From c4f9e34576c6662014c7785f24fc4a523607053a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Wed, 29 Jan 2025 10:35:39 +0100 Subject: [PATCH 01/29] JS runtime: implement more system primitives --- compiler/tests-check-prim/main.4.14.output | 16 +- compiler/tests-check-prim/main.5.2.output | 16 +- compiler/tests-check-prim/main.5.3.output | 16 +- .../tests-check-prim/unix-Unix.4.14.output | 30 ++- .../tests-check-prim/unix-Unix.5.2.output | 19 +- .../tests-check-prim/unix-Unix.5.3.output | 19 +- .../tests-check-prim/unix-Win32.4.14.output | 22 +- .../tests-check-prim/unix-Win32.5.2.output | 16 +- .../tests-check-prim/unix-Win32.5.3.output | 16 +- runtime/js/fs.js | 16 +- runtime/js/fs_fake.js | 17 ++ runtime/js/fs_node.js | 59 ++++++ runtime/js/unix.js | 194 +++++++++++++++++- 13 files changed, 369 insertions(+), 87 deletions(-) diff --git a/compiler/tests-check-prim/main.4.14.output b/compiler/tests-check-prim/main.4.14.output index 837ad8207f..01272e65e7 100644 --- a/compiler/tests-check-prim/main.4.14.output +++ b/compiler/tests-check-prim/main.4.14.output @@ -139,18 +139,28 @@ jsoo_toplevel_init_compile jsoo_toplevel_init_reloc From +unix.js: +caml_strerror +caml_sys_putenv +caml_unix_access +caml_unix_chdir +caml_unix_chmod caml_unix_cleanup caml_unix_close caml_unix_closedir +caml_unix_fchmod caml_unix_filedescr_of_fd caml_unix_findclose caml_unix_findfirst caml_unix_findnext caml_unix_fstat caml_unix_fstat_64 +caml_unix_fsync caml_unix_ftruncate caml_unix_ftruncate_64 -caml_unix_getpwuid +caml_unix_getegid +caml_unix_geteuid +caml_unix_getgid +caml_unix_getpwnam caml_unix_gettimeofday caml_unix_getuid caml_unix_gmtime @@ -158,6 +168,7 @@ caml_unix_has_symlink caml_unix_inchannel_of_filedescr caml_unix_inet_addr_of_string caml_unix_isatty +caml_unix_link caml_unix_localtime caml_unix_lookup_file caml_unix_lseek @@ -175,14 +186,17 @@ caml_unix_readlink caml_unix_rename caml_unix_rewinddir caml_unix_rmdir +caml_unix_single_write caml_unix_startup caml_unix_stat caml_unix_stat_64 caml_unix_symlink caml_unix_time +caml_unix_times caml_unix_truncate caml_unix_truncate_64 caml_unix_unlink caml_unix_utimes caml_unix_write +unix_error_message diff --git a/compiler/tests-check-prim/main.5.2.output b/compiler/tests-check-prim/main.5.2.output index bd6a3fa76b..9c0db80442 100644 --- a/compiler/tests-check-prim/main.5.2.output +++ b/compiler/tests-check-prim/main.5.2.output @@ -135,18 +135,28 @@ jsoo_toplevel_init_compile jsoo_toplevel_init_reloc From +unix.js: +caml_strerror +caml_sys_putenv +caml_unix_access +caml_unix_chdir +caml_unix_chmod caml_unix_cleanup caml_unix_close caml_unix_closedir +caml_unix_fchmod caml_unix_filedescr_of_fd caml_unix_findclose caml_unix_findfirst caml_unix_findnext caml_unix_fstat caml_unix_fstat_64 +caml_unix_fsync caml_unix_ftruncate caml_unix_ftruncate_64 -caml_unix_getpwuid +caml_unix_getegid +caml_unix_geteuid +caml_unix_getgid +caml_unix_getpwnam caml_unix_gettimeofday caml_unix_getuid caml_unix_gmtime @@ -154,6 +164,7 @@ caml_unix_has_symlink caml_unix_inchannel_of_filedescr caml_unix_inet_addr_of_string caml_unix_isatty +caml_unix_link caml_unix_localtime caml_unix_lookup_file caml_unix_lseek @@ -172,15 +183,18 @@ caml_unix_readlink caml_unix_rename caml_unix_rewinddir caml_unix_rmdir +caml_unix_single_write caml_unix_startup caml_unix_stat caml_unix_stat_64 caml_unix_symlink caml_unix_time +caml_unix_times caml_unix_truncate caml_unix_truncate_64 caml_unix_unlink caml_unix_utimes caml_unix_write caml_unix_write_bigarray +unix_error_message diff --git a/compiler/tests-check-prim/main.5.3.output b/compiler/tests-check-prim/main.5.3.output index d1f580ea3e..6167ae7545 100644 --- a/compiler/tests-check-prim/main.5.3.output +++ b/compiler/tests-check-prim/main.5.3.output @@ -133,18 +133,28 @@ jsoo_toplevel_init_compile jsoo_toplevel_init_reloc From +unix.js: +caml_strerror +caml_sys_putenv +caml_unix_access +caml_unix_chdir +caml_unix_chmod caml_unix_cleanup caml_unix_close caml_unix_closedir +caml_unix_fchmod caml_unix_filedescr_of_fd caml_unix_findclose caml_unix_findfirst caml_unix_findnext caml_unix_fstat caml_unix_fstat_64 +caml_unix_fsync caml_unix_ftruncate caml_unix_ftruncate_64 -caml_unix_getpwuid +caml_unix_getegid +caml_unix_geteuid +caml_unix_getgid +caml_unix_getpwnam caml_unix_gettimeofday caml_unix_getuid caml_unix_gmtime @@ -152,6 +162,7 @@ caml_unix_has_symlink caml_unix_inchannel_of_filedescr caml_unix_inet_addr_of_string caml_unix_isatty +caml_unix_link caml_unix_localtime caml_unix_lookup_file caml_unix_lseek @@ -170,15 +181,18 @@ caml_unix_readlink caml_unix_rename caml_unix_rewinddir caml_unix_rmdir +caml_unix_single_write caml_unix_startup caml_unix_stat caml_unix_stat_64 caml_unix_symlink caml_unix_time +caml_unix_times caml_unix_truncate caml_unix_truncate_64 caml_unix_unlink caml_unix_utimes caml_unix_write caml_unix_write_bigarray +unix_error_message diff --git a/compiler/tests-check-prim/unix-Unix.4.14.output b/compiler/tests-check-prim/unix-Unix.4.14.output index 7922e02de5..a6a6907210 100644 --- a/compiler/tests-check-prim/unix-Unix.4.14.output +++ b/compiler/tests-check-prim/unix-Unix.4.14.output @@ -18,11 +18,8 @@ caml_reset_afl_instrumentation caml_unix_map_file_bytecode debugger unix_accept -unix_access unix_alarm unix_bind -unix_chdir -unix_chmod unix_chown unix_chroot unix_clear_close_on_exec @@ -32,22 +29,13 @@ unix_dup unix_dup2 unix_environment unix_environment_unsafe -unix_error_message unix_execv unix_execve unix_execvp unix_execvpe -unix_fchmod unix_fchown unix_fork -unix_fsync unix_getaddrinfo -unix_getcwd -unix_getegid -unix_geteuid -unix_getgid -unix_getgrgid -unix_getgrnam unix_getgroups unix_gethostbyaddr unix_gethostbyname @@ -60,14 +48,12 @@ unix_getpid unix_getppid unix_getprotobyname unix_getprotobynumber -unix_getpwnam unix_getservbyname unix_getservbyport unix_getsockname unix_getsockopt unix_initgroups unix_kill -unix_link unix_listen unix_lockf unix_mkfifo @@ -92,7 +78,6 @@ unix_shutdown unix_sigpending unix_sigprocmask unix_sigsuspend -unix_single_write unix_sleep unix_socket unix_socketpair @@ -104,7 +89,6 @@ unix_tcflush unix_tcgetattr unix_tcsendbreak unix_tcsetattr -unix_times unix_umask unix_wait unix_waitpid @@ -231,18 +215,27 @@ jsoo_toplevel_init_compile jsoo_toplevel_init_reloc From +unix.js: +caml_sys_putenv +caml_unix_access +caml_unix_chdir +caml_unix_chmod caml_unix_cleanup caml_unix_close caml_unix_closedir +caml_unix_fchmod caml_unix_filedescr_of_fd caml_unix_findclose caml_unix_findfirst caml_unix_findnext caml_unix_fstat caml_unix_fstat_64 +caml_unix_fsync caml_unix_ftruncate caml_unix_ftruncate_64 -caml_unix_getpwuid +caml_unix_getegid +caml_unix_geteuid +caml_unix_getgid +caml_unix_getpwnam caml_unix_gettimeofday caml_unix_getuid caml_unix_gmtime @@ -250,6 +243,7 @@ caml_unix_has_symlink caml_unix_inchannel_of_filedescr caml_unix_inet_addr_of_string caml_unix_isatty +caml_unix_link caml_unix_localtime caml_unix_lookup_file caml_unix_lseek @@ -267,11 +261,13 @@ caml_unix_readlink caml_unix_rename caml_unix_rewinddir caml_unix_rmdir +caml_unix_single_write caml_unix_startup caml_unix_stat caml_unix_stat_64 caml_unix_symlink caml_unix_time +caml_unix_times caml_unix_truncate caml_unix_truncate_64 caml_unix_unlink diff --git a/compiler/tests-check-prim/unix-Unix.5.2.output b/compiler/tests-check-prim/unix-Unix.5.2.output index 25663a23da..31998ff808 100644 --- a/compiler/tests-check-prim/unix-Unix.5.2.output +++ b/compiler/tests-check-prim/unix-Unix.5.2.output @@ -9,11 +9,8 @@ caml_drop_continuation caml_int_as_pointer caml_reset_afl_instrumentation caml_unix_accept -caml_unix_access caml_unix_alarm caml_unix_bind -caml_unix_chdir -caml_unix_chmod caml_unix_chown caml_unix_chroot caml_unix_clear_close_on_exec @@ -23,22 +20,13 @@ caml_unix_dup caml_unix_dup2 caml_unix_environment caml_unix_environment_unsafe -caml_unix_error_message caml_unix_execv caml_unix_execve caml_unix_execvp caml_unix_execvpe -caml_unix_fchmod caml_unix_fchown caml_unix_fork -caml_unix_fsync caml_unix_getaddrinfo -caml_unix_getcwd -caml_unix_getegid -caml_unix_geteuid -caml_unix_getgid -caml_unix_getgrgid -caml_unix_getgrnam caml_unix_getgroups caml_unix_gethostbyaddr caml_unix_gethostbyname @@ -51,14 +39,12 @@ caml_unix_getpid caml_unix_getppid caml_unix_getprotobyname caml_unix_getprotobynumber -caml_unix_getpwnam caml_unix_getservbyname caml_unix_getservbyport caml_unix_getsockname caml_unix_getsockopt caml_unix_initgroups caml_unix_kill -caml_unix_link caml_unix_listen caml_unix_lockf caml_unix_map_file_bytecode @@ -84,7 +70,6 @@ caml_unix_shutdown caml_unix_sigpending caml_unix_sigprocmask caml_unix_sigsuspend -caml_unix_single_write caml_unix_sleep caml_unix_socket caml_unix_socketpair @@ -96,7 +81,6 @@ caml_unix_tcflush caml_unix_tcgetattr caml_unix_tcsendbreak caml_unix_tcsetattr -caml_unix_times caml_unix_umask caml_unix_wait caml_unix_waitpid @@ -227,10 +211,13 @@ jsoo_toplevel_init_compile jsoo_toplevel_init_reloc From +unix.js: +caml_strerror +caml_sys_putenv caml_unix_cleanup caml_unix_filedescr_of_fd caml_unix_findclose caml_unix_findfirst caml_unix_findnext caml_unix_startup +unix_error_message diff --git a/compiler/tests-check-prim/unix-Unix.5.3.output b/compiler/tests-check-prim/unix-Unix.5.3.output index 4184d40762..4a9f4a1f92 100644 --- a/compiler/tests-check-prim/unix-Unix.5.3.output +++ b/compiler/tests-check-prim/unix-Unix.5.3.output @@ -8,11 +8,8 @@ caml_continuation_use caml_int_as_pointer caml_reset_afl_instrumentation caml_unix_accept -caml_unix_access caml_unix_alarm caml_unix_bind -caml_unix_chdir -caml_unix_chmod caml_unix_chown caml_unix_chroot caml_unix_clear_close_on_exec @@ -22,22 +19,13 @@ caml_unix_dup caml_unix_dup2 caml_unix_environment caml_unix_environment_unsafe -caml_unix_error_message caml_unix_execv caml_unix_execve caml_unix_execvp caml_unix_execvpe -caml_unix_fchmod caml_unix_fchown caml_unix_fork -caml_unix_fsync caml_unix_getaddrinfo -caml_unix_getcwd -caml_unix_getegid -caml_unix_geteuid -caml_unix_getgid -caml_unix_getgrgid -caml_unix_getgrnam caml_unix_getgroups caml_unix_gethostbyaddr caml_unix_gethostbyname @@ -50,14 +38,12 @@ caml_unix_getpid caml_unix_getppid caml_unix_getprotobyname caml_unix_getprotobynumber -caml_unix_getpwnam caml_unix_getservbyname caml_unix_getservbyport caml_unix_getsockname caml_unix_getsockopt caml_unix_initgroups caml_unix_kill -caml_unix_link caml_unix_listen caml_unix_lockf caml_unix_map_file_bytecode @@ -83,7 +69,6 @@ caml_unix_shutdown caml_unix_sigpending caml_unix_sigprocmask caml_unix_sigsuspend -caml_unix_single_write caml_unix_sleep caml_unix_socket caml_unix_socketpair @@ -95,7 +80,6 @@ caml_unix_tcflush caml_unix_tcgetattr caml_unix_tcsendbreak caml_unix_tcsetattr -caml_unix_times caml_unix_umask caml_unix_wait caml_unix_waitpid @@ -225,10 +209,13 @@ jsoo_toplevel_init_compile jsoo_toplevel_init_reloc From +unix.js: +caml_strerror +caml_sys_putenv caml_unix_cleanup caml_unix_filedescr_of_fd caml_unix_findclose caml_unix_findfirst caml_unix_findnext caml_unix_startup +unix_error_message diff --git a/compiler/tests-check-prim/unix-Win32.4.14.output b/compiler/tests-check-prim/unix-Win32.4.14.output index ce3b1b2851..80dfdc0f2b 100644 --- a/compiler/tests-check-prim/unix-Win32.4.14.output +++ b/compiler/tests-check-prim/unix-Win32.4.14.output @@ -18,23 +18,17 @@ caml_reset_afl_instrumentation caml_unix_map_file_bytecode debugger unix_accept -unix_access unix_bind -unix_chdir -unix_chmod unix_clear_nonblock unix_connect unix_dup unix_dup2 unix_environment -unix_error_message unix_execv unix_execve unix_execvp unix_execvpe -unix_fsync unix_getaddrinfo -unix_getcwd unix_gethostbyaddr unix_gethostbyname unix_gethostname @@ -47,7 +41,6 @@ unix_getservbyname unix_getservbyport unix_getsockname unix_getsockopt -unix_link unix_listen unix_lockf unix_pipe @@ -61,12 +54,10 @@ unix_sendto unix_set_nonblock unix_setsockopt unix_shutdown -unix_single_write unix_sleep unix_socket unix_socketpair unix_string_of_inet_addr -unix_times win_clear_close_on_exec win_create_process win_set_close_on_exec @@ -196,18 +187,26 @@ jsoo_toplevel_init_compile jsoo_toplevel_init_reloc From +unix.js: +caml_unix_access +caml_unix_chdir +caml_unix_chmod caml_unix_cleanup caml_unix_close caml_unix_closedir +caml_unix_fchmod caml_unix_filedescr_of_fd caml_unix_findclose caml_unix_findfirst caml_unix_findnext caml_unix_fstat caml_unix_fstat_64 +caml_unix_fsync caml_unix_ftruncate caml_unix_ftruncate_64 -caml_unix_getpwuid +caml_unix_getegid +caml_unix_geteuid +caml_unix_getgid +caml_unix_getpwnam caml_unix_gettimeofday caml_unix_getuid caml_unix_gmtime @@ -215,6 +214,7 @@ caml_unix_has_symlink caml_unix_inchannel_of_filedescr caml_unix_inet_addr_of_string caml_unix_isatty +caml_unix_link caml_unix_localtime caml_unix_lookup_file caml_unix_lseek @@ -232,11 +232,13 @@ caml_unix_readlink caml_unix_rename caml_unix_rewinddir caml_unix_rmdir +caml_unix_single_write caml_unix_startup caml_unix_stat caml_unix_stat_64 caml_unix_symlink caml_unix_time +caml_unix_times caml_unix_truncate caml_unix_truncate_64 caml_unix_unlink diff --git a/compiler/tests-check-prim/unix-Win32.5.2.output b/compiler/tests-check-prim/unix-Win32.5.2.output index e556d8cbee..17f9d5b88e 100644 --- a/compiler/tests-check-prim/unix-Win32.5.2.output +++ b/compiler/tests-check-prim/unix-Win32.5.2.output @@ -9,10 +9,7 @@ caml_drop_continuation caml_int_as_pointer caml_reset_afl_instrumentation caml_unix_accept -caml_unix_access caml_unix_bind -caml_unix_chdir -caml_unix_chmod caml_unix_clear_close_on_exec caml_unix_clear_nonblock caml_unix_connect @@ -20,15 +17,12 @@ caml_unix_create_process caml_unix_dup caml_unix_dup2 caml_unix_environment -caml_unix_error_message caml_unix_execv caml_unix_execve caml_unix_execvp caml_unix_execvpe caml_unix_filedescr_of_channel -caml_unix_fsync caml_unix_getaddrinfo -caml_unix_getcwd caml_unix_gethostbyaddr caml_unix_gethostbyname caml_unix_gethostname @@ -41,7 +35,6 @@ caml_unix_getservbyname caml_unix_getservbyport caml_unix_getsockname caml_unix_getsockopt -caml_unix_link caml_unix_listen caml_unix_lockf caml_unix_map_file_bytecode @@ -57,14 +50,12 @@ caml_unix_set_close_on_exec caml_unix_set_nonblock caml_unix_setsockopt caml_unix_shutdown -caml_unix_single_write caml_unix_sleep caml_unix_socket caml_unix_socketpair caml_unix_string_of_inet_addr caml_unix_system caml_unix_terminate_process -caml_unix_times caml_unix_waitpid debugger @@ -193,7 +184,14 @@ jsoo_toplevel_init_compile jsoo_toplevel_init_reloc From +unix.js: +caml_strerror caml_unix_getpwuid +caml_unix_fchmod +caml_unix_getegid +caml_unix_geteuid +caml_unix_getgid +caml_unix_getpwnam caml_unix_getuid caml_unix_rewinddir +unix_error_message diff --git a/compiler/tests-check-prim/unix-Win32.5.3.output b/compiler/tests-check-prim/unix-Win32.5.3.output index 3259dfbe8b..a843e0f31f 100644 --- a/compiler/tests-check-prim/unix-Win32.5.3.output +++ b/compiler/tests-check-prim/unix-Win32.5.3.output @@ -8,10 +8,7 @@ caml_continuation_use caml_int_as_pointer caml_reset_afl_instrumentation caml_unix_accept -caml_unix_access caml_unix_bind -caml_unix_chdir -caml_unix_chmod caml_unix_clear_close_on_exec caml_unix_clear_nonblock caml_unix_connect @@ -19,15 +16,12 @@ caml_unix_create_process caml_unix_dup caml_unix_dup2 caml_unix_environment -caml_unix_error_message caml_unix_execv caml_unix_execve caml_unix_execvp caml_unix_execvpe caml_unix_filedescr_of_channel -caml_unix_fsync caml_unix_getaddrinfo -caml_unix_getcwd caml_unix_gethostbyaddr caml_unix_gethostbyname caml_unix_gethostname @@ -40,7 +34,6 @@ caml_unix_getservbyname caml_unix_getservbyport caml_unix_getsockname caml_unix_getsockopt -caml_unix_link caml_unix_listen caml_unix_lockf caml_unix_map_file_bytecode @@ -56,14 +49,12 @@ caml_unix_set_close_on_exec caml_unix_set_nonblock caml_unix_setsockopt caml_unix_shutdown -caml_unix_single_write caml_unix_sleep caml_unix_socket caml_unix_socketpair caml_unix_string_of_inet_addr caml_unix_system caml_unix_terminate_process -caml_unix_times caml_unix_waitpid debugger @@ -191,7 +182,14 @@ jsoo_toplevel_init_compile jsoo_toplevel_init_reloc From +unix.js: +caml_strerror caml_unix_getpwuid +caml_unix_fchmod +caml_unix_getegid +caml_unix_geteuid +caml_unix_getgid +caml_unix_getpwnam caml_unix_getuid caml_unix_rewinddir +unix_error_message diff --git a/runtime/js/fs.js b/runtime/js/fs.js index dc8cfcb0da..db8002262b 100644 --- a/runtime/js/fs.js +++ b/runtime/js/fs.js @@ -198,13 +198,15 @@ function caml_unmount(name) { //Provides: caml_sys_getcwd //Requires: caml_current_dir, caml_string_of_jsstring +//Alias: caml_unix_getcwd +//Alias: unix_getcwd function caml_sys_getcwd() { return caml_string_of_jsstring(caml_current_dir); } //Provides: caml_sys_chdir -//Requires: caml_current_dir, caml_raise_no_such_file, resolve_fs_device, caml_trailing_slash, caml_jsstring_of_string, caml_raise_sys_error -function caml_sys_chdir(dir) { +//Requires: caml_current_dir, caml_raise_no_such_file, resolve_fs_device, caml_trailing_slash, caml_jsstring_of_string, caml_raise_system_error +function caml_sys_chdir(dir, raise_unix) { var root = resolve_fs_device(dir); if (root.device.is_dir(root.rest)) { if (root.rest) @@ -212,11 +214,15 @@ function caml_sys_chdir(dir) { else caml_current_dir = root.path; return 0; } else if (root.device.exists(root.rest)) { - caml_raise_sys_error( - "ENOTDIR: not a directory, chdir '" + caml_jsstring_of_string(dir) + "'", + caml_raise_system_error( + raise_unix, + "ENOTDIR", + "chdir", + "not a directory", + caml_jsstring_of_string(dir), ); } else { - caml_raise_no_such_file(caml_jsstring_of_string(dir)); + caml_raise_no_such_file(caml_jsstring_of_string(dir), raise_unix); } } diff --git a/runtime/js/fs_fake.js b/runtime/js/fs_fake.js index d5af726d7a..0273b9a8bb 100644 --- a/runtime/js/fs_fake.js +++ b/runtime/js/fs_fake.js @@ -203,6 +203,23 @@ MlFakeDevice.prototype.unlink = function (name, raise_unix) { delete this.content[name]; return 0; }; +MlFakeDevice.prototype.access = function (name, f, raise_unix) { + var file; + this.lookup(name); + if (this.content[name]) { + if (this.is_dir(name)) + caml_raise_system_error( + raise_unix, + "EACCESS", + "access", + "permission denied,", + this.nm(name), + ); + } else { + caml_raise_no_such_file(this.nm(name), raise_unix); + } + return 0; +}; MlFakeDevice.prototype.open = function (name, f, _perms, raise_unix) { var file; this.lookup(name); diff --git a/runtime/js/fs_node.js b/runtime/js/fs_node.js index 5085c87d11..38be7f8cfb 100644 --- a/runtime/js/fs_node.js +++ b/runtime/js/fs_node.js @@ -113,6 +113,33 @@ MlNodeDevice.prototype.truncate = function (name, len, raise_unix) { caml_raise_nodejs_error(err, raise_unix); } }; +MlNodeDevice.prototype.access = function (name, f, raise_unix) { + var consts = require("node:constants"); + var res = 0; + for (var key in f) { + switch (key) { + case "r": + res |= consts.R_OK; + break; + case "w": + res |= consts.W_OK; + break; + case "x": + res |= + globalThis.process?.platform === "win32" ? consts.R_OK : consts.X_OK; + break; + case "f": + res |= consts.F_OK; + break; + } + } + try { + this.fs.accessSync(this.nm(name), res); + return 0; + } catch (err) { + caml_raise_nodejs_error(err, raise_unix); + } +}; MlNodeDevice.prototype.open = function (name, f, perms, raise_unix) { var consts = require("node:constants"); var res = 0; @@ -226,6 +253,22 @@ MlNodeDevice.prototype.lstat = function (name, large, raise_unix) { caml_raise_nodejs_error(err, raise_unix); } }; +MlNodeDevice.prototype.chmod = function (name, perms, raise_unix) { + try { + this.fs.chmodSync(this.nm(name), perms); + return 0; + } catch (err) { + caml_raise_nodejs_error(err, raise_unix); + } +}; +MlNodeDevice.prototype.link = function (target, path, raise_unix) { + try { + this.fs.linkSync(this.nm(target), this.nm(path)); + return 0; + } catch (err) { + caml_raise_nodejs_error(err, raise_unix); + } +}; MlNodeDevice.prototype.symlink = function (to_dir, target, path, raise_unix) { try { this.fs.symlinkSync( @@ -409,6 +452,22 @@ MlNodeFd.prototype.stat = function (large) { caml_raise_nodejs_error(err, /* raise Unix_error */ 1); } }; +MlNodeFd.prototype.chmod = function (perms) { + try { + this.fs.fchmodSync(this.fd, perms); + return 0; + } catch (err) { + caml_raise_nodejs_error(err, /* raise Unix_error */ 1); + } +}; +MlNodeFd.prototype.sync = function () { + try { + this.fs.fsyncSync(this.fd); + return 0; + } catch (err) { + caml_raise_nodejs_error(err, /* raise Unix_error */ 1); + } +}; MlNodeFd.prototype.close = function (raise_unix) { try { this.fs.closeSync(this.fd); diff --git a/runtime/js/unix.js b/runtime/js/unix.js index cb576e490e..f74fef8141 100644 --- a/runtime/js/unix.js +++ b/runtime/js/unix.js @@ -11,6 +11,20 @@ function caml_unix_time() { return Math.floor(caml_unix_gettimeofday()); } +//Provides: caml_unix_times +//Requires: caml_failwith +//Alias: unix_times +function caml_unix_times() { + if (globalThis.process && globalThis.process.cpuUsage) { + var t = globalThis.process.cpuUsage(); + return BLOCK(0, t.user / 1e6, t.system / 1e6, 0, 0); + } else if (globalThis.performance && globalThis.performance.now) { + return BLOCK(0, globalThis.performance.now() / 1000, 0, 0, 0); + } else { + caml_failwith("caml_unix_times: not implemented"); + } +} + //Provides: caml_unix_gmtime //Alias: unix_gmtime function caml_unix_gmtime(t) { @@ -77,6 +91,22 @@ function caml_unix_startup() {} //Alias: win_cleanup function caml_unix_cleanup() {} +//Provides: caml_sys_putenv (const, const) +//Requires: caml_jsstring_of_string, jsoo_static_env +function caml_sys_putenv(name, value) { + var name = caml_jsstring_of_string(name); + var value = caml_jsstring_of_string(value); + delete jsoo_static_env[name]; + //nodejs env + var process = globalThis.process; + if (process && process.env) { + process.env[name] = value; + return 0; + } + if (!globalThis.jsoo_env) globalThis.jsoo_env = {}; + globalThis.jsoo_env[name] = value; +} + //Provides: caml_unix_filedescr_of_fd const //Alias: win_handle_fd function caml_unix_filedescr_of_fd(x) { @@ -199,6 +229,36 @@ function make_unix_err_args(code, syscall, path, errno) { return args; } +//Provides: caml_strerror +//Requires: unix_error +function caml_strerror(errno) { + const util = require("node:util"); + if (errno >= 0) { + const code = unix_error[errno]; + return util + .getSystemErrorMap() + .entries() + .find((x) => x[1][0] === code)[1][1]; + } else { + return util.getSystemErrorMessage(errno); + } +} + +//Provides: unix_error_message +//Alias: caml_unix_error_message +//Requires: caml_strerror, caml_string_of_jsstring +function unix_error_message(err) { + const errno = typeof err === "number" ? err : -err[1]; + return caml_string_of_jsstring(caml_strerror(errno)); +} + +//Provides: caml_unix_chdir +//Requires: caml_sys_chdir +//Alias: unix_chdir +function caml_unix_chdir(dir) { + return caml_sys_chdir(dir, /* raise Unix_error */ true); +} + //Provides: caml_unix_stat //Requires: resolve_fs_device, caml_failwith //Alias: unix_stat @@ -259,6 +319,17 @@ function caml_unix_lstat_64(name) { ); } +//Provides: caml_unix_chmod +//Requires: resolve_fs_device, caml_failwith +//Alias: unix_chmod +function caml_unix_chmod(name, perms) { + var root = resolve_fs_device(name); + if (!root.device.chmod) { + caml_failwith("caml_unix_chmod: not implemented"); + } + return root.device.chmod(root.rest, perms); +} + //Provides: caml_unix_rename //Requires: caml_failwith, resolve_fs_device //Requires: caml_raise_system_error @@ -294,6 +365,26 @@ function caml_unix_rmdir(name) { return root.device.rmdir(root.rest, /* raise Unix_error */ true); } +//Provides: caml_unix_link +//Requires: resolve_fs_device, caml_failwith, caml_raise_system_error +//Alias: unix_link +function caml_unix_link(follow, src, dst) { + var src_root = resolve_fs_device(src); + var dst_root = resolve_fs_device(dst); + if (!src_root.device.link) { + caml_failwith("caml_unix_link: not implemented"); + } + if (typeof follow !== "number") + caml_raise_system_error(/* raise Unix_error */ 1, "ENOSYS", "link"); + if (src_root.device !== dst_root.device) + caml_raise_system_error(/* raise Unix_error */ 1, "EXDEV", "link"); + return src_root.device.link( + src_root.rest, + dst_root.rest, + /* raise Unix_error */ true, + ); +} + //Provides: caml_unix_symlink //Requires: resolve_fs_device, caml_failwith, caml_jsstring_of_string //Alias: unix_symlink @@ -373,6 +464,36 @@ function caml_unix_truncate_64(name, len) { return 0; } +//Provides: caml_unix_access +//Requires: resolve_fs_device, caml_failwith +//Alias: unix_access +function caml_unix_access(name, flags) { + var f = {}; + while (flags) { + switch (flags[1]) { + case 0: + f.r = 1; + break; + case 1: + f.w = 1; + break; + case 2: + f.x = 1; + break; + case 3: + f.f = 1; + break; + } + flags = flags[2]; + } + var root = resolve_fs_device(name); + if (!root.device.access) { + caml_failwith("caml_unix_access: not implemented"); + } + root.device.access(root.rest, f, /* raise Unix_error */ true); + return 0; +} + //Provides: caml_unix_open //Requires: resolve_fs_device, caml_sys_fds, MlChanid //Alias: unix_open @@ -455,6 +576,28 @@ function caml_unix_fstat_64(fd) { return file.stat(/* large */ true); } +//Provides: caml_unix_fchmod +//Alias: unix_fchmod +//Requires: caml_unix_lookup_file, caml_failwith +function caml_unix_fchmod(fd, perms) { + var file = caml_unix_lookup_file(fd, "fchmod"); + if (!file.chmod) { + caml_failwith("caml_unix_fchmod: not implemented"); + } + return file.chmod(perms); +} + +//Provides: caml_unix_fsync +//Alias: unix_fsync +//Requires: caml_unix_lookup_file, caml_failwith +function caml_unix_fsync(fd) { + var file = caml_unix_lookup_file(fd, "fsync"); + if (!file.sync) { + caml_failwith("caml_unix_fsync: not implemented"); + } + return file.sync(); +} + //Provides: caml_unix_write //Alias: unix_write //Requires: caml_unix_lookup_file, caml_uint8_array_of_bytes @@ -471,6 +614,20 @@ function caml_unix_write(fd, buf, pos, len) { return written; } +//Provides: caml_unix_single_write +//Alias: unix_single_write +//Requires: caml_unix_lookup_file, caml_uint8_array_of_bytes +function caml_unix_single_write(fd, buf, pos, len) { + var file = caml_unix_lookup_file(fd, "write"); + if (len === 0) return 0; + return file.write( + caml_uint8_array_of_bytes(buf), + pos, + len, + /* raise unix_error */ 1, + ); +} + //Provides: caml_unix_write_bigarray //Alias: caml_unix_lookup_file //Requires: caml_ba_to_typed_array, caml_unix_lookup_file @@ -589,10 +746,43 @@ function caml_unix_getuid(unit) { return 1; } -//Provides: caml_unix_getpwuid +//Provides: caml_unix_geteuid +//Alias: unix_geteuid +function caml_unix_geteuid(unit) { + if (globalThis.process && globalThis.process.geteuid) { + return globalThis.process.geteuid(); + } + return 1; +} + +//Provides: caml_unix_getgid +//Alias: unix_getgid +function caml_unix_getgid(unit) { + if (globalThis.process && globalThis.process.getgid) { + return globalThis.process.getgid(); + } + return 1; +} + +//Provides: caml_unix_getegid +//Alias: unix_getegid +function caml_unix_getegid(unit) { + if (globalThis.process && globalThis.process.getegid) { + return globalThis.process.getegid(); + } + return 1; +} + +//Provides: caml_unix_getpwnam //Requires: caml_raise_not_found +//Alias: unix_getpwnam +//Alias: caml_unix_getpwuid //Alias: unix_getpwuid -function caml_unix_getpwuid(unit) { +//Alias: caml_unix_getgrnam +//Alias: unix_getgrnam +//Alias: caml_unix_getgrgid +//Alias: unix_getgrgid +function caml_unix_getpwnam(unit) { caml_raise_not_found(); } From ac4bfc7d36a9330ca2f5bdd39b31f9b8cb2e65c9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Wed, 29 Jan 2025 10:41:07 +0100 Subject: [PATCH 02/29] Wasm runtime: clean-up --- runtime/wasm/fs.wat | 17 +++++++++-------- runtime/wasm/runtime.js | 2 +- runtime/wasm/unix.wat | 26 +++++++++++++------------- 3 files changed, 23 insertions(+), 22 deletions(-) diff --git a/runtime/wasm/fs.wat b/runtime/wasm/fs.wat index e4ba3664a4..eca2fc5487 100644 --- a/runtime/wasm/fs.wat +++ b/runtime/wasm/fs.wat @@ -21,8 +21,8 @@ (import "bindings" "mkdir" (func $mkdir (param anyref) (param i32))) (import "bindings" "rmdir" (func $rmdir (param anyref))) (import "bindings" "unlink" (func $unlink (param anyref))) - (import "bindings" "readdir" - (func $readdir (param anyref) (result (ref extern)))) + (import "bindings" "read_dir" + (func $read_dir (param anyref) (result (ref extern)))) (import "bindings" "file_exists" (func $file_exists (param anyref) (result (ref eq)))) (import "bindings" "is_directory" @@ -47,7 +47,12 @@ (func (export "caml_sys_getcwd") (param (ref eq)) (result (ref eq)) - (return_call $caml_string_of_jsstring (call $wrap (call $getcwd)))) + (try (result (ref eq)) + (do + (call $caml_string_of_jsstring (call $wrap (call $getcwd)))) + (catch $javascript_exception + (call $caml_handle_sys_error (pop externref)) + (ref.i31 (i32.const 0))))) (func (export "caml_sys_chdir") (param $name (ref eq)) (result (ref eq)) @@ -76,7 +81,7 @@ (do (return (call $caml_js_to_string_array - (call $readdir + (call $read_dir (call $unwrap (call $caml_jsstring_of_string (local.get $name))))))) (catch $javascript_exception @@ -137,8 +142,6 @@ (local.get $msg) (local.get $len) (i32.const 0) (i32.const 27)) (call $caml_raise_sys_error (local.get $msg))) - (data $caml_read_file_content "caml_read_file_content") - (func (export "caml_read_file_content") (param (ref eq)) (result (ref eq)) (call $caml_raise_no_such_file (local.get 0)) @@ -147,8 +150,6 @@ (func (export "caml_fs_init") (result (ref eq)) (ref.i31 (i32.const 0))) - (data $caml_sys_is_directory "caml_sys_is_directory") - (func (export "caml_sys_is_directory") (param $name (ref eq)) (result (ref eq)) (try diff --git a/runtime/wasm/runtime.js b/runtime/wasm/runtime.js index 1de4458c2c..1b5197896d 100644 --- a/runtime/wasm/runtime.js +++ b/runtime/wasm/runtime.js @@ -455,7 +455,7 @@ mkdir: (p, m) => fs.mkdirSync(p, m), rmdir: (p) => fs.rmdirSync(p), unlink: (p) => fs.unlinkSync(p), - readdir: (p) => fs.readdirSync(p), + read_dir: (p) => fs.readdirSync(p), stat: (p, l) => alloc_stat(fs.statSync(p), l), lstat: (p, l) => alloc_stat(fs.lstatSync(p), l), fstat: (fd, l) => alloc_stat(fs.fstatSync(fd), l), diff --git a/runtime/wasm/unix.wat b/runtime/wasm/unix.wat index 0e5fbf7535..e1e0a912a9 100644 --- a/runtime/wasm/unix.wat +++ b/runtime/wasm/unix.wat @@ -219,23 +219,22 @@ (ref.i31 (local.get $yday)) (ref.i31 (local.get $isdst)))) - (export "caml_unix_gmtime" (func $unix_gmtime)) - (func $unix_gmtime (export "unix_gmtime") (param (ref eq)) (result (ref eq)) + (func $unix_gmtime (export "unix_gmtime") (export "caml_unix_gmtime") + (param (ref eq)) (result (ref eq)) (call $gmtime (struct.get $float 0 (ref.cast (ref $float) (local.get 0))))) - (export "caml_unix_localtime" (func $unix_localtime)) - (func $unix_localtime (export "unix_localtime") + (func $unix_localtime (export "unix_localtime") (export "caml_unix_localtime") (param (ref eq)) (result (ref eq)) (call $localtime (struct.get $float 0 (ref.cast (ref $float) (local.get 0))))) - (export "caml_unix_time" (func $unix_time)) - (func $unix_time (export "unix_time") (param (ref eq)) (result (ref eq)) + (func $unix_time (export "unix_time") (export "caml_unix_time") + (param (ref eq)) (result (ref eq)) (struct.new $float (f64.floor (call $gettimeofday)))) - (export "caml_unix_mktime" (func $unix_mktime)) - (func $unix_mktime (export "unix_mktime") (param (ref eq)) (result (ref eq)) + (func $unix_mktime (export "unix_mktime") (export "caml_unix_mktime") + (param (ref eq)) (result (ref eq)) (local $tm (ref $block)) (local $t f64) (local.set $tm (ref.cast (ref $block) (local.get 0))) (local.set $t @@ -789,15 +788,16 @@ (export "unix_isatty" (func $isatty)) (export "caml_unix_isatty" (func $isatty)) - (export "caml_unix_inet_addr_of_string" (func $unix_inet_addr_of_string)) - (func $unix_inet_addr_of_string (export "unix_inet_addr_of_string") + (func (export "unix_inet_addr_of_string") + (export "caml_unix_inet_addr_of_string") (param (ref eq)) (result (ref eq)) (ref.i31 (i32.const 0))) - (export "caml_unix_filedescr_of_fd" (func $unix_filedescr_of_fd)) - (func $unix_filedescr_of_fd (export "unix_filedescr_of_fd") + + (func (export "win_handle_fd") (export "caml_unix_filedescr_of_fd") (param (ref eq)) (result (ref eq)) (local.get 0)) - (func $unix_cleanup (export "caml_unix_cleanup") + + (func (export "win_cleanup") (export "caml_unix_cleanup") (param (ref eq)) (result (ref eq)) (ref.i31 (i32.const 0))) ) From 7ce1c0445b06e455417cbd42039f9b4b1c8fa385 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Wed, 29 Jan 2025 21:19:31 +0100 Subject: [PATCH 03/29] Wasm runtime: implement more system primitives --- runtime/wasm/deps.json | 9 + runtime/wasm/fs.wat | 14 ++ runtime/wasm/io.wat | 23 +++ runtime/wasm/runtime.js | 33 ++++ runtime/wasm/sys.wat | 8 +- runtime/wasm/unix.wat | 359 ++++++++++++++++++++++++++++++++++++++-- 6 files changed, 426 insertions(+), 20 deletions(-) diff --git a/runtime/wasm/deps.json b/runtime/wasm/deps.json index cb37130f87..4a2173c983 100644 --- a/runtime/wasm/deps.json +++ b/runtime/wasm/deps.json @@ -72,6 +72,15 @@ "import": ["bindings", "wrap_meth_callback_unsafe"], "reaches": ["callback"] }, + { + "name": "alloc_times", + "export": "caml_alloc_times" + }, + { + "name": "times", + "import": ["bindings", "times"], + "reaches": ["alloc_times"] + }, { "name": "alloc_tm", "export": "caml_alloc_tm" diff --git a/runtime/wasm/fs.wat b/runtime/wasm/fs.wat index eca2fc5487..abe6dab066 100644 --- a/runtime/wasm/fs.wat +++ b/runtime/wasm/fs.wat @@ -27,6 +27,8 @@ (func $file_exists (param anyref) (result (ref eq)))) (import "bindings" "is_directory" (func $is_directory (param anyref) (result (ref eq)))) + (import "bindings" "is_file" + (func $is_file (param anyref) (result (ref eq)))) (import "bindings" "rename" (func $rename (param anyref) (param anyref))) (import "jslib" "wrap" (func $wrap (param anyref) (result (ref eq)))) (import "jslib" "unwrap" (func $unwrap (param (ref eq)) (result anyref))) @@ -161,4 +163,16 @@ (catch $javascript_exception (call $caml_handle_sys_error (pop externref)) (return (ref.i31 (i32.const 0)))))) + + (func (export "caml_sys_is_regular_file") + (param $name (ref eq)) (result (ref eq)) + (try + (do + (return + (call $is_file + (call $unwrap + (call $caml_jsstring_of_string (local.get $name)))))) + (catch $javascript_exception + (call $caml_handle_sys_error (pop externref)) + (return (ref.i31 (i32.const 0)))))) ) diff --git a/runtime/wasm/io.wat b/runtime/wasm/io.wat index fc07d84d02..3a4b2086e1 100644 --- a/runtime/wasm/io.wat +++ b/runtime/wasm/io.wat @@ -315,6 +315,18 @@ (param (ref eq)) (result (ref eq)) (ref.i31 (i32.const 1))) + (func (export "caml_channel_descriptor") + (param $ch (ref eq)) (result (ref eq)) + (local $fd i32) + (local.set $fd + (struct.get $channel $fd (ref.cast (ref $channel) (local.get $ch)))) + (if (i32.eq (local.get $fd) (i32.const -1)) + (then + (call $caml_raise_sys_error + (array.new_data $bytes $bad_file_descriptor + (i32.const 0) (i32.const 19))))) + (ref.i31 (local.get $fd))) + (func (export "caml_ml_close_channel") (param (ref eq)) (result (ref eq)) (local $ch (ref $channel)) @@ -605,6 +617,17 @@ (struct.get $channel $fd (local.get $ch)))) (i64.extend_i32_s (struct.get $channel $curr (local.get $ch)))))) +(;ZZZ + (func $check_valid_offset + (param $fd i32) (param $offset i64) (param $prev_offset i64) + (if (i32.or (i32.lt_s (local.get $offset (i64.const 0))) + (i32.gt_s (local.get $offset) + (call $file_size (local.get $fd))))) + (then + ;;; + ))) +;) + (func $caml_seek_in (param $ch (ref $channel)) (param $dest i64) (result (ref eq)) (local $fd i32) (local $offset i64) diff --git a/runtime/wasm/runtime.js b/runtime/wasm/runtime.js index 1b5197896d..6cc148ae52 100644 --- a/runtime/wasm/runtime.js +++ b/runtime/wasm/runtime.js @@ -70,6 +70,10 @@ const fs_cst = fs?.constants; + const access_flags = fs + ? [fs_cst.R_OK, fs_cst.W_OK, fs_cst.X_OK, fs_cst.F_OK] + : []; + const open_flags = fs ? [ fs_cst.O_RDONLY, @@ -374,6 +378,15 @@ return pad ? " " + s : s; }, gettimeofday: () => new Date().getTime() / 1000, + times: () => { + if (globalThis.process?.cpuUsage) { + var t = globalThis.process.cpuUsage(); + return caml_alloc_times(t.user / 1e6, t.system / 1e6); + } else { + var t = performance.now() / 1000; + return call_alloc_times(t, t); + } + }, gmtime: (t) => { var d = new Date(t * 1000); var d_num = d.getTime(); @@ -417,6 +430,11 @@ mktime: (year, month, day, h, m, s) => new Date(year, month, day, h, m, s).getTime(), random_seed: () => crypto.getRandomValues(new Int32Array(12)), + access: (p, flags) => + fs.accessSync( + p, + access_flags.reduce((f, v, i) => (flags & (1 << i) ? f | v : f), 0), + ), open: (p, flags, perm) => fs.openSync( p, @@ -432,6 +450,7 @@ ), l), read: (fd, b, o, l, p) => fs.readSync(fd, b, o, l, p), + fsync: (fd) => fs.fsyncSync(fd), file_size: (fd) => fs.fstatSync(fd, { bigint: true }).size, register_channel, unregister_channel, @@ -440,6 +459,7 @@ argv: () => (isNode ? process.argv.slice(1) : ["a.out"]), on_windows: +on_windows, getenv: (n) => (isNode ? process.env[n] : null), + putenv: (n, v) => process.env[n] = v, system: (c) => { var res = require("node:child_process").spawnSync(c, { shell: true, @@ -454,13 +474,25 @@ chdir: (x) => process.chdir(x), mkdir: (p, m) => fs.mkdirSync(p, m), rmdir: (p) => fs.rmdirSync(p), + link: (d, s) => fs.linkSync(d, s), + symlink: (t, p, kind) => fs.symlinkSync(t, p, [null, "file", "dir"][kind]), + readlink: (p) => fs.readlinkSync(p), unlink: (p) => fs.unlinkSync(p), read_dir: (p) => fs.readdirSync(p), + opendir: (p) => fs.opendirSync(p), + readdir: (d) => { + var n = d.readSync()?.name; + return n === undefined ? null : n; + }, + closedir: (d) => d.closeSync(), stat: (p, l) => alloc_stat(fs.statSync(p), l), lstat: (p, l) => alloc_stat(fs.lstatSync(p), l), fstat: (fd, l) => alloc_stat(fs.fstatSync(fd), l), + chmod: (p, perms) => fs.chmodSync(p, perms), + fchmod: (p, perms) => fs.fchmodSync(p, perms), file_exists: (p) => +fs.existsSync(p), is_directory: (p) => +fs.lstatSync(p).isDirectory(), + is_file: (p) => +fs.lstatSync(p).isFile(), utimes: (p, a, m) => fs.utimesSync(p, a, m), truncate: (p, l) => fs.truncateSync(p, l), ftruncate: (fd, l) => fs.ftruncateSync(fd, l), @@ -583,6 +615,7 @@ var { caml_callback, + caml_alloc_times, caml_alloc_tm, caml_alloc_stat, caml_start_fiber, diff --git a/runtime/wasm/sys.wat b/runtime/wasm/sys.wat index 6cfa7817e1..feff58e716 100644 --- a/runtime/wasm/sys.wat +++ b/runtime/wasm/sys.wat @@ -37,6 +37,8 @@ (import "fail" "caml_raise_not_found" (func $caml_raise_not_found)) (import "bindings" "argv" (func $argv (result (ref extern)))) (import "bindings" "on_windows" (global $on_windows i32)) + (import "bindings" "isatty" + (func $isatty (param (ref eq)) (result (ref eq)))) (import "bindings" "system" (func $system (param anyref) (result (ref eq)))) (import "bindings" "getenv" (func $getenv (param anyref) (result anyref))) (import "bindings" "time" (func $time (result f64))) @@ -49,6 +51,8 @@ (import "jsstring" "jsstring_test" (func $jsstring_test (param anyref) (result i32))) (import "bindings" "exit" (func $exit (param (ref eq)))) + (import "io" "caml_channel_descriptor" + (func $caml_channel_descriptor (param (ref eq)) (result (ref eq)))) (type $block (array (mut (ref eq)))) (type $bytes (array (mut i8))) @@ -165,8 +169,8 @@ (ref.i31 (i32.const 0)))) (func (export "caml_sys_isatty") - (param (ref eq)) (result (ref eq)) - (ref.i31 (i32.const 0))) + (param $ch (ref eq)) (result (ref eq)) + (return_call $isatty (call $caml_channel_descriptor (local.get $ch)))) (func (export "caml_runtime_variant") (param (ref eq)) (result (ref eq)) (array.new_fixed $bytes 0)) diff --git a/runtime/wasm/unix.wat b/runtime/wasm/unix.wat index e1e0a912a9..935b9f74ce 100644 --- a/runtime/wasm/unix.wat +++ b/runtime/wasm/unix.wat @@ -17,6 +17,7 @@ (module (import "bindings" "gettimeofday" (func $gettimeofday (result f64))) + (import "bindings" "times" (func $times (result (ref eq)))) (import "bindings" "gmtime" (func $gmtime (param f64) (result (ref eq)))) (import "bindings" "localtime" (func $localtime (param f64) (result (ref eq)))) @@ -25,16 +26,31 @@ (param i32) (param i32) (param i32) (param i32) (param i32) (param i32) (result f64))) (import "bindings" "utimes" (func $utimes (param anyref f64 f64))) + (import "bindings" "putenv" (func $putenv (param anyref anyref))) (import "bindings" "stat" (func $stat (param anyref i32) (result (ref eq)))) (import "bindings" "lstat" (func $lstat (param anyref i32) (result (ref eq)))) (import "bindings" "fstat" (func $fstat (param (ref eq) i32) (result (ref eq)))) + (import "bindings" "chmod" (func $chmod (param anyref (ref eq)))) + (import "bindings" "fchmod" (func $fchmod (param (ref eq) (ref eq)))) (import "bindings" "rename" (func $rename (param anyref) (param anyref))) + (import "bindings" "getcwd" (func $getcwd (result anyref))) + (import "bindings" "chdir" (func $chdir (param anyref))) + (import "bindings" "mkdir" (func $mkdir (param anyref) (param i32))) + (import "bindings" "opendir" (func $opendir (param anyref) (result anyref))) + (import "bindings" "readdir" (func $readdir (param anyref) (result anyref))) + (import "bindings" "closedir" (func $closedir (param anyref))) + (import "bindings" "rmdir" (func $rmdir (param anyref))) + (import "bindings" "link" (func $link (param anyref anyref))) + (import "bindings" "symlink" (func $symlink (param anyref anyref i32))) + (import "bindings" "readlink" (func $readlink (param anyref) (result anyref))) + (import "bindings" "unlink" (func $unlink (param anyref))) (import "bindings" "truncate" (func $truncate (param anyref (ref eq)))) (import "bindings" "truncate" (func $truncate_64 (param anyref f64))) (import "bindings" "ftruncate" (func $ftruncate (param (ref eq) (ref eq)))) (import "bindings" "ftruncate" (func $ftruncate_64 (param (ref eq) f64))) (import "bindings" "file_size" (func $file_size (param i32) (result i64))) + (import "bindings" "access" (func $access (param anyref) (param i32))) (import "bindings" "open" (func $open (param anyref) (param i32) (param i32) (result i32))) (import "bindings" "write" @@ -45,10 +61,13 @@ (func $read (param i32 (ref extern) i32 i32 i64) (result i32))) (import "bindings" "read" (func $read' (param i32 (ref extern) i32 i32 nullexternref) (result i32))) + (import "bindings" "fsync" (func $fsync (param (ref eq)))) (import "bindings" "close" (func $close (param (ref eq)))) (import "bindings" "isatty" (func $isatty (param (ref eq)) (result (ref eq)))) (import "js" "unix_error" (global $unix_error_js (ref any))) + (import "js" "caml_strerror" + (func $caml_strerror (param i32) (result (ref any)))) (import "jslib" "wrap" (func $wrap (param anyref) (result (ref eq)))) (import "jslib" "unwrap" (func $unwrap (param (ref eq)) (result anyref))) (import "jslib" "caml_js_meth_call" @@ -67,10 +86,12 @@ (import "fail" "ocaml_exception" (tag $ocaml_exception (param (ref eq)))) (import "fail" "javascript_exception" (tag $javascript_exception (param externref))) + (import "fail" "caml_raise_end_of_file" (func $caml_raise_end_of_file)) (import "fail" "caml_invalid_argument" (func $caml_invalid_argument (param (ref eq)))) + (import "fail" "caml_raise_not_found" (func $caml_raise_not_found)) (import "io" "convert_flag_list" - (func $convert_flag_list (param (ref $open_flags) (ref eq)) (result i32))) + (func $convert_flag_list (param (ref $flags) (ref eq)) (result i32))) (import "io" "IO_BUFFER_SIZE" (global $IO_BUFFER_SIZE i32)) (import "io" "initialize_fd_offset" (func $initialize_fd_offset (param i32 i64))) @@ -100,6 +121,7 @@ (type $bytes (array (mut i8))) (type $block (array (mut (ref eq)))) (type $float (struct (field f64))) + (type $float_array (array (mut f64))) (type $js (struct (field anyref))) (type $fd_offset @@ -199,11 +221,36 @@ (call $caml_js_get (local.get $exn) (array.new_data $bytes $path (i32.const 0) (i32.const 4))))))) - (export "caml_unix_gettimeofday" (func $unix_gettimeofday)) - (func $unix_gettimeofday (export "unix_gettimeofday") + (func (export "unix_error_message") (export "caml_unix_error_message") + (param $err (ref eq)) (result (ref eq)) + (local $errno i32) + (local.set $errno + (if (result i32) (ref.test (ref i31) (local.get $err)) + (then + (i31.get_u (ref.cast (ref i31) (local.get $err)))) + (else + (i32.sub (i32.const 0) + (i31.get_u + (ref.cast (ref i31) + (array.get $block + (ref.cast (ref $block) (local.get $err)) + (i32.const 1)))))))) + (return_call $caml_string_of_jsstring + (call $wrap (call $caml_strerror (local.get $errno))))) + + (func (export "unix_gettimeofday") (export "caml_unix_gettimeofday") (param (ref eq)) (result (ref eq)) (struct.new $float (call $gettimeofday))) + (func (export "caml_alloc_times") + (param $u f64) (param $s f64) (result (ref eq)) + (array.new_fixed $float_array 4 + (local.get $u) (local.get $s) (f64.const 0) (f64.const 0))) + + (func (export "unix_times") (export "caml_unix_times") + (param (ref eq)) (result (ref eq)) + (return_call $times)) + (func (export "caml_alloc_tm") (param $sec i32) (param $min i32) (param $hour i32) (param $mday i32) (param $mon i32) (param $year i32) (param $wday i32) (param $yday i32) @@ -287,6 +334,12 @@ (call $caml_unix_error (pop externref) (ref.null eq)))) (ref.i31 (i32.const 0))) + (func (export "caml_sys_putenv") + (param $name (ref eq)) (param $value (ref eq)) + (call $putenv + (call $unwrap (call $caml_jsstring_of_string (local.get $name))) + (call $unwrap (call $caml_jsstring_of_string (local.get $value))))) + (func (export "caml_alloc_stat") (param $large i32) (param $dev i32) (param $ino i32) (param $kind i32) (param $perm i32) @@ -373,6 +426,26 @@ (call $caml_unix_error (pop externref) (ref.null eq)) (ref.i31 (i32.const 0))))) + (func (export "unix_chmod") (export "caml_unix_chmod") + (param $path (ref eq)) (param $perms (ref eq)) (result (ref eq)) + (try + (do + (call $chmod + (call $unwrap (call $caml_jsstring_of_string (local.get $path))) + (local.get $perms))) + (catch $javascript_exception + (call $caml_unix_error (pop externref) (ref.null eq)))) + (ref.i31 (i32.const 0))) + + (func (export "unix_fchmod") (export "caml_unix_fchmod") + (param $fd (ref eq)) (param $perms (ref eq)) (result (ref eq)) + (try + (do + (call $fchmod (local.get $fd) (local.get $perms))) + (catch $javascript_exception + (call $caml_unix_error (pop externref) (ref.null eq)))) + (ref.i31 (i32.const 0))) + (func (export "unix_rename") (export "caml_unix_rename") (param $o (ref eq)) (param $n (ref eq)) (result (ref eq)) (try @@ -384,6 +457,165 @@ (call $caml_unix_error (pop externref) (ref.null eq)))) (ref.i31 (i32.const 0))) + (func (export "unix_getcwd") (export "caml_unix_getcwd") + (param (ref eq)) (result (ref eq)) + (try (result (ref eq)) + (do + (call $caml_string_of_jsstring (call $wrap (call $getcwd)))) + (catch $javascript_exception + (call $caml_unix_error (pop externref) (ref.null eq)) + (ref.i31 (i32.const 0))))) + + (func (export "unix_chdir") (export "caml_unix_chdir") + (param $name (ref eq)) (result (ref eq)) + (try + (do + (call $chdir + (call $unwrap (call $caml_jsstring_of_string (local.get $name))))) + (catch $javascript_exception + (call $caml_unix_error (pop externref) (ref.null eq)))) + (ref.i31 (i32.const 0))) + + (func (export "unix_mkdir") (export "caml_unix_mkdir") + (param $name (ref eq)) (param $perm (ref eq)) (result (ref eq)) + (try + (do + (call $mkdir + (call $unwrap (call $caml_jsstring_of_string (local.get $name))) + (i31.get_u (ref.cast (ref i31) (local.get $perm))))) + (catch $javascript_exception + (call $caml_unix_error (pop externref) (ref.null eq)))) + (ref.i31 (i32.const 0))) + + (func (export "unix_opendir") (export "caml_unix_opendir") + (param $name (ref eq)) (result (ref eq)) + (try (result (ref eq)) + (do + (call $wrap + (call $opendir + (call $unwrap + (call $caml_jsstring_of_string (local.get $name)))))) + (catch $javascript_exception + (call $caml_unix_error (pop externref) (ref.null eq)) + (ref.i31 (i32.const 0))))) + + (func (export "unix_readdir") (export "caml_unix_readdir") + (param $dir (ref eq)) (result (ref eq)) + (block $end + (return + (try (result (ref eq)) + (do + (call $caml_string_of_jsstring + (call $wrap + (br_on_null $end + (call $readdir (call $unwrap (local.get $dir))))))) + (catch $javascript_exception + (call $caml_unix_error (pop externref) (ref.null eq)) + (ref.i31 (i32.const 0)))))) + (call $caml_raise_end_of_file) + (ref.i31 (i32.const 0))) + + (func (export "unix_closedir") (export "caml_unix_closedir") + (param $dir (ref eq)) (result (ref eq)) + (try + (do + (call $closedir (call $unwrap (local.get $dir)))) + (catch $javascript_exception + (call $caml_unix_error (pop externref) (ref.null eq)))) + (ref.i31 (i32.const 0))) + + (data $rewinddir_not_implemented "rewinddir not implemented") + + (func (export "unix_rewinddir") (export "caml_unix_rewinddir") + (param (ref eq)) (result (ref eq)) + (call $caml_invalid_argument + (array.new_data $bytes $rewinddir_not_implemented + (i32.const 0) (i32.const 25))) + (ref.i31 (i32.const 0))) + + (func (export "unix_unlink") (export "caml_unix_unlink") + (param $p (ref eq)) (result (ref eq)) + (try + (do + (call $unlink + (call $unwrap (call $caml_jsstring_of_string (local.get $p))))) + (catch $javascript_exception + (call $caml_unix_error (pop externref) (ref.null eq)))) + (ref.i31 (i32.const 0))) + + (func (export "unix_rmdir") (export "caml_unix_rmdir") + (param $p (ref eq)) (result (ref eq)) + (try + (do + (call $rmdir + (call $unwrap (call $caml_jsstring_of_string (local.get $p))))) + (catch $javascript_exception + (call $caml_unix_error (pop externref) (ref.null eq)))) + (ref.i31 (i32.const 0))) + + (data $link "link") + + (func (export "unix_link") (export "caml_unix_link") + (param $follow (ref eq)) (param $d (ref eq)) (param $s (ref eq)) + (result (ref eq)) + (if (ref.test (ref $block) (local.get $follow)) + (then + (throw $ocaml_exception + (array.new_fixed $block 5 + (ref.i31 (i32.const 0)) + (call $get_unix_error_exn) + (ref.i31 (i32.const 25)) ;; ENOSYS + (array.new_data $bytes $link (i32.const 0) (i32.const 4)) + (global.get $no_arg))))) + (try + (do + (call $link + (call $unwrap (call $caml_jsstring_of_string (local.get $d))) + (call $unwrap (call $caml_jsstring_of_string (local.get $s))))) + (catch $javascript_exception + (call $caml_unix_error (pop externref) (ref.null eq)))) + (ref.i31 (i32.const 0))) + + (func (export "unix_has_symlink") (export "caml_unix_has_symlink") + (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 1))) + + (func (export "unix_symlink") (export "caml_unix_symlink") + (param $to_dir (ref eq)) (param $t (ref eq)) (param $p (ref eq)) + (result (ref eq)) + (local $kind i32) + (if (ref.test (ref $block) (local.get $to_dir)) + (then + (local.set $kind + (i32.add (i32.const 1) + (i31.get_s + (ref.cast (ref i31) + (array.get $block + (ref.cast (ref $block) (local.get $to_dir)) + (i32.const 0)))))))) + (try + (do + (call $symlink + (call $unwrap (call $caml_jsstring_of_string (local.get $t))) + (call $unwrap (call $caml_jsstring_of_string (local.get $p))) + (local.get $kind))) + (catch $javascript_exception + (call $caml_unix_error (pop externref) (ref.null eq)))) + (ref.i31 (i32.const 0))) + + (func (export "unix_readlink") (export "caml_unix_readlink") + (param $path (ref eq)) (result (ref eq)) + (try + (do + (return_call $caml_string_of_jsstring + (call $wrap + (call $readlink + (call $unwrap + (call $caml_jsstring_of_string (local.get $path))))))) + (catch $javascript_exception + (call $caml_unix_error (pop externref) (ref.null eq)))) + (ref.i31 (i32.const 0))) + (func (export "unix_truncate") (export "caml_unix_truncate") (param $path (ref eq)) (param $len (ref eq)) (result (ref eq)) @@ -459,7 +691,26 @@ (local.get $len)))) (ref.i31 (i32.const 0))) - (type $open_flags (array i8)) + (global $access_flags (ref $flags) + (array.new_fixed $flags 4 + (i32.const 1) (i32.const 2) (i32.const 4) (i32.const 8))) + + (func (export "unix_access") (export "caml_unix_access") + (param $path (ref eq)) (param $vflags (ref eq)) (result (ref eq)) + (local $flags i32) + (local.set $flags + (call $convert_flag_list + (global.get $access_flags) (local.get $vflags))) + (try + (do + (call $access + (call $unwrap (call $caml_jsstring_of_string (local.get $path))) + (local.get $flags))) + (catch $javascript_exception + (call $caml_unix_error (pop externref) (ref.null eq)))) + (ref.i31 (i32.const 0))) + + (type $flags (array i8)) ;; 1 O_RDONLY ;; 2 O_WRONLY ;; 4 O_RDWR @@ -471,8 +722,8 @@ ;; 256 O_NOCTTY ;; 512 O_DSYNC ;; 1024 O_SYNC - (global $unix_open_flags (ref $open_flags) - (array.new_fixed $open_flags 15 + (global $unix_open_flags (ref $flags) + (array.new_fixed $flags 15 (i32.const 1) (i32.const 2) (i32.const 4) (i32.const 128) (i32.const 8) (i32.const 16) (i32.const 32) (i32.const 64) (i32.const 256) (i32.const 512) (i32.const 1024) (i32.const 0) @@ -565,6 +816,51 @@ (br $loop)))) (ref.i31 (local.get $n))) + (func (export "unix_single_write") (export "caml_unix_single_write") + (param $vfd (ref eq)) (param $vbuf (ref eq)) (param $vpos (ref eq)) + (param $vlen (ref eq)) (result (ref eq)) + (local $fd i32) (local $s (ref $bytes)) (local $buf (ref extern)) + (local $pos i32) (local $len i32) (local $numbytes i32) + (local $written i32) (local $n i32) + (local $fd_offset (ref $fd_offset)) + (local $offset i64) + (local.set $fd (i31.get_u (ref.cast (ref i31) (local.get $vfd)))) + (local.set $s (ref.cast (ref $bytes) (local.get $vbuf))) + (local.set $pos (i31.get_u (ref.cast (ref i31) (local.get $vpos)))) + (local.set $len (i31.get_u (ref.cast (ref i31) (local.get $vlen)))) + (local.set $buf (call $get_io_buffer)) + (local.set $fd_offset (call $get_fd_offset (local.get $fd))) + (local.set $offset + (struct.get $fd_offset $offset (local.get $fd_offset))) + (if (i32.gt_u (local.get $len) (i32.const 0)) + (then + (local.set $numbytes + (select (global.get $IO_BUFFER_SIZE) (local.get $len) + (i32.gt_u (local.get $len) (global.get $IO_BUFFER_SIZE)))) + (call $ta_blit_from_bytes + (local.get $s) (local.get $pos) + (local.get $buf) (i32.const 0) (local.get $numbytes)) + (try + (do + (local.set $n + (if (result i32) + (struct.get $fd_offset $seeked (local.get $fd_offset)) + (then + (call $write (local.get $fd) (local.get $buf) + (i32.const 0) (local.get $numbytes) + (local.get $offset))) + (else + (call $write' (local.get $fd) (local.get $buf) + (i32.const 0) (local.get $numbytes) + (ref.null extern)))))) + (catch $javascript_exception + (call $caml_unix_error (pop externref) (ref.null eq)))) + (local.set $offset + (i64.add (local.get $offset) (i64.extend_i32_u (local.get $n)))) + (struct.set $fd_offset $offset + (local.get $fd_offset) (local.get $offset)))) + (ref.i31 (local.get $n))) + (func (export "unix_read") (export "caml_unix_read") (param $vfd (ref eq)) (param $vbuf (ref eq)) (param $vpos (ref eq)) (param $vlen (ref eq)) (result (ref eq)) @@ -595,7 +891,7 @@ (call $ta_blit_to_bytes (local.get $buf) (i32.const 0) (ref.cast (ref $bytes) (local.get $vbuf)) (local.get $pos) - (local.get $len)) + (local.get $n)) (ref.i31 (local.get $n))) (func (export "unix_write_bigarray") (export "caml_unix_write_bigarray") @@ -681,14 +977,14 @@ (func $lseek (param $vfd (ref eq)) (param $offset i64) (param $cmd (ref eq)) - (result (ref eq)) + (result i64) (local $fd i32) (local $fd_offset (ref $fd_offset)) (local.set $fd (i31.get_u (ref.cast (ref i31) (local.get $vfd)))) (local.set $fd_offset (block $non_null (result (ref $fd_offset)) (br_on_non_null $non_null (call $get_fd_offset_unchecked (local.get $fd))) - (throw $ocaml_exception (call $lseek_exn (i32.const 9))))) ;; EBADF + (throw $ocaml_exception (call $lseek_exn (i32.const 3))))) ;; EBADF (if (ref.eq (local.get $cmd) (ref.i31 (i32.const 1))) (then (local.set $offset @@ -705,23 +1001,36 @@ (call $lseek_exn (i32.const 12))))) ;; EINVAL (struct.set $fd_offset $offset (local.get $fd_offset) (local.get $offset)) (struct.set $fd_offset $seeked (local.get $fd_offset) (i32.const 1)) - (ref.i31 (i32.const 0))) + (local.get $offset)) (func (export "unix_lseek") (export "caml_unix_lseek") (param $fd (ref eq)) (param $ofs (ref eq)) (param $cmd (ref eq)) (result (ref eq)) - (return_call $lseek - (local.get $fd) - (i64.extend_i32_s (i31.get_s (ref.cast (ref i31) (local.get $ofs)))) - (local.get $cmd))) + (ref.i31 + (i32.wrap_i64 + (call $lseek + (local.get $fd) + (i64.extend_i32_s + (i31.get_s (ref.cast (ref i31) (local.get $ofs)))) + (local.get $cmd))))) (func (export "unix_lseek_64") (export "caml_unix_lseek_64") (param $fd (ref eq)) (param $ofs (ref eq)) (param $cmd (ref eq)) (result (ref eq)) - (return_call $lseek - (local.get $fd) - (call $Int64_val (local.get $ofs)) - (local.get $cmd))) + (return_call $caml_copy_int64 + (call $lseek + (local.get $fd) + (call $Int64_val (local.get $ofs)) + (local.get $cmd)))) + + (func (export "unix_fsync") (export "caml_unix_fsync") + (param $fd (ref eq)) (result (ref eq)) + (try + (do + (call $fsync (local.get $fd))) + (catch $javascript_exception + (call $caml_unix_error (pop externref) (ref.null eq)))) + (ref.i31 (i32.const 0))) (data $out_channel_of_descr "out_channel_of_descr") (data $in_channel_of_descr "in_channel_of_descr") @@ -788,6 +1097,20 @@ (export "unix_isatty" (func $isatty)) (export "caml_unix_isatty" (func $isatty)) + (func (export "unix_getuid") (export "caml_unix_getuid") + (export "unix_geteuid") (export "caml_unix_geteuid") + (export "unix_getgid") (export "caml_unix_getgid") + (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 1))) + + (func (export "unix_getpwnam") (export "caml_unix_getpwnam") + (export "unix_getpwuid") (export "caml_unix_getpwuid") + (export "unix_getgrnam") (export "caml_unix_getgrnam") + (export "unix_getgruid") (export "caml_unix_getgruid") + (param (ref eq)) (result (ref eq)) + (call $caml_raise_not_found) + (ref.i31 (i32.const 0))) + (func (export "unix_inet_addr_of_string") (export "caml_unix_inet_addr_of_string") (param (ref eq)) (result (ref eq)) From 9900af679737b826f0a39a0e4f9957e070a81a14 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Tue, 4 Feb 2025 17:26:58 +0100 Subject: [PATCH 04/29] Don't add Unix.putenv --- compiler/tests-check-prim/main.4.14.output | 1 - compiler/tests-check-prim/main.5.2.output | 1 - compiler/tests-check-prim/main.5.3.output | 1 - compiler/tests-check-prim/unix-Unix.4.14.output | 1 - compiler/tests-check-prim/unix-Unix.5.2.output | 1 - compiler/tests-check-prim/unix-Unix.5.3.output | 1 - runtime/js/unix.js | 16 ---------------- runtime/wasm/runtime.js | 1 - runtime/wasm/unix.wat | 7 ------- 9 files changed, 30 deletions(-) diff --git a/compiler/tests-check-prim/main.4.14.output b/compiler/tests-check-prim/main.4.14.output index 01272e65e7..94bb240abc 100644 --- a/compiler/tests-check-prim/main.4.14.output +++ b/compiler/tests-check-prim/main.4.14.output @@ -140,7 +140,6 @@ jsoo_toplevel_init_reloc From +unix.js: caml_strerror -caml_sys_putenv caml_unix_access caml_unix_chdir caml_unix_chmod diff --git a/compiler/tests-check-prim/main.5.2.output b/compiler/tests-check-prim/main.5.2.output index 9c0db80442..973ddcb677 100644 --- a/compiler/tests-check-prim/main.5.2.output +++ b/compiler/tests-check-prim/main.5.2.output @@ -136,7 +136,6 @@ jsoo_toplevel_init_reloc From +unix.js: caml_strerror -caml_sys_putenv caml_unix_access caml_unix_chdir caml_unix_chmod diff --git a/compiler/tests-check-prim/main.5.3.output b/compiler/tests-check-prim/main.5.3.output index 6167ae7545..af47aa226e 100644 --- a/compiler/tests-check-prim/main.5.3.output +++ b/compiler/tests-check-prim/main.5.3.output @@ -134,7 +134,6 @@ jsoo_toplevel_init_reloc From +unix.js: caml_strerror -caml_sys_putenv caml_unix_access caml_unix_chdir caml_unix_chmod diff --git a/compiler/tests-check-prim/unix-Unix.4.14.output b/compiler/tests-check-prim/unix-Unix.4.14.output index a6a6907210..d6634cabe7 100644 --- a/compiler/tests-check-prim/unix-Unix.4.14.output +++ b/compiler/tests-check-prim/unix-Unix.4.14.output @@ -215,7 +215,6 @@ jsoo_toplevel_init_compile jsoo_toplevel_init_reloc From +unix.js: -caml_sys_putenv caml_unix_access caml_unix_chdir caml_unix_chmod diff --git a/compiler/tests-check-prim/unix-Unix.5.2.output b/compiler/tests-check-prim/unix-Unix.5.2.output index 31998ff808..02ee9d3515 100644 --- a/compiler/tests-check-prim/unix-Unix.5.2.output +++ b/compiler/tests-check-prim/unix-Unix.5.2.output @@ -212,7 +212,6 @@ jsoo_toplevel_init_reloc From +unix.js: caml_strerror -caml_sys_putenv caml_unix_cleanup caml_unix_filedescr_of_fd caml_unix_findclose diff --git a/compiler/tests-check-prim/unix-Unix.5.3.output b/compiler/tests-check-prim/unix-Unix.5.3.output index 4a9f4a1f92..1c8c4155fd 100644 --- a/compiler/tests-check-prim/unix-Unix.5.3.output +++ b/compiler/tests-check-prim/unix-Unix.5.3.output @@ -210,7 +210,6 @@ jsoo_toplevel_init_reloc From +unix.js: caml_strerror -caml_sys_putenv caml_unix_cleanup caml_unix_filedescr_of_fd caml_unix_findclose diff --git a/runtime/js/unix.js b/runtime/js/unix.js index f74fef8141..46c29d8f19 100644 --- a/runtime/js/unix.js +++ b/runtime/js/unix.js @@ -91,22 +91,6 @@ function caml_unix_startup() {} //Alias: win_cleanup function caml_unix_cleanup() {} -//Provides: caml_sys_putenv (const, const) -//Requires: caml_jsstring_of_string, jsoo_static_env -function caml_sys_putenv(name, value) { - var name = caml_jsstring_of_string(name); - var value = caml_jsstring_of_string(value); - delete jsoo_static_env[name]; - //nodejs env - var process = globalThis.process; - if (process && process.env) { - process.env[name] = value; - return 0; - } - if (!globalThis.jsoo_env) globalThis.jsoo_env = {}; - globalThis.jsoo_env[name] = value; -} - //Provides: caml_unix_filedescr_of_fd const //Alias: win_handle_fd function caml_unix_filedescr_of_fd(x) { diff --git a/runtime/wasm/runtime.js b/runtime/wasm/runtime.js index 6cc148ae52..087cc66a1c 100644 --- a/runtime/wasm/runtime.js +++ b/runtime/wasm/runtime.js @@ -459,7 +459,6 @@ argv: () => (isNode ? process.argv.slice(1) : ["a.out"]), on_windows: +on_windows, getenv: (n) => (isNode ? process.env[n] : null), - putenv: (n, v) => process.env[n] = v, system: (c) => { var res = require("node:child_process").spawnSync(c, { shell: true, diff --git a/runtime/wasm/unix.wat b/runtime/wasm/unix.wat index 935b9f74ce..26a49dc06a 100644 --- a/runtime/wasm/unix.wat +++ b/runtime/wasm/unix.wat @@ -26,7 +26,6 @@ (param i32) (param i32) (param i32) (param i32) (param i32) (param i32) (result f64))) (import "bindings" "utimes" (func $utimes (param anyref f64 f64))) - (import "bindings" "putenv" (func $putenv (param anyref anyref))) (import "bindings" "stat" (func $stat (param anyref i32) (result (ref eq)))) (import "bindings" "lstat" (func $lstat (param anyref i32) (result (ref eq)))) (import "bindings" "fstat" @@ -334,12 +333,6 @@ (call $caml_unix_error (pop externref) (ref.null eq)))) (ref.i31 (i32.const 0))) - (func (export "caml_sys_putenv") - (param $name (ref eq)) (param $value (ref eq)) - (call $putenv - (call $unwrap (call $caml_jsstring_of_string (local.get $name))) - (call $unwrap (call $caml_jsstring_of_string (local.get $value))))) - (func (export "caml_alloc_stat") (param $large i32) (param $dev i32) (param $ino i32) (param $kind i32) (param $perm i32) From bd4f17820377d75517cecb04c3b63bd46bd16700 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Wed, 5 Feb 2025 17:41:08 +0100 Subject: [PATCH 05/29] Add test from OCaml test suite --- compiler/tests-ocaml/win-unicode/dune | 4 + compiler/tests-ocaml/win-unicode/mltest.ml | 293 +++++++++++++++++++++ 2 files changed, 297 insertions(+) create mode 100644 compiler/tests-ocaml/win-unicode/dune create mode 100644 compiler/tests-ocaml/win-unicode/mltest.ml diff --git a/compiler/tests-ocaml/win-unicode/dune b/compiler/tests-ocaml/win-unicode/dune new file mode 100644 index 0000000000..08585c87e9 --- /dev/null +++ b/compiler/tests-ocaml/win-unicode/dune @@ -0,0 +1,4 @@ +(tests + (names mltest) + (libraries ocaml_testing unix) + (modes js wasm)) diff --git a/compiler/tests-ocaml/win-unicode/mltest.ml b/compiler/tests-ocaml/win-unicode/mltest.ml new file mode 100644 index 0000000000..5c750eb231 --- /dev/null +++ b/compiler/tests-ocaml/win-unicode/mltest.ml @@ -0,0 +1,293 @@ +(* TEST + include unix; + hasunix; + flags += "-strict-sequence -w +A -warn-error +A"; + windows-unicode; + toplevel; +*) + +let foreign_names = + List.sort compare + [ + "simple"; + "\xE4\xBD\xA0\xE5\xA5\xBD"; (* "你好" *) + "\x73\xC5\x93\x75\x72"; (* "sœur" *) + "e\204\129te\204\129"; (* "été" *) + ] +;; + +let test_files = + List.map (fun s -> s ^ ".txt") foreign_names +;; + +let to_create_and_delete_files = + [ + (* "верблюды" *) + "\xD0\xB2\xD0\xB5\xD1\x80\xD0\xB1\xD0\xBB\xD1\x8E\xD0\xB4\xD1\x8B"; + "\xE9\xAA\x86\xE9\xA9\xBC"; (* "骆驼" *) + "\215\167\215\162\215\158\215\156"; (* "קעמל" *) + "\216\167\217\136\217\134\217\185"; (* "اونٹ" *) + "L\225\186\161c \196\145\195\160"; (* "Lạc đà" *) + "\224\176\146\224\176\130\224\176\159\224\177\134"; (* "ఒంటె" *) + "\224\174\146\224\174\159\224\175\141\224\174\159\224\174\149\224\ + \174\174\224\175\141"; (* "ஒட்டகம்" *) + "\217\136\216\180\216\170\216\177"; (* "وشتر" *) + "\224\164\137\224\164\183\224\165\141\224\164\159\224\165\141\224\ + \164\176\224\164\131"; (* "उष्ट्रः" *) + "\216\167\217\186"; (* "اٺ" *) + ] +;; + +let foreign_names2 = + let rec take n l = + if n = 0 then [] + else List.hd l :: take (n-1) (List.tl l) + in + take (List.length foreign_names) to_create_and_delete_files +;; + +(* let env0 = + List.sort compare + (List.mapi (fun i v -> Printf.sprintf "OCAML_UTF8_VAR%d=%s" i v) + foreign_names2) *) + +(* let read_all ic = *) +(* set_binary_mode_in ic false; *) +(* let rec loop acc = *) +(* match input_line ic with *) +(* | exception End_of_file -> *) +(* List.rev acc *) +(* | s -> *) +(* loop (s :: acc) *) +(* in *) +(* loop [] *) + +(** WRAPPERS *) + +let getenvironmentenv s = + let env = Unix.environment () in + let rec loop i = + if i >= Array.length env then + "" + else begin + let e = env.(i) in + let pos = String.index e '=' in + if String.sub e 0 pos = s then + String.sub e (pos+1) (String.length e - pos - 1) + else + loop (i+1) + end + in + loop 0 +;; + +let unix_getcwd () = + Filename.basename (Unix.getcwd ()) +;; + +let sys_getcwd () = + Filename.basename (Sys.getcwd ()) +;; + +let unix_readdir s = + let h = Unix.opendir s in + let rec loop acc = + match Unix.readdir h with + | s -> + loop (s :: acc) + | exception End_of_file -> + Unix.closedir h; + acc + in + List.sort compare (loop []) +;; + +let sys_readdir s = + List.sort compare (Array.to_list (Sys.readdir s)) +;; + +(* let open_process_in cmdline = *) +(* let f cmdline = *) +(* let ic as proc = Unix.open_process_in cmdline in *) +(* let l = List.tl (read_all ic) in *) +(* ignore (Unix.close_process_in proc); *) +(* l *) +(* in *) +(* wrap "Unix.open_process_in" f ell cmdline (list quote) *) + +(* let open_process_full filter cmdline env = + let f cmdline env = + let (ic, _, _) as proc = + Unix.open_process_full cmdline (Array.of_list env) + in + let l = read_all ic in + ignore (Unix.close_process_full proc); + List.sort compare (List.filter filter l) + in + wrap2 "Unix.open_process_full" f ell (list quote) cmdline env (list quote) +*) + +let test_readdir readdir = + let filter s = List.mem s test_files && Filename.check_suffix s ".txt" in + List.filter filter (readdir Filename.current_dir_name) +;; + +let test_open_in () = + let check s = + let ic = open_in s in + let l = input_line ic in + close_in ic; + l + in + let filter s = List.mem s test_files in + let files = List.filter filter (sys_readdir Filename.current_dir_name) in + List.map check files +;; + +(* putenv not implemented +let test_getenv () = + let equiv l r = + assert (l = r); + l, r + in + let doit key s = + Unix.putenv key s; + let l = equiv (Sys.getenv key) (getenvironmentenv key) in + let r = + Unix.putenv key (s ^ s); + equiv (Sys.getenv key) (getenvironmentenv key) + in + l, r + in + List.map2 doit foreign_names foreign_names2 +;; +*) + +let test_mkdir () = + let doit s = + Unix.mkdir s 0o755; + Sys.file_exists s, Sys.is_directory s + in + List.map doit foreign_names +;; + +let test_chdir chdir getcwd = + let curr = Sys.getcwd () in + let doit s = + chdir s; + let d = getcwd () in + chdir curr; + d + in + List.map doit foreign_names +;; + +let test_rmdir () = + let doit s = + Unix.rmdir s; + Sys.file_exists s + in + List.map doit foreign_names +;; + +let test_stat () = + let doit s = + (Unix.stat s).Unix.st_kind, + (Unix.lstat s).Unix.st_kind, + (Unix.LargeFile.stat s).Unix.LargeFile.st_kind, + (Unix.LargeFile.lstat s).Unix.LargeFile.st_kind + in + List.map doit to_create_and_delete_files +;; + +let test_access () = + List.iter (fun s -> Unix.access s [Unix.F_OK]) to_create_and_delete_files + +let test_rename rename = + let doit s = + let s' = s ^ "-1" in + rename s s'; + let x = Sys.file_exists s, Sys.file_exists s' in + rename s' s; + let y = Sys.file_exists s, Sys.file_exists s' in + x, y + in + List.map doit to_create_and_delete_files +;; + +let test_open_out () = + let doit s = + let oc = open_out s in + Printf.fprintf oc "Hello, %s\n" s; + close_out oc; + let ic = open_in s in + let l = input_line ic in + close_in ic; + l + in + List.map doit to_create_and_delete_files +;; + +let test_file_exists () = + List.map Sys.file_exists to_create_and_delete_files +;; + +let test_remove () = + let doit s = + Sys.remove s; + Sys.file_exists s + in + List.map doit to_create_and_delete_files +;; + +let create_file s = + let oc = open_out_bin s in + output_string oc s; + close_out oc +;; + +let test_symlink () = + let foodir = "UNIQU\xE4\xBD\xA0\xE5\xA5\xBD" (* "UNIQU你好" *) in + let foofile = "UNIQU\xE4\xBD\xA0\xE5\xA5\xBD/\xE4\xBD\xA0\xE5\xA5\xBD.txt" + (* "UNIQU你好/你好.txt" *) + in + let fileln = "\xE4\xBD\xA0\xE5\xA5\xBD-file-ln-s" (* "你好-file-ln-s" *) in + let dirln = "\xE4\xBD\xA0\xE5\xA5\xBD-dir-ln-s" (* "你好-dir-ln-s" *) in + Unix.mkdir foodir 0o777; + create_file foofile; + Unix.symlink ~to_dir:true foodir dirln; + Unix.symlink ~to_dir:false foofile fileln; + let res = + (Unix.stat fileln).Unix.st_kind = Unix.S_REG && + (Unix.lstat fileln).Unix.st_kind = Unix.S_LNK +(* node cannot stat a link to a directory under Windows (EPERM) +&& (Unix.stat dirln).Unix.st_kind = Unix.S_DIR +&& (Unix.lstat dirln).Unix.st_kind = Unix.S_LNK *) + in + Sys.remove foofile; + Sys.remove fileln; + Sys.remove dirln; + Unix.rmdir foodir; + res +;; + +List.iter create_file test_files;; + +let check_length ?(n = 4) v = assert (List.length v = n);; + +let t_unix_readdir = check_length @@ test_readdir unix_readdir;; +let t_sys_readdir = check_length @@ test_readdir sys_readdir;; +let t_open_in = check_length @@ test_open_in ();; +let t_open_out = check_length ~n:10 @@ test_open_out ();; +let t_file_exists = assert (List.for_all Fun.id (test_file_exists ()));; +let t_stat = assert (List.for_all (fun x -> match x with Unix.S_REG,Unix.S_REG,Unix.S_REG,Unix.S_REG -> true | _ -> false) (test_stat ()));; +test_access ();; +let t_unix_rename = test_rename Unix.rename;; +let t_sys_rename = test_rename Sys.rename;; +assert (not (List.exists Fun.id (test_remove ())));; +assert (List.for_all (fun (p, q) -> p && q) (test_mkdir ()));; +let t_sys_chdir = assert (foreign_names = test_chdir Sys.chdir sys_getcwd);; +let t_unix_chdir = assert (foreign_names = test_chdir Unix.chdir unix_getcwd);; +assert (not (List.exists Fun.id (test_rmdir ())));; +(*let t_getenv = test_getenv ();;*) +assert (if Unix.has_symlink () then test_symlink () else true);; From 15daf96361a9d710ec71a65670ce2fda39dd2180 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Mon, 10 Feb 2025 20:09:50 +0100 Subject: [PATCH 06/29] Add tests --- .../tests-check-prim/unix-Win32.5.2.output | 1 - .../tests-check-prim/unix-Win32.5.3.output | 1 - compiler/tests-io/non_ascii_filenames.ml | 9 +- compiler/tests-jsoo/dune | 6 + compiler/tests-jsoo/test_unix.ml | 156 ++++++++++++++++++ .../tests-ocaml/lib-marshal/compressed.ml | 6 +- 6 files changed, 166 insertions(+), 13 deletions(-) create mode 100644 compiler/tests-jsoo/test_unix.ml diff --git a/compiler/tests-check-prim/unix-Win32.5.2.output b/compiler/tests-check-prim/unix-Win32.5.2.output index 17f9d5b88e..4abee14701 100644 --- a/compiler/tests-check-prim/unix-Win32.5.2.output +++ b/compiler/tests-check-prim/unix-Win32.5.2.output @@ -185,7 +185,6 @@ jsoo_toplevel_init_reloc From +unix.js: caml_strerror -caml_unix_getpwuid caml_unix_fchmod caml_unix_getegid caml_unix_geteuid diff --git a/compiler/tests-check-prim/unix-Win32.5.3.output b/compiler/tests-check-prim/unix-Win32.5.3.output index a843e0f31f..fdd7c21ad6 100644 --- a/compiler/tests-check-prim/unix-Win32.5.3.output +++ b/compiler/tests-check-prim/unix-Win32.5.3.output @@ -183,7 +183,6 @@ jsoo_toplevel_init_reloc From +unix.js: caml_strerror -caml_unix_getpwuid caml_unix_fchmod caml_unix_getegid caml_unix_geteuid diff --git a/compiler/tests-io/non_ascii_filenames.ml b/compiler/tests-io/non_ascii_filenames.ml index 437ae89d4b..f32136e9fe 100644 --- a/compiler/tests-io/non_ascii_filenames.ml +++ b/compiler/tests-io/non_ascii_filenames.ml @@ -13,14 +13,7 @@ let () = Printf.printf "reading directories\n"; let check_file d = let a = Sys.readdir d in - if - not - (Array.exists - (fun x -> - prerr_endline x; - x = "accentué") - a) - then raise Not_found + if not (Array.exists (fun x -> x = "accentué") a) then raise Not_found in test check_file "."; test check_file "/static"; diff --git a/compiler/tests-jsoo/dune b/compiler/tests-jsoo/dune index faf7fd7f64..7ccd92ca4e 100644 --- a/compiler/tests-jsoo/dune +++ b/compiler/tests-jsoo/dune @@ -1,3 +1,9 @@ +(env + (_ + ;; for testing + (env-vars + (FOO bar)))) + (library (name jsoo_testsuite_latest) (modules test_io test_floats) diff --git a/compiler/tests-jsoo/test_unix.ml b/compiler/tests-jsoo/test_unix.ml new file mode 100644 index 0000000000..aa25c0baad --- /dev/null +++ b/compiler/tests-jsoo/test_unix.ml @@ -0,0 +1,156 @@ +let%expect_test "Unix.error_message" = + Printf.printf "%s\n" (String.lowercase_ascii (Unix.error_message ENOENT)); + [%expect {| no such file or directory |}] + +let%expect_test "Unix.times" = + let t = Unix.times () in + let t' = Unix.times () in + let cmp v v' = v' >= v && v' <= v +. 0.1 in + if + cmp t.tms_utime t'.tms_utime + && cmp t.tms_stime t'.tms_stime + && cmp t.tms_cutime t'.tms_cutime + && cmp t.tms_cstime t'.tms_cstime + then Printf.printf "OK\n"; + [%expect {| OK |}] + +let on_windows = Sys.os_type = "Win32" + +let%expect_test "Unix.chmod / Unix.fchmod / Unix.access" = + let tmp = Filename.temp_file "a" "txt" in + let test ?(ok_on_windows = false) flags = + try + Unix.access tmp flags; + if on_windows && ok_on_windows + then Printf.printf "denied (success on Windows)\n" + else Printf.printf "success\n" + with + | Unix.Unix_error ((EPERM | EACCES), _, _) -> + if (not on_windows) && ok_on_windows + then Printf.printf "denied (success on Windows)\n" + else Printf.printf "denied\n" + | Unix.Unix_error (ENOENT, _, _) -> Printf.printf "absent\n" + in + let touch perms = + Unix.chmod tmp 0o600; + Unix.unlink tmp; + let fd = Unix.openfile tmp [ O_WRONLY; O_CREAT; O_TRUNC ] perms in + Unix.close fd + in + let test_perms set = + set 0o200; + test ~ok_on_windows:true [ R_OK ]; + test [ W_OK ]; + test ~ok_on_windows:true [ R_OK; W_OK ]; + [%expect + {| + denied (success on Windows) + success + denied (success on Windows) + |}]; + set 0o400; + test [ R_OK ]; + test [ W_OK ]; + test [ R_OK; W_OK ]; + [%expect {| + success + denied + denied |}]; + set 0o600; + test [ R_OK ]; + test [ W_OK ]; + test [ R_OK; W_OK ]; + [%expect {| + success + success + success |}]; + set 0o000; + test ~ok_on_windows:true [ R_OK ]; + test [ W_OK ]; + test [ R_OK; W_OK ]; + [%expect {| + denied (success on Windows) + denied + denied + |}] + in + test [ F_OK ]; + [%expect {| + success |}]; + Unix.chmod tmp 0o600; + Unix.unlink tmp; + test [ F_OK ]; + [%expect {| + absent |}]; + let fd = Unix.openfile tmp [ O_WRONLY; O_CREAT; O_TRUNC ] 0o666 in + test [ F_OK ]; + [%expect {| + success |}]; + if not on_windows then test_perms (Unix.fchmod fd); + Unix.close fd; + test_perms (Unix.chmod tmp); + test_perms touch; + Unix.chmod tmp 0o600; + Unix.unlink tmp + +let%expect_test "Unix.link" = + let tmp = Filename.temp_file "a" "txt" in + let ch = open_out tmp in + output_string ch "test\n"; + close_out ch; + let tmp' = Filename.temp_file "a" "txt" in + Unix.unlink tmp'; + Unix.link tmp tmp'; + let ch = open_in tmp' in + Format.printf "%s\n" (input_line ch); + close_in ch; + let ch = open_out tmp' in + output_string ch "abcd\n"; + close_out ch; + let ch = open_in tmp in + Format.printf "%s\n" (input_line ch); + close_in ch; + Unix.unlink tmp; + Unix.unlink tmp'; + [%expect {| + test + abcd + |}] + +let%expect_test "Unix.readlink" = + let tmp' = Filename.temp_file "a" "txt" in + Unix.unlink tmp'; + Unix.symlink "abcdefgh" tmp'; + Format.printf "%s\n" (Unix.readlink tmp'); + [%expect {| abcdefgh |}] + +let%expect_test "Unix.single_write" = + let s = "abcd efgh ijkl mnop qrst uvwx" in + let b = Bytes.of_string s in + let tmp = Filename.temp_file "a" "txt" in + let fd = Unix.openfile tmp [ O_WRONLY; O_CREAT; O_TRUNC ] 0o666 in + let n = Unix.single_write fd b 0 (Bytes.length b) in + Unix.close fd; + let ch = open_in tmp in + let s' = really_input_string ch n in + Printf.printf "%b %b\n" (n > 0) (s' = String.sub s 0 n); + [%expect {| true true |}] + +let%expect_test "Unix.read" = + let tmp = Filename.temp_file "a" "txt" in + let fd = Unix.openfile tmp [ O_RDONLY ] 0o666 in + (try Printf.printf "write: %d\n" (Unix.write fd (Bytes.create 8) 0 8) + with Unix.Unix_error (_, _, _) -> Printf.printf "write failed\n"); + Unix.close fd; + Unix.unlink tmp; + (try Printf.printf "read: %d\n" (Unix.read fd (Bytes.create 8) 0 8) + with Unix.Unix_error (err, _, _) -> + Printf.printf "%s\n" (String.lowercase_ascii (Unix.error_message err))); + [%expect {| + write failed + bad file descriptor + |}] + +let%expect_test "Unix.getenv" = + Printf.printf "%s\n" (Sys.getenv "FOO"); + [%expect {| bar |}] diff --git a/compiler/tests-ocaml/lib-marshal/compressed.ml b/compiler/tests-ocaml/lib-marshal/compressed.ml index 841cb94640..9d3b0440e2 100644 --- a/compiler/tests-ocaml/lib-marshal/compressed.ml +++ b/compiler/tests-ocaml/lib-marshal/compressed.ml @@ -161,8 +161,8 @@ let test_supported filename = if false then test 100 (actually_supported = compression_supported) let main () = - test_out "intext.data"; test_in "intext.data"; - test_supported "intext.data"; - Sys.remove "intext.data" + test_out "intext_compressed.data"; test_in "intext_compressed.data"; + test_supported "intext_compressed.data"; + Sys.remove "intext_compressed.data" let _ = main () From 3b759c95e99f649761c440e4cf1e045ddb8f28c4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Mon, 10 Feb 2025 20:12:20 +0100 Subject: [PATCH 07/29] Changes --- CHANGES.md | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index 23a63c84bf..443bd1d74d 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,8 @@ +# dev + +## Features/Changes +* Runtime: support more Unix functions (#1829) + # 6.0.1 (2025-02-07) - Lille ## Features/Changes From 180cf566e32cb70235028e5bc170870e68a7f1a6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Wed, 12 Feb 2025 22:22:50 +0100 Subject: [PATCH 08/29] Wasm runtime: implement ocaml_unix_findfirst / ocaml_unix_findnext --- runtime/wasm/unix.wat | 61 ++++++++++++++++++++++++++++++++++++++----- 1 file changed, 55 insertions(+), 6 deletions(-) diff --git a/runtime/wasm/unix.wat b/runtime/wasm/unix.wat index 26a49dc06a..867f22abde 100644 --- a/runtime/wasm/unix.wat +++ b/runtime/wasm/unix.wat @@ -480,7 +480,7 @@ (call $caml_unix_error (pop externref) (ref.null eq)))) (ref.i31 (i32.const 0))) - (func (export "unix_opendir") (export "caml_unix_opendir") + (func $unix_opendir (export "unix_opendir") (export "caml_unix_opendir") (param $name (ref eq)) (result (ref eq)) (try (result (ref eq)) (do @@ -492,8 +492,18 @@ (call $caml_unix_error (pop externref) (ref.null eq)) (ref.i31 (i32.const 0))))) - (func (export "unix_readdir") (export "caml_unix_readdir") - (param $dir (ref eq)) (result (ref eq)) + (func $throw_ebadf (param $cmd (ref eq)) + (throw $ocaml_exception + (array.new_fixed $block 5 + (ref.i31 (i32.const 0)) + (call $get_unix_error_exn) + (ref.i31 (i32.const 3)) ;; EBADF + (local.get $cmd) + (global.get $no_arg)))) + + (data $readdir "readdir") + + (func $readdir_helper (param $dir (ref eq)) (result (ref eq)) (block $end (return (try (result (ref eq)) @@ -503,20 +513,59 @@ (br_on_null $end (call $readdir (call $unwrap (local.get $dir))))))) (catch $javascript_exception - (call $caml_unix_error (pop externref) (ref.null eq)) + (drop (pop externref)) + (call $throw_ebadf + (array.new_data $bytes $readdir + (i32.const 0) (i32.const 7))) (ref.i31 (i32.const 0)))))) (call $caml_raise_end_of_file) (ref.i31 (i32.const 0))) - (func (export "unix_closedir") (export "caml_unix_closedir") + (data $closedir "closedir") + + (func $unix_closedir (export "unix_closedir") (export "caml_unix_closedir") + (export "win_findclose") (export "caml_unix_findclose") (param $dir (ref eq)) (result (ref eq)) (try (do (call $closedir (call $unwrap (local.get $dir)))) (catch $javascript_exception - (call $caml_unix_error (pop externref) (ref.null eq)))) + (drop (pop externref)) + (call $throw_ebadf + (array.new_data $bytes $closedir (i32.const 0) (i32.const 8))))) (ref.i31 (i32.const 0))) + (func (export "unix_readdir") (export "caml_unix_readdir") + (param $dir (ref eq)) (result (ref eq)) + (block $return (result (ref eq)) + (br_on_non_null $return (call $readdir_helper (local.get $dir))) + (call $caml_raise_end_of_file) + (ref.i31 (i32.const 0)))) + + (func $win_find_next (export "win_findnext") (export "caml_unix_findnext") + (param $dir (ref eq)) (result (ref eq)) + (block $return (result (ref eq)) + (br_on_non_null $return (call $readdir_helper (local.get $dir))) + (drop (call $unix_closedir (local.get $dir))) + (call $caml_raise_end_of_file) + (ref.i31 (i32.const 0)))) + + (func (export "win_findfirst") (export "caml_unix_findfirst") + (param $vpath (ref eq)) (result (ref eq)) + (local $dir (ref eq)) (local $p (ref $bytes)) (local $p' (ref $bytes)) + (local $len i32) + (local.set $p (ref.cast (ref $bytes) (local.get $vpath))) + (local.set $len (i32.sub (array.len (local.get $p)) (i32.const 3))) + (local.set $p' (array.new $bytes (i32.const 0) (local.get $len))) + (array.copy $bytes $bytes + (local.get $p') (i32.const 0) + (local.get $p) (i32.const 0) + (local.get $len)) + (local.set $dir (call $unix_opendir (local.get $p'))) + (array.new_fixed $block 3 (ref.i31 (i32.const 0)) + (call $win_find_next (local.get $dir)) + (local.get $dir))) + (data $rewinddir_not_implemented "rewinddir not implemented") (func (export "unix_rewinddir") (export "caml_unix_rewinddir") From d04d04de3bc670723206aaafee0be91e536f160b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Thu, 30 Jan 2025 16:33:23 +0100 Subject: [PATCH 09/29] More flexible API to call binaryen tools --- compiler/bin-wasm_of_ocaml/compile.ml | 29 ++++++++++++++++++--------- compiler/lib-wasm/binaryen.ml | 28 +++++++++++++++++--------- compiler/lib-wasm/binaryen.mli | 12 +++++++++-- 3 files changed, 48 insertions(+), 21 deletions(-) diff --git a/compiler/bin-wasm_of_ocaml/compile.ml b/compiler/bin-wasm_of_ocaml/compile.ml index 4f3587d8c7..3905c0428a 100644 --- a/compiler/bin-wasm_of_ocaml/compile.ml +++ b/compiler/bin-wasm_of_ocaml/compile.ml @@ -101,10 +101,14 @@ let link_and_optimize else None) @@ fun opt_temp_sourcemap -> Binaryen.link - ~runtime_files:(runtime_file :: runtime_wasm_files) - ~input_files:wat_files + ~inputs: + (List.map + ~f:(fun file -> { Binaryen.module_name = "env"; file }) + (runtime_file :: runtime_wasm_files) + @ List.map ~f:(fun file -> { Binaryen.module_name = "OCaml"; file }) wat_files) ~opt_output_sourcemap:opt_temp_sourcemap - ~output_file:temp_file; + ~output_file:temp_file + (); Fs.with_intermediate_file (Filename.temp_file "wasm-dce" ".wasm") @@ fun temp_file' -> opt_with @@ -124,7 +128,8 @@ let link_and_optimize ~opt_input_sourcemap:opt_temp_sourcemap' ~opt_output_sourcemap:opt_sourcemap ~input_file:temp_file' - ~output_file; + ~output_file + (); Option.iter ~f:(update_sourcemap ~sourcemap_root ~sourcemap_don't_inline_content) opt_sourcemap_file; @@ -138,15 +143,19 @@ let link_runtime ~profile runtime_wasm_files output_file = @@ fun temp_file -> Binaryen.link ~opt_output_sourcemap:None - ~runtime_files:(runtime_file :: runtime_wasm_files) - ~input_files:[] - ~output_file:temp_file; + ~inputs: + (List.map + ~f:(fun file -> { Binaryen.module_name = "env"; file }) + (runtime_file :: runtime_wasm_files)) + ~output_file:temp_file + (); Binaryen.optimize ~profile ~opt_input_sourcemap:None ~opt_output_sourcemap:None ~input_file:temp_file ~output_file + () let generate_prelude ~out_file = Filename.gen_file out_file @@ -186,7 +195,8 @@ let build_prelude z = ~input_file:prelude_file ~output_file:tmp_prelude_file ~opt_input_sourcemap:None - ~opt_output_sourcemap:None; + ~opt_output_sourcemap:None + (); Zip.add_file z ~name:"prelude.wasm" ~file:tmp_prelude_file; predefined_exceptions @@ -413,7 +423,8 @@ let run ~opt_input_sourcemap:None ~opt_output_sourcemap:opt_tmp_map_file ~input_file:wat_file - ~output_file:tmp_wasm_file; + ~output_file:tmp_wasm_file + (); { Link.unit_name; unit_info; strings; fragments } in cont unit_data unit_name tmp_wasm_file opt_tmp_map_file diff --git a/compiler/lib-wasm/binaryen.ml b/compiler/lib-wasm/binaryen.ml index 93b0b7b7fb..f0a6679e83 100644 --- a/compiler/lib-wasm/binaryen.ml +++ b/compiler/lib-wasm/binaryen.ml @@ -45,18 +45,20 @@ let opt_flag flag v = | None -> [] | Some v -> [ flag; Filename.quote v ] -let link ~runtime_files ~input_files ~opt_output_sourcemap ~output_file = +type link_input = + { module_name : string + ; file : string + } + +let link ?options ~inputs ~opt_output_sourcemap ~output_file () = command ("wasm-merge" :: (common_options () + @ Option.value ~default:[] options @ List.flatten (List.map - ~f:(fun runtime_file -> [ Filename.quote runtime_file; "env" ]) - runtime_files) - @ List.flatten - (List.map - ~f:(fun input_file -> [ Filename.quote input_file; "OCaml" ]) - input_files) + ~f:(fun { file; module_name } -> [ Filename.quote file; module_name ]) + inputs) @ [ "-o"; Filename.quote output_file ] @ opt_flag "--output-source-map" opt_output_sourcemap)) @@ -114,8 +116,14 @@ let optimization_options = ; [ "-O3"; "--skip-pass=inlining-optimizing"; "--traps-never-happen" ] |] -let optimize ~profile ~opt_input_sourcemap ~input_file ~opt_output_sourcemap ~output_file - = +let optimize + ~profile + ?options + ~opt_input_sourcemap + ~input_file + ~opt_output_sourcemap + ~output_file + () = let level = match profile with | None -> 1 @@ -124,7 +132,7 @@ let optimize ~profile ~opt_input_sourcemap ~input_file ~opt_output_sourcemap ~ou command ("wasm-opt" :: (common_options () - @ optimization_options.(level - 1) + @ Option.value ~default:optimization_options.(level - 1) options @ [ Filename.quote input_file; "-o"; Filename.quote output_file ]) @ opt_flag "--input-source-map" opt_input_sourcemap @ opt_flag "--output-source-map" opt_output_sourcemap) diff --git a/compiler/lib-wasm/binaryen.mli b/compiler/lib-wasm/binaryen.mli index 3e07e06f88..4ce5bbd916 100644 --- a/compiler/lib-wasm/binaryen.mli +++ b/compiler/lib-wasm/binaryen.mli @@ -16,12 +16,18 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +type link_input = + { module_name : string + ; file : string + } + val link : - runtime_files:string list - -> input_files:string list + ?options:string list + -> inputs:link_input list -> opt_output_sourcemap:string option -> output_file:string -> unit + -> unit val dead_code_elimination : dependencies:string @@ -33,8 +39,10 @@ val dead_code_elimination : val optimize : profile:Driver.profile option + -> ?options:string list -> opt_input_sourcemap:string option -> input_file:string -> opt_output_sourcemap:string option -> output_file:string -> unit + -> unit From 81e826f8d4368d0b17c53d8d29449414bb6f5c8a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Tue, 17 Dec 2024 16:53:01 +0100 Subject: [PATCH 10/29] WAT file preprocessor --- compiler/bin-wasm_of_ocaml/compile.ml | 30 +- compiler/bin-wasmoo_util/cmd_arg.ml | 181 +++++++++ compiler/bin-wasmoo_util/cmd_arg.mli | 52 +++ compiler/bin-wasmoo_util/dune | 17 + compiler/bin-wasmoo_util/wasmoo_util.ml | 121 ++++++ compiler/lib-wasm/dune | 4 +- compiler/lib-wasm/link.ml | 13 + compiler/lib-wasm/link.mli | 4 + compiler/lib-wasm/runtime.ml | 21 + compiler/lib-wasm/runtime.mli | 7 + compiler/lib-wasm/wat_preprocess.ml | 520 ++++++++++++++++++++++++ compiler/lib-wasm/wat_preprocess.mli | 22 + runtime/wasm/args.ml | 2 +- runtime/wasm/dune | 37 +- 14 files changed, 990 insertions(+), 41 deletions(-) create mode 100644 compiler/bin-wasmoo_util/cmd_arg.ml create mode 100644 compiler/bin-wasmoo_util/cmd_arg.mli create mode 100644 compiler/bin-wasmoo_util/dune create mode 100644 compiler/bin-wasmoo_util/wasmoo_util.ml create mode 100644 compiler/lib-wasm/runtime.ml create mode 100644 compiler/lib-wasm/runtime.mli create mode 100644 compiler/lib-wasm/wat_preprocess.ml create mode 100644 compiler/lib-wasm/wat_preprocess.mli diff --git a/compiler/bin-wasm_of_ocaml/compile.ml b/compiler/bin-wasm_of_ocaml/compile.ml index 3905c0428a..8b0f4a0f31 100644 --- a/compiler/bin-wasm_of_ocaml/compile.ml +++ b/compiler/bin-wasm_of_ocaml/compile.ml @@ -73,6 +73,21 @@ let output_gen output_file f = Code.Var.set_stable (Config.Flag.stable_var ()); Filename.gen_file output_file f +let with_runtime_files ~runtime_wasm_files f = + let inputs = + List.map + ~f:(fun file -> + { Wat_preprocess.module_name = "env" + ; file + ; source = + (if Link.Wasm_binary.check_file ~file + then File + else Contents (Js_of_ocaml_compiler.Fs.read_file file)) + }) + runtime_wasm_files + in + Wat_preprocess.with_preprocessed_files ~variables:[] ~inputs f + let link_and_optimize ~profile ~sourcemap_root @@ -100,15 +115,15 @@ let link_and_optimize then Some (Filename.temp_file "wasm-merged" ".wasm.map") else None) @@ fun opt_temp_sourcemap -> + (with_runtime_files ~runtime_wasm_files + @@ fun runtime_inputs -> Binaryen.link ~inputs: - (List.map - ~f:(fun file -> { Binaryen.module_name = "env"; file }) - (runtime_file :: runtime_wasm_files) + (({ Binaryen.module_name = "env"; file = runtime_file } :: runtime_inputs) @ List.map ~f:(fun file -> { Binaryen.module_name = "OCaml"; file }) wat_files) ~opt_output_sourcemap:opt_temp_sourcemap ~output_file:temp_file - (); + ()); Fs.with_intermediate_file (Filename.temp_file "wasm-dce" ".wasm") @@ fun temp_file' -> opt_with @@ -141,12 +156,11 @@ let link_runtime ~profile runtime_wasm_files output_file = Fs.write_file ~name:runtime_file ~contents:Runtime_files.wasm_runtime; Fs.with_intermediate_file (Filename.temp_file "wasm-merged" ".wasm") @@ fun temp_file -> + with_runtime_files ~runtime_wasm_files + @@ fun runtime_inputs -> Binaryen.link ~opt_output_sourcemap:None - ~inputs: - (List.map - ~f:(fun file -> { Binaryen.module_name = "env"; file }) - (runtime_file :: runtime_wasm_files)) + ~inputs:({ Binaryen.module_name = "env"; file = runtime_file } :: runtime_inputs) ~output_file:temp_file (); Binaryen.optimize diff --git a/compiler/bin-wasmoo_util/cmd_arg.ml b/compiler/bin-wasmoo_util/cmd_arg.ml new file mode 100644 index 0000000000..d9c6d01bdd --- /dev/null +++ b/compiler/bin-wasmoo_util/cmd_arg.ml @@ -0,0 +1,181 @@ +(* Js_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * Copyright (C) 2014 Hugo Heuzard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +open Cmdliner + +type variables = + { enable : string list + ; disable : string list + ; set : (string * string) list + } + +type preprocess_options = + { input_file : string option + ; output_file : string option + ; variables : variables + } + +let variable_options = + let enable = + let doc = "Set preprocessor variable $(docv) to true." in + let arg = + Arg.(value & opt_all (list string) [] & info [ "enable" ] ~docv:"VAR" ~doc) + in + Term.(const List.flatten $ arg) + in + let disable = + let doc = "Set preprocessor variable $(docv) to false." in + let arg = + Arg.(value & opt_all (list string) [] & info [ "disable" ] ~docv:"VAR" ~doc) + in + Term.(const List.flatten $ arg) + in + let set = + let doc = "Set preprocessor variable $(i,VAR) to value $(i,VALUE)." in + let arg = + Arg.( + value + & opt_all (list (pair ~sep:'=' string string)) [] + & info [ "set" ] ~docv:"VAR=VALUE" ~doc) + in + Term.(const List.flatten $ arg) + in + let build_t enable disable set = { enable; disable; set } in + Term.(const build_t $ enable $ disable $ set) + +let preprocess_options = + let input_file = + let doc = + "Use the Wasm text file $(docv) as input (default to the standard input)." + in + Arg.(value & pos 0 (some string) None & info [] ~docv:"INPUT_FILE" ~doc) + in + let output_file = + let doc = "Specify the output file $(docv) (default to the standard output)." in + Arg.(value & opt (some string) None & info [ "o" ] ~docv:"OUTPUT_FILE" ~doc) + in + let build_t input_file output_file variables = + `Ok { input_file; output_file; variables } + in + let t = Term.(const build_t $ input_file $ output_file $ variable_options) in + Term.ret t + +type binaryen_options = + { common : string list + ; opt : string list + ; merge : string list + } + +type link_options = + { input_modules : (string * string) list + ; output_file : string + ; variables : variables + ; binaryen_options : binaryen_options + } + +let link_options = + let input_modules = + let doc = + "Specify an input module with name $(i,NAME) in Wasm text file $(i,FILE)." + in + Arg.( + value + & pos_right 0 (pair ~sep:':' string string) [] + & info [] ~docv:"NAME:FILE" ~doc) + in + let output_file = + let doc = "Specify the Wasm binary output file $(docv)." in + Arg.(required & pos 0 (some string) None & info [] ~docv:"WASM_FILE" ~doc) + in + let binaryen_options = + let doc = "Pass option $(docv) to binaryen tools" in + Arg.(value & opt_all string [] & info [ "binaryen" ] ~docv:"OPT" ~doc) + in + let opt_options = + let doc = "Pass option $(docv) to $(b,wasm-opt)" in + Arg.(value & opt_all string [] & info [ "binaryen-opt" ] ~docv:"OPT" ~doc) + in + let merge_options = + let doc = "Pass option $(docv) to $(b,wasm-merge)" in + Arg.(value & opt_all string [] & info [ "binaryen-merge" ] ~docv:"OPT" ~doc) + in + let build_t input_modules output_file variables common opt merge = + `Ok + { input_modules; output_file; variables; binaryen_options = { common; opt; merge } } + in + let t = + Term.( + const build_t + $ input_modules + $ output_file + $ variable_options + $ binaryen_options + $ opt_options + $ merge_options) + in + Term.ret t + +let make_info ~name ~doc ~description = + let man = + [ `S "DESCRIPTION" + ; `P description + ; `S "BUGS" + ; `P + "Bugs are tracked on github at \ + $(i,https://github.com/ocsigen/js_of_ocaml/issues)." + ; `S "SEE ALSO" + ; `P "wasm_of_ocaml(1)" + ; `S "AUTHORS" + ; `P "Jerome Vouillon, Hugo Heuzard." + ; `S "LICENSE" + ; `P "Copyright (C) 2010-2025." + ; `P + "wasmoo_util is free software, you can redistribute it and/or modify it under \ + the terms of the GNU Lesser General Public License as published by the Free \ + Software Foundation, with linking exception; either version 2.1 of the License, \ + or (at your option) any later version." + ] + in + let version = + match Js_of_ocaml_compiler.Compiler_version.git_version with + | "" -> Js_of_ocaml_compiler.Compiler_version.s + | v -> Printf.sprintf "%s+%s" Js_of_ocaml_compiler.Compiler_version.s v + in + Cmd.info name ~version ~doc ~man + +let preprocess_info = + make_info + ~name:"pp" + ~doc:"Wasm text file preprocessor" + ~description:"$(b,wasmoo_util pp) is a Wasm text file preprocessor." + +let link_info = + make_info + ~name:"link" + ~doc:"Wasm linker" + ~description: + "$(b,wasmoo_util link) is a Wasm linker. It takes as input a list of Wasm text \ + files, preprocesses them, links them together, and outputs a single Wasm binary \ + module" + +let info = + make_info + ~name:"wasmoo_util" + ~doc:"Wasm utilities" + ~description:"wasmoo_util is a collection of utilities for $(b,wasm_of_ocaml)" diff --git a/compiler/bin-wasmoo_util/cmd_arg.mli b/compiler/bin-wasmoo_util/cmd_arg.mli new file mode 100644 index 0000000000..e23e53c35e --- /dev/null +++ b/compiler/bin-wasmoo_util/cmd_arg.mli @@ -0,0 +1,52 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +type variables = + { enable : string list + ; disable : string list + ; set : (string * string) list + } + +type preprocess_options = + { input_file : string option + ; output_file : string option + ; variables : variables + } + +val preprocess_options : preprocess_options Cmdliner.Term.t + +val preprocess_info : Cmdliner.Cmd.info + +type binaryen_options = + { common : string list + ; opt : string list + ; merge : string list + } + +type link_options = + { input_modules : (string * string) list + ; output_file : string + ; variables : variables + ; binaryen_options : binaryen_options + } + +val link_options : link_options Cmdliner.Term.t + +val link_info : Cmdliner.Cmd.info + +val info : Cmdliner.Cmd.info diff --git a/compiler/bin-wasmoo_util/dune b/compiler/bin-wasmoo_util/dune new file mode 100644 index 0000000000..d09db61954 --- /dev/null +++ b/compiler/bin-wasmoo_util/dune @@ -0,0 +1,17 @@ +(executable + (name wasmoo_util) + (public_name wasmoo_util) + (package wasm_of_ocaml-compiler) + (libraries wasm_of_ocaml-compiler jsoo_cmdline cmdliner)) + +(rule + (targets wasmoo_util.1) + (action + (with-stdout-to + %{targets} + (run %{bin:wasmoo_util} --help=groff)))) + +(install + (section man) + (package wasm_of_ocaml-compiler) + (files wasmoo_util.1)) diff --git a/compiler/bin-wasmoo_util/wasmoo_util.ml b/compiler/bin-wasmoo_util/wasmoo_util.ml new file mode 100644 index 0000000000..6f0cc37e29 --- /dev/null +++ b/compiler/bin-wasmoo_util/wasmoo_util.ml @@ -0,0 +1,121 @@ +(* Js_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * Copyright (C) 2013 Hugo Heuzard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +open Js_of_ocaml_compiler.Stdlib +open Wasm_of_ocaml_compiler + +let () = Sys.catch_break true + +let read_contents ch = + let buf = Buffer.create 65536 in + let b = Bytes.create 65536 in + let rec read () = + let n = input ch b 0 (Bytes.length b) in + if n > 0 + then ( + Buffer.add_subbytes buf b 0 n; + read ()) + in + read (); + Buffer.contents buf + +let set_variables { Cmd_arg.enable; disable; set } = + List.map ~f:(fun nm -> nm, Wat_preprocess.Bool true) enable + @ List.map ~f:(fun nm -> nm, Wat_preprocess.Bool false) disable + @ List.map ~f:(fun (nm, v) -> nm, Wat_preprocess.String v) set + +let preprocess { Cmd_arg.input_file; output_file; variables } = + let with_input f = + match input_file with + | None -> f stdin + | Some file -> + let ch = open_in file in + let res = f ch in + close_in ch; + res + in + let with_output f = + match output_file with + | Some "-" | None -> f stdout + | Some file -> Filename.gen_file file f + in + let contents = with_input read_contents in + let res = + Wat_preprocess.f + ~filename:(Option.value ~default:"-" input_file) + ~contents + ~variables:(set_variables variables) + in + with_output (fun ch -> output_string ch res) + +let preprocess_term = Cmdliner.Term.(const preprocess $ Cmd_arg.preprocess_options) + +let preprocess_command = Cmdliner.Cmd.v Cmd_arg.preprocess_info preprocess_term + +let link + { Cmd_arg.input_modules + ; output_file + ; variables + ; binaryen_options = { common; merge; opt } + } = + let inputs = + List.map + ~f:(fun (module_name, file) -> + { Wat_preprocess.module_name + ; file + ; source = + (if Link.Wasm_binary.check_file ~file + then File + else Contents (Js_of_ocaml_compiler.Fs.read_file file)) + }) + input_modules + in + Runtime.build + ~link_options:(common @ merge) + ~opt_options:(common @ opt) + ~variables:(set_variables variables) + ~inputs + ~output_file + +let link_term = Cmdliner.Term.(const link $ Cmd_arg.link_options) + +let link_command = Cmdliner.Cmd.v Cmd_arg.link_info link_term + +let (_ : int) = + try + Cmdliner.Cmd.eval + ~catch:false + ~argv:(Jsoo_cmdline.normalize_argv ~warn:(warn "%s") Sys.argv) + (Cmdliner.Cmd.group Cmd_arg.info [ preprocess_command; link_command ]) + with + | (Match_failure _ | Assert_failure _ | Not_found) as exc -> + let backtrace = Printexc.get_backtrace () in + Format.eprintf + "%s: You found a bug. Please report it at \ + https://github.com/ocsigen/js_of_ocaml/issues :@." + Sys.argv.(0); + Format.eprintf "Error: %s@." (Printexc.to_string exc); + prerr_string backtrace; + exit 1 + | Failure s -> + Format.eprintf "%s: Error: %s@." Sys.argv.(0) s; + exit 1 + | exc -> + Format.eprintf "%s: Error: %s@." Sys.argv.(0) (Printexc.to_string exc); + exit 1 diff --git a/compiler/lib-wasm/dune b/compiler/lib-wasm/dune index 2a54c9316f..90e6dcddee 100644 --- a/compiler/lib-wasm/dune +++ b/compiler/lib-wasm/dune @@ -4,4 +4,6 @@ (synopsis "Wasm_of_ocaml compiler library") (libraries js_of_ocaml_compiler) (flags - (:standard -w -7-37 -safe-string -open Js_of_ocaml_compiler))) + (:standard -w -7-37 -safe-string -open Js_of_ocaml_compiler)) + (preprocess + (pps sedlex.ppx))) diff --git a/compiler/lib-wasm/link.ml b/compiler/lib-wasm/link.ml index b5822d31ea..4178ce0b3a 100644 --- a/compiler/lib-wasm/link.ml +++ b/compiler/lib-wasm/link.ml @@ -104,6 +104,19 @@ module Wasm_binary = struct if not (String.equal s header) then failwith (file ^ " is not a Wasm binary file (bad magic)") + let check ~contents = String.starts_with ~prefix:header contents + + let check_file ~file = + let ch = open_in file in + let res = + try + let s = really_input_string ch 8 in + String.equal s header + with End_of_file -> false + in + close_in ch; + res + type t = { ch : in_channel ; limit : int diff --git a/compiler/lib-wasm/link.mli b/compiler/lib-wasm/link.mli index 9ad39a4244..0c788e7d47 100644 --- a/compiler/lib-wasm/link.mli +++ b/compiler/lib-wasm/link.mli @@ -24,6 +24,10 @@ module Wasm_binary : sig ; name : string } + val check : contents:string -> bool + + val check_file : file:string -> bool + val read_imports : file:string -> import list val append_source_map_section : file:string -> url:string -> unit diff --git a/compiler/lib-wasm/runtime.ml b/compiler/lib-wasm/runtime.ml new file mode 100644 index 0000000000..7402dd69c7 --- /dev/null +++ b/compiler/lib-wasm/runtime.ml @@ -0,0 +1,21 @@ +open Stdlib + +let build ~link_options ~opt_options ~variables ~inputs ~output_file = + Fs.with_intermediate_file (Filename.temp_file "runtime-merged" ".wasm") + @@ fun merge_file -> + (Wat_preprocess.with_preprocessed_files ~variables ~inputs + @@ fun inputs -> + Binaryen.link + ~options:link_options + ~opt_output_sourcemap:None + ~inputs + ~output_file:merge_file + ()); + Binaryen.optimize + ~profile:None + ~options:opt_options + ~opt_input_sourcemap:None + ~input_file:merge_file + ~opt_output_sourcemap:None + ~output_file + () diff --git a/compiler/lib-wasm/runtime.mli b/compiler/lib-wasm/runtime.mli new file mode 100644 index 0000000000..2ba99e5e59 --- /dev/null +++ b/compiler/lib-wasm/runtime.mli @@ -0,0 +1,7 @@ +val build : + link_options:string list + -> opt_options:string list + -> variables:(string * Wat_preprocess.value) list + -> inputs:Wat_preprocess.input list + -> output_file:string + -> unit diff --git a/compiler/lib-wasm/wat_preprocess.ml b/compiler/lib-wasm/wat_preprocess.ml new file mode 100644 index 0000000000..52b97f88b7 --- /dev/null +++ b/compiler/lib-wasm/wat_preprocess.ml @@ -0,0 +1,520 @@ +open Stdlib + +exception Error of (Lexing.position * Lexing.position) * string + +let report_error loc msg = + let location = MenhirLib.LexerUtil.range loc in + Format.eprintf "%s%s%!" location msg; + exit 1 + +(****) + +let digit = [%sedlex.regexp? '0' .. '9'] + +let hexdigit = [%sedlex.regexp? '0' .. '9' | 'a' .. 'f' | 'A' .. 'F'] + +let num = [%sedlex.regexp? digit, Star (Opt '_', digit)] + +let hexnum = [%sedlex.regexp? hexdigit, Star (Opt '_', hexdigit)] + +let uN = [%sedlex.regexp? num | "0x", hexnum] + +let idchar = + [%sedlex.regexp? + ( '0' .. '9' + | 'A' .. 'Z' + | 'a' .. 'z' + | '!' + | '#' + | '$' + | '%' + | '&' + | '\'' + | '*' + | '+' + | '-' + | '.' + | '/' + | ':' + | '<' + | '=' + | '>' + | '?' + | '@' + | '\\' + | '^' + | '_' + | '`' + | '|' + | '~' )] + +let id = [%sedlex.regexp? '$', Plus idchar] + +let linechar = [%sedlex.regexp? Sub (any, (10 | 13))] + +let newline = [%sedlex.regexp? 10 | 13 | 13, 10] + +let linecomment = [%sedlex.regexp? ";;", Star linechar, (newline | eof)] + +let keyword = [%sedlex.regexp? Plus idchar] + +let rec comment start_pos lexbuf = + match%sedlex lexbuf with + | ";)" -> () + | "(;" -> + comment (Sedlexing.lexing_positions lexbuf) lexbuf; + comment start_pos lexbuf + | ';' | '(' | Plus (Sub (any, (';' | '('))) -> comment start_pos lexbuf + | _ -> raise (Error (start_pos, Printf.sprintf "Unclosed comment.\n")) + +let string_buffer = Buffer.create 256 + +let rec string lexbuf = + match%sedlex lexbuf with + | '"' -> + Buffer.add_string string_buffer (Sedlexing.Utf8.lexeme lexbuf); + let s = Buffer.contents string_buffer in + Buffer.clear string_buffer; + s + | Plus + ( Sub (any, (0 .. 31 | 0x7f | '"' | '\\')) + | "\\t" | "\\n" | "\\r" | "\\'" | "\\\"" | "\\\\" + | '\\', hexdigit, hexdigit + | "\\u{", hexnum, "}" ) -> + Buffer.add_string string_buffer (Sedlexing.Utf8.lexeme lexbuf); + string lexbuf + | _ -> + raise + (Error (Sedlexing.lexing_positions lexbuf, Printf.sprintf "Malformed string.\n")) + +type pos = + { loc : Lexing.position + ; byte_loc : int + } + +type token = + | LPAREN + | RPAREN + | ATOM of string + | EOF + +let locs lexbuf = + let loc, loc' = Sedlexing.lexing_positions lexbuf in + let byte_loc, byte_loc' = Sedlexing.bytes_loc lexbuf in + { loc; byte_loc }, { loc = loc'; byte_loc = byte_loc' } + +let position_of_loc (pos, pos') = pos.loc, pos'.loc + +let rec token lexbuf = + match%sedlex lexbuf with + | '(' -> LPAREN, locs lexbuf + | ')' -> RPAREN, locs lexbuf + | keyword -> ATOM (Sedlexing.Utf8.lexeme lexbuf), locs lexbuf + | '"' -> + let string_start = + { loc = Sedlexing.lexing_position_start lexbuf + ; byte_loc = Sedlexing.lexeme_bytes_start lexbuf + } + in + Buffer.add_char string_buffer '"'; + let str = string lexbuf in + ( ATOM str + , ( string_start + , { loc = Sedlexing.lexing_position_curr lexbuf + ; byte_loc = Sedlexing.lexeme_bytes_end lexbuf + } ) ) + | Plus (' ' | '\t' | newline | linecomment) -> token lexbuf + | "(;" -> + comment (Sedlexing.lexing_positions lexbuf) lexbuf; + token lexbuf + | ";)" -> + raise + (Error + ( Sedlexing.lexing_positions lexbuf + , Printf.sprintf "Unmatched closing comment.\n" )) + | eof -> EOF, locs lexbuf + | _ -> + raise (Error (Sedlexing.lexing_positions lexbuf, Printf.sprintf "Syntax error.\n")) + +type t = + { loc : pos * pos + ; desc : desc + } + +and desc = + | Atom of string + | List of t list + +let rec parse_list lexbuf toplevel start_loc acc = + let tok, loc = token lexbuf in + match tok with + | LPAREN -> + let lst, loc = parse_list lexbuf false loc [] in + parse_list lexbuf toplevel start_loc ({ desc = List lst; loc } :: acc) + | RPAREN -> + if toplevel + then + raise + (Error + ( Sedlexing.lexing_positions lexbuf + , Printf.sprintf "Unexpected closing parenthesis.\n" )); + List.rev acc, (fst start_loc, snd loc) + | EOF -> + if not toplevel + then + raise + (Error (position_of_loc start_loc, Printf.sprintf "Unclosed parenthesis.\n")); + List.rev acc, (fst start_loc, snd loc) + | ATOM s -> parse_list lexbuf toplevel start_loc ({ loc; desc = Atom s } :: acc) + +let parse lexbuf = + let pos = + { loc = Sedlexing.lexing_position_start lexbuf + ; byte_loc = Sedlexing.lexeme_bytes_end lexbuf + } + in + parse_list lexbuf true (pos, pos) [] + +let is_unsigned_integer s = + let lexbuf = Sedlexing.Utf8.from_string s in + match%sedlex lexbuf with + | uN, eof -> true + | _ -> false + +let hexdigit c = + match c with + | '0' .. '9' -> Char.code c - Char.code '0' + | 'a' .. 'f' -> Char.code c - (Char.code 'a' - 10) + | 'A' .. 'F' -> Char.code c - (Char.code 'A' - 10) + | _ -> assert false + +let rec parse_string_contents loc lexbuf = + match%sedlex lexbuf with + | eof -> + let s = Buffer.contents string_buffer in + Buffer.clear string_buffer; + s + | Plus (Sub (any, (0 .. 31 | 0x7f | '"' | '\\'))) -> + Buffer.add_string string_buffer (Sedlexing.Utf8.lexeme lexbuf); + parse_string_contents loc lexbuf + | "\\t" -> + Buffer.add_char string_buffer '\t'; + parse_string_contents loc lexbuf + | "\\n" -> + Buffer.add_char string_buffer '\n'; + parse_string_contents loc lexbuf + | "\\r" -> + Buffer.add_char string_buffer '\r'; + parse_string_contents loc lexbuf + | "\\'" -> + Buffer.add_char string_buffer '\''; + parse_string_contents loc lexbuf + | "\\\"" -> + Buffer.add_char string_buffer '"'; + parse_string_contents loc lexbuf + | "\\\\" -> + Buffer.add_char string_buffer '\\'; + parse_string_contents loc lexbuf + | '\\', hexdigit, hexdigit -> + let s = Sedlexing.Utf8.lexeme lexbuf in + assert (String.length s = 3); + Buffer.add_char string_buffer (Char.chr ((hexdigit s.[1] * 16) + hexdigit s.[2])); + parse_string_contents loc lexbuf + | "\\u{", hexnum, "}" -> ( + match + let s = Sedlexing.Utf8.lexeme lexbuf in + int_of_string ("0x" ^ String.sub s ~pos:3 ~len:(String.length s - 4)) + with + | c when Uchar.is_valid c -> + Buffer.add_utf_8_uchar string_buffer (Uchar.of_int c); + parse_string_contents loc lexbuf + | _ | (exception Failure _) -> + Buffer.clear string_buffer; + raise + (Error + (position_of_loc loc, Printf.sprintf "Invalid Unicode escape sequences.\n")) + ) + | _ -> assert false + +let parse_string loc s = + parse_string_contents + loc + (Sedlexing.Utf8.from_string (String.sub s ~pos:1 ~len:(String.length s - 2))) + +let is_string s = String.length s > 0 && Char.equal s.[0] '"' + +let is_keyword s = + let lexbuf = Sedlexing.Utf8.from_string s in + match%sedlex lexbuf with + | keyword, eof -> true + | _ -> false + +(****) + +module StringMap = Map.Make (String) + +type typ = + | Bool + | String + | Version + +type value = + | Bool of bool + | String of string + | Version of int * int * int + +type st = + { text : string + ; mutable pos : pos + ; variables : value StringMap.t + ; buf : Buffer.t + } + +let value_type v : typ = + match v with + | Bool _ -> Bool + | String _ -> String + | Version _ -> Version + +let type_name (t : typ) = + match t with + | Bool -> "boolean" + | String -> "string" + | Version -> "version" + +let check_type ?typ expr actual_typ = + match typ with + | None -> () + | Some typ -> + if Poly.(actual_typ <> typ) + then + raise + (Error + ( position_of_loc expr.loc + , Printf.sprintf + "Expected a %s but this is a %s.\n" + (type_name typ) + (type_name actual_typ) )) + +let rec eval ?typ st expr = + match expr with + | { desc = Atom s; loc } when is_string s -> + check_type ?typ expr String; + String (parse_string loc s) + | { desc = Atom s; loc } when is_keyword s -> + if not (StringMap.mem s st.variables) + then + raise (Error (position_of_loc loc, Printf.sprintf "Unknown variable '%s'.\n" s)); + let res = StringMap.find s st.variables in + check_type ?typ expr (value_type res); + res + | { desc = + List + [ { desc = Atom major; _ } + ; { desc = Atom minor; _ } + ; { desc = Atom patchlevel; _ } + ] + ; _ + } + when is_unsigned_integer major + && is_unsigned_integer minor + && is_unsigned_integer patchlevel -> + check_type ?typ expr Version; + Version (int_of_string major, int_of_string minor, int_of_string patchlevel) + | { desc = List ({ desc = Atom "and"; _ } :: lst); _ } -> + check_type ?typ expr Bool; + Bool (List.for_all ~f:(fun expr' -> eval_bool st expr') lst) + | { desc = List ({ desc = Atom "or"; _ } :: lst); _ } -> + check_type ?typ expr Bool; + Bool (List.exists ~f:(fun expr' -> eval_bool st expr') lst) + | { desc = List [ { desc = Atom "not"; _ }; expr' ]; _ } -> + check_type ?typ expr Bool; + Bool (not (eval_bool st expr')) + | { desc = + List ({ desc = Atom (("=" | "<" | ">" | "<=" | ">=" | "<>") as op); _ } :: args) + ; loc + } -> bin_op st ?typ loc op args + | { loc; _ } -> raise (Error (position_of_loc loc, Printf.sprintf "Syntax error.\n")) + +and eval_bool st expr = + match eval ~typ:Bool st expr with + | Bool b -> b + | _ -> assert false + +and bin_op st ?typ loc op args = + match args with + | [ expr; expr' ] -> + check_type ?typ expr Bool; + let v = eval st expr in + let v' = eval ~typ:(value_type v) st expr' in + Bool + Poly.( + match op with + | "=" -> v = v' + | "<" -> v < v' + | ">" -> v > v' + | "<=" -> v <= v' + | ">=" -> v >= v' + | "<>" -> v <> v' + | _ -> assert false) + | _ -> raise (Error (position_of_loc loc, Printf.sprintf "Syntax error.\n")) + +(****) + +let write st pos' = + Buffer.add_substring st.buf st.text st.pos.byte_loc (pos'.byte_loc - st.pos.byte_loc); + st.pos <- pos' + +let skip st (pos' : pos) = + let lines = pos'.loc.pos_lnum - st.pos.loc.pos_lnum in + let cols = + pos'.loc.pos_cnum + - pos'.loc.pos_bol + - if lines > 0 then 0 else st.pos.loc.pos_cnum - st.pos.loc.pos_bol + in + Buffer.add_string st.buf (String.make (max 0 lines) '\n'); + Buffer.add_string st.buf (String.make (max 0 cols) ' '); + st.pos <- pos' + +let pred_position { loc; byte_loc } = + { loc = { loc with pos_cnum = loc.pos_cnum - 1 }; byte_loc = byte_loc - 1 } + +let rec rewrite_list st l = List.iter ~f:(rewrite st) l + +and rewrite st elt = + match elt with + | { desc = + List + [ { desc = Atom "@if"; _ } + ; expr + ; { desc = List ({ desc = Atom "@then"; loc = _, pos_after_then } :: then_body) + ; loc = _, pos_after_then_body + } + ] + ; loc = pos, pos' + } -> + write st pos; + if eval_bool st expr + then ( + skip st pos_after_then; + rewrite_list st then_body; + write st (pred_position pos_after_then_body); + skip st pos') + else skip st pos' + | { desc = + List + [ { desc = Atom "@if"; _ } + ; expr + ; { desc = List ({ desc = Atom "@then"; loc = _, pos_after_then } :: then_body) + ; loc = _, pos_after_then_body + } + ; { desc = List ({ desc = Atom "@else"; loc = _, pos_after_else } :: else_body) + ; loc = _, pos_after_else_body + } + ] + ; loc = pos, pos' + } -> + write st pos; + if eval_bool st expr + then ( + skip st pos_after_then; + rewrite_list st then_body; + write st (pred_position pos_after_then_body); + skip st pos') + else ( + skip st pos_after_else; + rewrite_list st else_body; + write st (pred_position pos_after_else_body); + skip st pos') + | { desc = + List + ({ desc = Atom "@if"; _ } + :: _ + :: { desc = List ({ desc = Atom "@then"; _ } :: _); _ } + :: { desc = List ({ desc = Atom "@else"; _ } :: _); _ } + :: { loc; _ } + :: _) + ; _ + } -> + raise + (Error (position_of_loc loc, Printf.sprintf "Expecting closing parenthesis.\n")) + | { desc = + List + ({ desc = Atom "@if"; _ } + :: _ + :: { desc = List ({ desc = Atom "@then"; _ } :: _); _ } + :: { loc; _ } + :: _) + ; _ + } -> + raise + (Error + ( position_of_loc loc + , Printf.sprintf "Expecting @else clause or closing parenthesis.\n" )) + | { desc = List ({ desc = Atom "@if"; _ } :: _ :: { loc = pos, pos'; _ } :: _); _ } + | { desc = List [ { desc = Atom "@if"; _ }; { loc = _, pos; _ } ]; loc = _, pos' } -> + raise (Error ((pos.loc, pos'.loc), Printf.sprintf "Expecting @then clause.\n")) + | { desc = List [ { desc = Atom "@if"; loc = _, pos } ]; loc = _, pos' } -> + raise (Error ((pos.loc, pos'.loc), Printf.sprintf "Expecting condition.\n")) + | { desc = List ({ desc = Atom (("@then" | "@else") as nm); loc } :: _); _ } -> + raise + (Error + ( position_of_loc loc + , Printf.sprintf "Unexpected %s clause. Maybe you forgot a parenthesis.\n" nm + )) + | { desc = List l; _ } -> rewrite_list st l + | _ -> () + +(****) + +let ocaml_version = + Scanf.sscanf Sys.ocaml_version "%d.%d.%d" (fun major minor patchlevel -> + Version (major, minor, patchlevel)) + +let f ~variables ~filename ~contents:text = + let variables = + List.fold_left + ~f:(fun m (k, v) -> StringMap.add k v m) + ~init:StringMap.empty + variables + in + let variables = StringMap.add "ocaml_version" ocaml_version variables in + let lexbuf = Sedlexing.Utf8.from_string text in + Sedlexing.set_filename lexbuf filename; + try + let t, (pos, end_pos) = parse lexbuf in + let st = { text; pos; variables; buf = Buffer.create (String.length text) } in + rewrite_list st t; + write st end_pos; + Buffer.contents st.buf + with Error (loc, msg) -> report_error loc msg + +type source = + | File + | Contents of string + +type input = + { module_name : string + ; file : string + ; source : source + } + +let with_preprocessed_files ~variables ~inputs action = + List.fold_left + ~f:(fun cont { module_name; file; source } inputs -> + match source with + | File -> cont ({ Binaryen.module_name; file } :: inputs) + | Contents contents -> + let source_file = file in + Fs.with_intermediate_file (Filename.temp_file module_name ".wasm") + @@ fun file -> + Fs.write_file + ~name:file + ~contents: + (if Link.Wasm_binary.check ~contents + then contents + else f ~variables ~filename:source_file ~contents); + cont ({ Binaryen.module_name; file } :: inputs)) + ~init:action + inputs + [] diff --git a/compiler/lib-wasm/wat_preprocess.mli b/compiler/lib-wasm/wat_preprocess.mli new file mode 100644 index 0000000000..c0b386f09d --- /dev/null +++ b/compiler/lib-wasm/wat_preprocess.mli @@ -0,0 +1,22 @@ +type value = + | Bool of bool + | String of string + | Version of int * int * int + +val f : variables:(string * value) list -> filename:string -> contents:string -> string + +type source = + | File (* Binary file (skipped) *) + | Contents of string (* Contents to preprocess *) + +type input = + { module_name : string + ; file : string + ; source : source + } + +val with_preprocessed_files : + variables:(string * value) list + -> inputs:input list + -> (Binaryen.link_input list -> 'a) + -> 'a diff --git a/runtime/wasm/args.ml b/runtime/wasm/args.ml index 16cd0418a5..3b34457fea 100644 --- a/runtime/wasm/args.ml +++ b/runtime/wasm/args.ml @@ -1,4 +1,4 @@ let () = for i = 1 to Array.length Sys.argv - 1 do - Format.printf "%s@.%s@." Sys.argv.(i) (Filename.chop_suffix Sys.argv.(i) ".wat") + Format.printf "%s:%s@." (Filename.chop_suffix Sys.argv.(i) ".wat") Sys.argv.(i) done diff --git a/runtime/wasm/dune b/runtime/wasm/dune index 3bbc0a5fc6..84618077d7 100644 --- a/runtime/wasm/dune +++ b/runtime/wasm/dune @@ -31,42 +31,17 @@ (rule (target runtime.wasm) - (deps runtime.merged.wasm) - (action - (run - wasm-opt - -g - --enable-gc - --enable-exception-handling - --enable-reference-types - --enable-tail-call - --enable-strings - --enable-multivalue - --enable-bulk-memory - %{deps} - -O3 - -o - %{target}))) - -(rule - (target runtime.merged.wasm) (deps args (glob_files *.wat)) (action (run - wasm-merge - -g - --enable-gc - --enable-exception-handling - --enable-reference-types - --enable-tail-call - --enable-strings - --enable-multivalue - --enable-bulk-memory - %{read-lines:args} - -o - %{target}))) + wasmoo_util + link + --binaryen=-g + --binaryen-opt=-O3 + %{target} + %{read-lines:args}))) (rule (target args) From aa379b4f39cb73a4da0d560d39c77416e6f179b8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Thu, 30 Jan 2025 18:14:37 +0100 Subject: [PATCH 11/29] Use preprocessor to manage runtime changes between OCaml versions --- manual/wasm_runtime.wiki | 16 +++++- runtime/wasm/domain.wat | 47 ++++++++++++++++ runtime/wasm/dune | 26 --------- runtime/wasm/marshal.wat | 12 ++++- runtime/wasm/runtime_events.wat | 12 +++++ runtime/wasm/version-dependent/post-5.1.wat | 46 ---------------- runtime/wasm/version-dependent/post-5.2.wat | 59 --------------------- runtime/wasm/version-dependent/pre-5.1.wat | 46 ---------------- 8 files changed, 84 insertions(+), 180 deletions(-) delete mode 100644 runtime/wasm/version-dependent/post-5.1.wat delete mode 100644 runtime/wasm/version-dependent/post-5.2.wat delete mode 100644 runtime/wasm/version-dependent/pre-5.1.wat diff --git a/manual/wasm_runtime.wiki b/manual/wasm_runtime.wiki index 6547c55338..a236753bf4 100644 --- a/manual/wasm_runtime.wiki +++ b/manual/wasm_runtime.wiki @@ -46,7 +46,21 @@ You can import the following functions to access or allocate integers of type in (func $caml_copy_int64 (param i64) (result (ref eq)))) }}} -== Implementing primitives +== Preprocessor == + +The Wasm text files are passed through a preprocessor. You can run the processor manually: {{{wasm_of_ocaml pp test.wasm}}}. + +This preprocessing step allows optional compilations of pieces of code depending on the version of the compiler. +{{{ +(@if (>= ocaml_version (5 2 0)) + (@then ...) + (@else ...)) +}}} +To form conditional expressions, the following operators are available: +- comparisons: {{{=}}}, {{{>}}}, {{{>=}}}, {{{<}}}, {{{<=}}}, {{{<>}}}; +- boolean operators: {{{and}}}, {{{or}}}, {{{not}}} + +== Implementing primitives == You define a primitive by exporting a Wasm function with parameters and return value of type {{{(ref eq)}}}. {{{ diff --git a/runtime/wasm/domain.wat b/runtime/wasm/domain.wat index 2c53926868..a4d46414ec 100644 --- a/runtime/wasm/domain.wat +++ b/runtime/wasm/domain.wat @@ -16,6 +16,12 @@ ;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (module + (import "obj" "caml_callback_1" + (func $caml_callback_1 + (param (ref eq)) (param (ref eq)) (result (ref eq)))) + (import "sync" "caml_ml_mutex_unlock" + (func $caml_ml_mutex_unlock (param (ref eq)) (result (ref eq)))) + (type $block (array (mut (ref eq)))) (type $function_1 (func (param (ref eq) (ref eq)) (result (ref eq)))) (type $closure (sub (struct (;(field i32);) (field (ref $function_1))))) @@ -99,6 +105,47 @@ (global $caml_domain_latest_id (export "caml_domain_latest_id") (mut i32) (i32.const 1)) +(@if (>= ocaml_version (5 2 0)) +(@then + (func (export "caml_domain_spawn") + (param $f (ref eq)) (param $term_sync_v (ref eq)) (result (ref eq)) + (local $id i32) (local $old i32) (local $ts (ref $block)) (local $res (ref eq)) + (local.set $id (global.get $caml_domain_latest_id)) + (global.set $caml_domain_latest_id + (i32.add (local.get $id) (i32.const 1))) + (local.set $old (global.get $caml_domain_id)) + (local.set $res + (call $caml_callback_1 (local.get $f) (ref.i31 (i32.const 0)))) + (global.set $caml_domain_id (local.get $old)) + (local.set $ts (ref.cast (ref $block) (local.get $term_sync_v))) + (drop (call $caml_ml_mutex_unlock (array.get $block (local.get $ts) (i32.const 2)))) + ;; TODO: fix exn case + (array.set + $block + (local.get $ts) + (i32.const 1) + (array.new_fixed + $block + 2 + (ref.i31 (i32.const 0)) + (array.new_fixed $block 2 (ref.i31 (i32.const 0)) (local.get $res)))) + (ref.i31 (local.get $id))) +) +(@else + (func (export "caml_domain_spawn") + (param $f (ref eq)) (param $mutex (ref eq)) (result (ref eq)) + (local $id i32) (local $old i32) + (local.set $id (global.get $caml_domain_latest_id)) + (global.set $caml_domain_latest_id + (i32.add (local.get $id) (i32.const 1))) + (local.set $old (global.get $caml_domain_id)) + (drop (call $caml_callback_1 (local.get $f) (ref.i31 (i32.const 0)))) + (global.set $caml_domain_id (local.get $old)) + (drop (call $caml_ml_mutex_unlock (local.get $mutex))) + (ref.i31 (local.get $id))) +)) + + (func (export "caml_ml_domain_id") (export "caml_ml_domain_index") (param (ref eq)) (result (ref eq)) (ref.i31 (global.get $caml_domain_id))) diff --git a/runtime/wasm/dune b/runtime/wasm/dune index 84618077d7..c55cb470cd 100644 --- a/runtime/wasm/dune +++ b/runtime/wasm/dune @@ -3,32 +3,6 @@ (package wasm_of_ocaml-compiler) (files runtime.wasm runtime.js)) -(rule - (target version-dependent.wat) - (deps version-dependent/post-5.2.wat) - (enabled_if - (>= %{ocaml_version} 5.2.0)) - (action - (copy %{deps} %{target}))) - -(rule - (target version-dependent.wat) - (deps version-dependent/post-5.1.wat) - (enabled_if - (and - (>= %{ocaml_version} 5.1.0) - (< %{ocaml_version} 5.2.0))) - (action - (copy %{deps} %{target}))) - -(rule - (target version-dependent.wat) - (deps version-dependent/pre-5.1.wat) - (enabled_if - (< %{ocaml_version} 5.1.0)) - (action - (copy %{deps} %{target}))) - (rule (target runtime.wasm) (deps diff --git a/runtime/wasm/marshal.wat b/runtime/wasm/marshal.wat index 9b68a38eb7..5db0a1a788 100644 --- a/runtime/wasm/marshal.wat +++ b/runtime/wasm/marshal.wat @@ -49,8 +49,6 @@ (import "custom" "caml_find_custom_operations" (func $caml_find_custom_operations (param (ref $bytes)) (result (ref null $custom_operations)))) - (import "version-dependent" "caml_marshal_header_size" - (global $caml_marshal_header_size i32)) (global $input_val_from_string (ref $bytes) (array.new_fixed $bytes 21 @@ -722,6 +720,16 @@ (data $marshal_data_size "Marshal.data_size") +(@if (>= ocaml_version (5 1 0)) +(@then + (global $caml_marshal_header_size (export "caml_marshal_header_size") i32 + (i32.const 16)) +) +(@else + (global $caml_marshal_header_size (export "caml_marshal_header_size") i32 + (i32.const 20)) +)) + (func (export "caml_marshal_data_size") (param $buf (ref eq)) (param $ofs (ref eq)) (result (ref eq)) (local $s (ref $intern_state)) diff --git a/runtime/wasm/runtime_events.wat b/runtime/wasm/runtime_events.wat index be15719f6c..5d207d0820 100644 --- a/runtime/wasm/runtime_events.wat +++ b/runtime/wasm/runtime_events.wat @@ -33,6 +33,18 @@ (local.get $evtag) (local.get $evtype))) +(@if (>= ocaml_version (5 2 0)) +(@then + (func (export "caml_runtime_events_user_write") + (param (ref eq)) (param (ref eq)) (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) +) +(@else + (func (export "caml_runtime_events_user_write") + (param (ref eq)) (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) +)) + (func (export "caml_runtime_events_user_resolve") (param (ref eq)) (param (ref eq)) (param (ref eq)) (result (ref eq)) (ref.i31 (i32.const 0))) diff --git a/runtime/wasm/version-dependent/post-5.1.wat b/runtime/wasm/version-dependent/post-5.1.wat deleted file mode 100644 index 258505a5e9..0000000000 --- a/runtime/wasm/version-dependent/post-5.1.wat +++ /dev/null @@ -1,46 +0,0 @@ -;; Wasm_of_ocaml runtime support -;; http://www.ocsigen.org/js_of_ocaml/ -;; -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU Lesser General Public License as published by -;; the Free Software Foundation, with linking exception; -;; either version 2.1 of the License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public License -;; along with this program; if not, write to the Free Software -;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -(module - (import "obj" "caml_callback_1" - (func $caml_callback_1 - (param (ref eq)) (param (ref eq)) (result (ref eq)))) - (import "sync" "caml_ml_mutex_unlock" - (func $caml_ml_mutex_unlock (param (ref eq)) (result (ref eq)))) - (import "domain" "caml_domain_latest_id" - (global $caml_domain_latest_id (mut i32))) - (import "domain" "caml_domain_id" - (global $caml_domain_id (mut i32))) - - (func (export "caml_runtime_events_user_write") - (param (ref eq)) (param (ref eq)) (result (ref eq)) - (ref.i31 (i32.const 0))) - - (func (export "caml_domain_spawn") - (param $f (ref eq)) (param $mutex (ref eq)) (result (ref eq)) - (local $id i32) (local $old i32) - (local.set $id (global.get $caml_domain_latest_id)) - (global.set $caml_domain_latest_id - (i32.add (local.get $id) (i32.const 1))) - (local.set $old (global.get $caml_domain_id)) - (drop (call $caml_callback_1 (local.get $f) (ref.i31 (i32.const 0)))) - (global.set $caml_domain_id (local.get $old)) - (drop (call $caml_ml_mutex_unlock (local.get $mutex))) - (ref.i31 (local.get $id))) - - (global (export "caml_marshal_header_size") i32 (i32.const 16)) -) diff --git a/runtime/wasm/version-dependent/post-5.2.wat b/runtime/wasm/version-dependent/post-5.2.wat deleted file mode 100644 index b4183d2dcb..0000000000 --- a/runtime/wasm/version-dependent/post-5.2.wat +++ /dev/null @@ -1,59 +0,0 @@ -;; Wasm_of_ocaml runtime support -;; http://www.ocsigen.org/js_of_ocaml/ -;; -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU Lesser General Public License as published by -;; the Free Software Foundation, with linking exception; -;; either version 2.1 of the License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public License -;; along with this program; if not, write to the Free Software -;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -(module - (type $block (array (mut (ref eq)))) - (import "obj" "caml_callback_1" - (func $caml_callback_1 - (param (ref eq)) (param (ref eq)) (result (ref eq)))) - (import "sync" "caml_ml_mutex_unlock" - (func $caml_ml_mutex_unlock (param (ref eq)) (result (ref eq)))) - (import "domain" "caml_domain_latest_id" - (global $caml_domain_latest_id (mut i32))) - (import "domain" "caml_domain_id" - (global $caml_domain_id (mut i32))) - - (func (export "caml_runtime_events_user_write") - (param (ref eq)) (param (ref eq)) (param (ref eq)) (result (ref eq)) - (ref.i31 (i32.const 0))) - - (func (export "caml_domain_spawn") - (param $f (ref eq)) (param $term_sync_v (ref eq)) (result (ref eq)) - (local $id i32) (local $old i32) (local $ts (ref $block)) (local $res (ref eq)) - (local.set $id (global.get $caml_domain_latest_id)) - (global.set $caml_domain_latest_id - (i32.add (local.get $id) (i32.const 1))) - (local.set $old (global.get $caml_domain_id)) - (local.set $res - (call $caml_callback_1 (local.get $f) (ref.i31 (i32.const 0)))) - (global.set $caml_domain_id (local.get $old)) - (local.set $ts (ref.cast (ref $block) (local.get $term_sync_v))) - (drop (call $caml_ml_mutex_unlock (array.get $block (local.get $ts) (i32.const 2)))) - ;; TODO: fix exn case - (array.set - $block - (local.get $ts) - (i32.const 1) - (array.new_fixed - $block - 2 - (ref.i31 (i32.const 0)) - (array.new_fixed $block 2 (ref.i31 (i32.const 0)) (local.get $res)))) - (ref.i31 (local.get $id))) - - (global (export "caml_marshal_header_size") i32 (i32.const 16)) -) diff --git a/runtime/wasm/version-dependent/pre-5.1.wat b/runtime/wasm/version-dependent/pre-5.1.wat deleted file mode 100644 index cc23b90ad7..0000000000 --- a/runtime/wasm/version-dependent/pre-5.1.wat +++ /dev/null @@ -1,46 +0,0 @@ -;; Wasm_of_ocaml runtime support -;; http://www.ocsigen.org/js_of_ocaml/ -;; -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU Lesser General Public License as published by -;; the Free Software Foundation, with linking exception; -;; either version 2.1 of the License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public License -;; along with this program; if not, write to the Free Software -;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -(module - (import "obj" "caml_callback_1" - (func $caml_callback_1 - (param (ref eq)) (param (ref eq)) (result (ref eq)))) - (import "sync" "caml_ml_mutex_unlock" - (func $caml_ml_mutex_unlock (param (ref eq)) (result (ref eq)))) - (import "domain" "caml_domain_latest_id" - (global $caml_domain_latest_id (mut i32))) - (import "domain" "caml_domain_id" - (global $caml_domain_id (mut i32))) - - (func (export "caml_runtime_events_user_write") - (param (ref eq)) (param (ref eq)) (result (ref eq)) - (ref.i31 (i32.const 0))) - - (func (export "caml_domain_spawn") - (param $f (ref eq)) (param $mutex (ref eq)) (result (ref eq)) - (local $id i32) (local $old i32) - (local.set $id (global.get $caml_domain_latest_id)) - (global.set $caml_domain_latest_id - (i32.add (local.get $id) (i32.const 1))) - (local.set $old (global.get $caml_domain_id)) - (drop (call $caml_callback_1 (local.get $f) (ref.i31 (i32.const 0)))) - (global.set $caml_domain_id (local.get $old)) - (drop (call $caml_ml_mutex_unlock (local.get $mutex))) - (ref.i31 (local.get $id))) - - (global (export "caml_marshal_header_size") i32 (i32.const 20)) -) From fb40e558ed2f84a9bbfc37dd103be5fd80fead34 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Thu, 30 Jan 2025 19:36:46 +0100 Subject: [PATCH 12/29] WAT preprocessor: add tests --- compiler/bin-wasmoo_util/tests/cram.t | 154 ++++++++++++++++++ compiler/bin-wasmoo_util/tests/dune | 12 ++ compiler/bin-wasmoo_util/tests/tests.expected | 67 ++++++++ compiler/bin-wasmoo_util/tests/tests.txt | 67 ++++++++ 4 files changed, 300 insertions(+) create mode 100644 compiler/bin-wasmoo_util/tests/cram.t create mode 100644 compiler/bin-wasmoo_util/tests/dune create mode 100644 compiler/bin-wasmoo_util/tests/tests.expected create mode 100644 compiler/bin-wasmoo_util/tests/tests.txt diff --git a/compiler/bin-wasmoo_util/tests/cram.t b/compiler/bin-wasmoo_util/tests/cram.t new file mode 100644 index 0000000000..3093ce69ca --- /dev/null +++ b/compiler/bin-wasmoo_util/tests/cram.t @@ -0,0 +1,154 @@ +Too many parentheses + + $ echo '())' | wasmoo_util pp + File "-", line 1, characters 2-3: + Unexpected closing parenthesis. + [1] + + $ echo '();)' | wasmoo_util pp + File "-", line 1, characters 2-4: + Unmatched closing comment. + [1] + +Missing parenthesis + + $ echo '(()' | wasmoo_util pp + File "-", line 1, characters 0-1: + Unclosed parenthesis. + [1] + + $ echo '(; ()' | wasmoo_util pp + File "-", line 1, characters 0-2: + Unclosed comment. + [1] + + $ echo '(; (; ()' | wasmoo_util pp + File "-", line 1, characters 3-5: + Unclosed comment. + [1] + +Unterminated string (we point at the newline) + + $ echo '"abcd' | wasmoo_util pp + File "-", line 1, characters 5-5: + Malformed string. + [1] + +Bad conditional + + $ echo '(@if)' | wasmoo_util pp + File "-", line 1, characters 4-5: + Expecting condition. + [1] + + $ echo '(@if a)' | wasmoo_util pp + File "-", line 1, characters 6-7: + Expecting @then clause. + [1] + + $ echo '(@if a xxx)' | wasmoo_util pp + File "-", line 1, characters 7-10: + Expecting @then clause. + [1] + + $ echo '(@if a (@then) xx)' | wasmoo_util pp + File "-", line 1, characters 15-17: + Expecting @else clause or closing parenthesis. + [1] + + $ echo '(@if a (@then) (@else) xx)' | wasmoo_util pp + File "-", line 1, characters 23-25: + Expecting closing parenthesis. + [1] + +Syntax error in condition + + $ echo '(@if () (@then))' | wasmoo_util pp + File "-", line 1, characters 5-7: + Syntax error. + [1] + + $ echo '(@if (not) (@then))' | wasmoo_util pp + File "-", line 1, characters 5-10: + Syntax error. + [1] + + $ echo '(@if (not (and) (or)) (@then))' | wasmoo_util pp + File "-", line 1, characters 5-21: + Syntax error. + [1] + + $ echo '(@if (= "a") (@then))' | wasmoo_util pp + File "-", line 1, characters 5-12: + Syntax error. + [1] + + $ echo '(@if (= "a" "b" "c") (@then))' | wasmoo_util pp + File "-", line 1, characters 5-20: + Syntax error. + [1] + +Unicode escape sequences + + $ echo '(@if (= "\u{1F600}" "b") (@then))' | wasmoo_util pp + + + $ echo '(@if (= "\u{D800}" "b") (@then))' | wasmoo_util pp + File "-", line 1, characters 8-18: + Invalid Unicode escape sequences. + [1] + + $ echo '(@if (= "\u{110000}" "b") (@then))' | wasmoo_util pp + File "-", line 1, characters 8-20: + Invalid Unicode escape sequences. + [1] + +Lonely @then or @else + + $ echo '(@then)' | wasmoo_util pp + File "-", line 1, characters 1-6: + Unexpected @then clause. Maybe you forgot a parenthesis. + [1] + + $ echo '(@else)' | wasmoo_util pp + File "-", line 1, characters 1-6: + Unexpected @else clause. Maybe you forgot a parenthesis. + [1] + + $ echo '(@if (and) (@then (@else)))' | wasmoo_util pp + File "-", line 1, characters 19-24: + Unexpected @else clause. Maybe you forgot a parenthesis. + [1] + +Undefined variable + + $ echo '(@if a (@then))' | wasmoo_util pp + File "-", line 1, characters 5-6: + Unknown variable 'a'. + [1] + +Wrong type + $ echo '(@if "" (@then))' | wasmoo_util pp + File "-", line 1, characters 5-7: + Expected a boolean but this is a string. + [1] + + $ echo '(@if (not "") (@then))' | wasmoo_util pp + File "-", line 1, characters 10-12: + Expected a boolean but this is a string. + [1] + + $ echo '(@if (and "") (@then))' | wasmoo_util pp + File "-", line 1, characters 10-12: + Expected a boolean but this is a string. + [1] + + $ echo '(@if (or "") (@then))' | wasmoo_util pp + File "-", line 1, characters 9-11: + Expected a boolean but this is a string. + [1] + + $ echo '(@if (= (and) "") (@then))' | wasmoo_util pp + File "-", line 1, characters 14-16: + Expected a boolean but this is a string. + [1] diff --git a/compiler/bin-wasmoo_util/tests/dune b/compiler/bin-wasmoo_util/tests/dune new file mode 100644 index 0000000000..efe865bf23 --- /dev/null +++ b/compiler/bin-wasmoo_util/tests/dune @@ -0,0 +1,12 @@ +(rule + (with-stdout-to + tests.output + (run wasmoo_util pp --enable a --disable b --set c=1 %{dep:tests.txt}))) + +(rule + (alias runtest) + (action + (diff tests.expected tests.output))) + +(cram + (deps %{bin:wasmoo_util})) diff --git a/compiler/bin-wasmoo_util/tests/tests.expected b/compiler/bin-wasmoo_util/tests/tests.expected new file mode 100644 index 0000000000..45013d93d2 --- /dev/null +++ b/compiler/bin-wasmoo_util/tests/tests.expected @@ -0,0 +1,67 @@ +;; conditional + a is true + b is false + a is true + + +;; nested conditionals + a is true and b is false + + +;; not + + b is false + +;; and + true + a is true + + + a is true and b is false + + + +;; or + + a is true + + a or b is true + a is true or b is false + + a or b is false + +;; strings + newline + quote + +;; string comparisons + c is 1 + + + c is not 2 + +;; version comparisons + + (4 1 1) = (4 1 1) + + (4 1 1) <> (4 1 0) + + (4 1 1) <> (4 1 2) + + (4 1 1) <= (4 1 1) + (4 1 1) <= (4 1 2) + (4 1 1) >= (4 1 0) + (4 1 1) >= (4 1 1) + + (4 1 1) > (4 1 0) + + + +;; version comparisons: lexicographic order + + + (4 1 1) < (4 1 2) + + (4 1 1) < (4 2 0) + (4 1 1) < (5 0 1) + diff --git a/compiler/bin-wasmoo_util/tests/tests.txt b/compiler/bin-wasmoo_util/tests/tests.txt new file mode 100644 index 0000000000..922c4a049a --- /dev/null +++ b/compiler/bin-wasmoo_util/tests/tests.txt @@ -0,0 +1,67 @@ +;; conditional +(@if a (@then a is true) (@else a is false)) +(@if b (@then b is true) (@else b is false)) +(@if a (@then a is true)) +(@if b (@then b is true)) + +;; nested conditionals +(@if a (@then (@if b (@then a and b are true) (@else a is true and b is false))) + (@else (@if b (@then a is false and b is true) (@else a and b are false)))) + +;; not +(@if (not a) (@then a is false)) +(@if (not b) (@then b is false)) + +;; and +(@if (and) (@then true)) +(@if (and a) (@then a is true)) +(@if (and b) (@then b is true)) +(@if (and a b) (@then a and b are true)) +(@if (and a (not b)) (@then a is true and b is false)) +(@if (and (not a) b) (@then a is false and b is true)) +(@if (and (not a) (not b)) (@then a and b are false)) + +;; or +(@if (or) (@then false)) +(@if (or a) (@then a is true)) +(@if (or b) (@then b is true)) +(@if (or a b) (@then a or b is true)) +(@if (or a (not b)) (@then a is true or b is false)) +(@if (or (not a) b) (@then a is false or b is true)) +(@if (or (not a) (not b)) (@then a or b is false)) + +;; strings +(@if (= "\n" "\0a") (@then newline)) +(@if (= "\'" "'") (@then quote)) + +;; string comparisons +(@if (= c "1") (@then c is 1)) +(@if (= c "2") (@then c is 2)) +(@if (<> c "1") (@then c is not 1)) +(@if (<> c "2") (@then c is not 2)) + +;; version comparisons +(@if (= (4 1 1) (4 1 0)) (@then (4 1 1) = (4 1 0))) +(@if (= (4 1 1) (4 1 1)) (@then (4 1 1) = (4 1 1))) +(@if (= (4 1 1) (4 1 2)) (@then (4 1 1) = (4 1 2))) +(@if (<> (4 1 1) (4 1 0)) (@then (4 1 1) <> (4 1 0))) +(@if (<> (4 1 1) (4 1 1)) (@then (4 1 1) <> (4 1 1))) +(@if (<> (4 1 1) (4 1 2)) (@then (4 1 1) <> (4 1 2))) +(@if (<= (4 1 1) (4 1 0)) (@then (4 1 1) <= (4 1 0))) +(@if (<= (4 1 1) (4 1 1)) (@then (4 1 1) <= (4 1 1))) +(@if (<= (4 1 1) (4 1 2)) (@then (4 1 1) <= (4 1 2))) +(@if (>= (4 1 1) (4 1 0)) (@then (4 1 1) >= (4 1 0))) +(@if (>= (4 1 1) (4 1 1)) (@then (4 1 1) >= (4 1 1))) +(@if (>= (4 1 1) (4 1 2)) (@then (4 1 1) >= (4 1 2))) +(@if (> (4 1 1) (4 1 0)) (@then (4 1 1) > (4 1 0))) +(@if (> (4 1 1) (4 1 1)) (@then (4 1 1) > (4 1 1))) +(@if (> (4 1 1) (4 1 2)) (@then (4 1 1) > (4 1 2))) + +;; version comparisons: lexicographic order +(@if (< (4 1 1) (4 1 0)) (@then (4 1 1) < (4 1 0))) +(@if (< (4 1 1) (4 1 1)) (@then (4 1 1) < (4 1 1))) +(@if (< (4 1 1) (4 1 2)) (@then (4 1 1) < (4 1 2))) +(@if (< (4 1 1) (4 0 2)) (@then (4 1 1) < (4 0 2))) +(@if (< (4 1 1) (4 2 0)) (@then (4 1 1) < (4 2 0))) +(@if (< (4 1 1) (5 0 1)) (@then (4 1 1) < (5 0 1))) +(@if (< (4 1 1) (3 2 1)) (@then (4 1 1) < (3 2 1))) From 385e7f13eec5e15c4225e2fb7d4a5aa5fe219856 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Fri, 31 Jan 2025 12:36:09 +0100 Subject: [PATCH 13/29] Syntactic sugar for strings --- compiler/bin-wasmoo_util/tests/cram.t | 35 +++++++++++ compiler/bin-wasmoo_util/tests/tests.expected | 7 +++ compiler/bin-wasmoo_util/tests/tests.txt | 7 +++ compiler/lib-wasm/wat_preprocess.ml | 58 +++++++++++++++++++ manual/wasm_runtime.wiki | 2 + 5 files changed, 109 insertions(+) diff --git a/compiler/bin-wasmoo_util/tests/cram.t b/compiler/bin-wasmoo_util/tests/cram.t index 3093ce69ca..2e8807637d 100644 --- a/compiler/bin-wasmoo_util/tests/cram.t +++ b/compiler/bin-wasmoo_util/tests/cram.t @@ -152,3 +152,38 @@ Wrong type File "-", line 1, characters 14-16: Expected a boolean but this is a string. [1] + +Bad strings + + $ echo '(@string)' | wasmoo_util pp + File "-", line 1, characters 8-9: + Expecting an id or a string. + [1] + + $ echo '(@string a "b")' | wasmoo_util pp + File "-", line 1, characters 9-10: + Expecting an id + [1] + + $ echo '(@string $a b)' | wasmoo_util pp + File "-", line 1, characters 12-13: + Expecting a string + [1] + + $ echo '(@string $good "\u{1F600}")' | wasmoo_util pp + (global $good (ref eq) (array.new_fixed $bytes 4 (i32.const 240) (i32.const 159) (i32.const 152) (i32.const 128))) + + $ echo '(@string $bad "\u{D800}")' | wasmoo_util pp + File "-", line 1, characters 14-24: + Invalid Unicode escape sequences. + [1] + + $ echo '(@string a)' | wasmoo_util pp + File "-", line 1, characters 9-10: + Expecting a string + [1] + + $ echo '(@string a b c)' | wasmoo_util pp + File "-", line 1, characters 13-14: + Expecting a closing parenthesis. + [1] diff --git a/compiler/bin-wasmoo_util/tests/tests.expected b/compiler/bin-wasmoo_util/tests/tests.expected index 45013d93d2..9e5aa1ae61 100644 --- a/compiler/bin-wasmoo_util/tests/tests.expected +++ b/compiler/bin-wasmoo_util/tests/tests.expected @@ -65,3 +65,10 @@ (4 1 1) < (4 2 0) (4 1 1) < (5 0 1) + +;; strings +(global $s (ref eq) (array.new_fixed $bytes 4 (i32.const 97) (i32.const 98) (i32.const 99) (i32.const 100))) +(array.new_fixed $bytes 4 (i32.const 97) (i32.const 98) (i32.const 99) (i32.const 100)) +(array.new_fixed $bytes 4 (i32.const 92) (i32.const 39) (i32.const 40) (i32.const 10)) + (array.new_fixed $bytes 4 (i32.const 97) (i32.const 98) (i32.const 99) (i32.const 100)) + (array.new_fixed $bytes 4 (i32.const 97) (i32.const 98) (i32.const 99) (i32.const 100)) diff --git a/compiler/bin-wasmoo_util/tests/tests.txt b/compiler/bin-wasmoo_util/tests/tests.txt index 922c4a049a..98cd0bd3c8 100644 --- a/compiler/bin-wasmoo_util/tests/tests.txt +++ b/compiler/bin-wasmoo_util/tests/tests.txt @@ -65,3 +65,10 @@ (@if (< (4 1 1) (4 2 0)) (@then (4 1 1) < (4 2 0))) (@if (< (4 1 1) (5 0 1)) (@then (4 1 1) < (5 0 1))) (@if (< (4 1 1) (3 2 1)) (@then (4 1 1) < (3 2 1))) + +;; strings +(@string $s "abcd") +(@string "abcd") +(@string "\\\'\28\n") +(@if (and) (@then (@string "abcd"))) +(@if (or) (@then) (@else (@string "abcd"))) diff --git a/compiler/lib-wasm/wat_preprocess.ml b/compiler/lib-wasm/wat_preprocess.ml index 52b97f88b7..97ec321deb 100644 --- a/compiler/lib-wasm/wat_preprocess.ml +++ b/compiler/lib-wasm/wat_preprocess.ml @@ -249,6 +249,12 @@ let is_keyword s = | keyword, eof -> true | _ -> false +let is_id s = + let lexbuf = Sedlexing.Utf8.from_string s in + match%sedlex lexbuf with + | id, eof -> true + | _ -> false + (****) module StringMap = Map.Make (String) @@ -376,6 +382,14 @@ let skip st (pos' : pos) = Buffer.add_string st.buf (String.make (max 0 cols) ' '); st.pos <- pos' +let insert st s = + Buffer.add_string st.buf s; + let n = String.length s in + st.pos <- + { loc = { st.pos.loc with pos_cnum = st.pos.loc.pos_cnum + n } + ; byte_loc = st.pos.byte_loc - 1 + } + let pred_position { loc; byte_loc } = { loc = { loc with pos_cnum = loc.pos_cnum - 1 }; byte_loc = byte_loc - 1 } @@ -462,6 +476,50 @@ and rewrite st elt = ( position_of_loc loc , Printf.sprintf "Unexpected %s clause. Maybe you forgot a parenthesis.\n" nm )) + | { desc = + List + [ { desc = Atom "@string"; _ } + ; { desc = Atom name; loc = loc_name } + ; { desc = Atom value; loc = loc_value } + ] + ; loc = pos, pos' + } -> + if not (is_id name) then raise (Error (position_of_loc loc_name, "Expecting an id")); + if not (is_string value) + then raise (Error (position_of_loc loc_value, "Expecting a string")); + let s = parse_string loc_value value in + write st pos; + insert + st + (Format.asprintf + "(global %s (ref eq) (array.new_fixed $bytes %d%a))" + name + (String.length s) + (fun f s -> + String.iter ~f:(fun c -> Format.fprintf f " (i32.const %d)" (Char.code c)) s) + s); + skip st pos' + | { desc = List [ { desc = Atom "@string"; _ }; { desc = Atom value; loc = loc_value } ] + ; loc = pos, pos' + } -> + if not (is_string value) + then raise (Error (position_of_loc loc_value, "Expecting a string")); + let s = parse_string loc_value value in + write st pos; + insert + st + (Format.asprintf + "(array.new_fixed $bytes %d%a)" + (String.length s) + (fun f s -> + String.iter ~f:(fun c -> Format.fprintf f " (i32.const %d)" (Char.code c)) s) + s); + skip st pos' + | { desc = List [ { desc = Atom "@string"; loc = _, pos } ]; loc = _, pos' } -> + raise (Error ((pos.loc, pos'.loc), Printf.sprintf "Expecting an id or a string.\n")) + | { desc = List ({ desc = Atom "@string"; _ } :: _ :: _ :: { loc; _ } :: _); _ } -> + raise + (Error (position_of_loc loc, Printf.sprintf "Expecting a closing parenthesis.\n")) | { desc = List l; _ } -> rewrite_list st l | _ -> () diff --git a/manual/wasm_runtime.wiki b/manual/wasm_runtime.wiki index a236753bf4..972dbd91c1 100644 --- a/manual/wasm_runtime.wiki +++ b/manual/wasm_runtime.wiki @@ -60,6 +60,8 @@ To form conditional expressions, the following operators are available: - comparisons: {{{=}}}, {{{>}}}, {{{>=}}}, {{{<}}}, {{{<=}}}, {{{<>}}}; - boolean operators: {{{and}}}, {{{or}}}, {{{not}}} +It also provides some syntactic sugar to write strings. The expression{{{(@string "ab")}}} is expanded into {{{(array.new_fixed $bytes 2 (i32.const 97) (i32.const 98))}}}. The statement {{{(@string $s "ab")}}} is an abbreviation for {{{(global $s (ref eq) (@string "ab"))}}}. + == Implementing primitives == You define a primitive by exporting a Wasm function with parameters and return value of type {{{(ref eq)}}}. From ed5d4192b12131134c3596388219abd7c7284776 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Fri, 31 Jan 2025 12:36:09 +0100 Subject: [PATCH 14/29] Wasm runtime: use string syntactic sugar --- runtime/wasm/array.wat | 17 +--- runtime/wasm/backtrace.wat | 6 +- runtime/wasm/bigarray.wat | 89 ++++++------------ runtime/wasm/bigstring.wat | 4 +- runtime/wasm/compare.wat | 20 ++-- runtime/wasm/effect.wat | 21 ++--- runtime/wasm/fail.wat | 6 +- runtime/wasm/float.wat | 14 +-- runtime/wasm/fs.wat | 25 ++--- runtime/wasm/int32.wat | 27 ++---- runtime/wasm/int64.wat | 13 +-- runtime/wasm/ints.wat | 15 +-- runtime/wasm/io.wat | 11 +-- runtime/wasm/jslib.wat | 11 +-- runtime/wasm/jslib_js_of_ocaml.wat | 9 +- runtime/wasm/lexing.wat | 12 +-- runtime/wasm/marshal.wat | 141 +++++++++-------------------- runtime/wasm/obj.wat | 11 +-- runtime/wasm/parsing.wat | 85 ++++++----------- runtime/wasm/printexc.wat | 3 +- runtime/wasm/stdlib.wat | 20 ++-- runtime/wasm/str.wat | 50 +++------- runtime/wasm/string.wat | 7 +- runtime/wasm/sync.wat | 17 +--- runtime/wasm/sys.wat | 19 ++-- runtime/wasm/unix.wat | 57 +++++------- runtime/wasm/weak.wat | 7 +- 27 files changed, 229 insertions(+), 488 deletions(-) diff --git a/runtime/wasm/array.wat b/runtime/wasm/array.wat index 0be161fec1..6f9acbf4ff 100644 --- a/runtime/wasm/array.wat +++ b/runtime/wasm/array.wat @@ -24,7 +24,7 @@ (type $float (struct (field f64))) (type $float_array (array (mut f64))) - (data $Array_make "Array.make") + (@string $Array_make "Array.make") (global $empty_array (ref eq) (array.new_fixed $block 1 (ref.i31 (i32.const 0)))) @@ -34,10 +34,7 @@ (local $sz i32) (local $b (ref $block)) (local $f f64) (local.set $sz (i31.get_s (ref.cast (ref i31) (local.get $n)))) (if (i32.ge_u (local.get $sz) (i32.const 0xfffffff)) - (then - (call $caml_invalid_argument - (array.new_data $bytes $Array_make - (i32.const 0) (i32.const 10))))) + (then (call $caml_invalid_argument (global.get $Array_make)))) (if (i32.eqz (local.get $sz)) (then (return (global.get $empty_array)))) (drop (block $not_float (result (ref eq)) (local.set $f @@ -56,10 +53,7 @@ (local $sz i32) (local $f f64) (local.set $sz (i31.get_s (ref.cast (ref i31) (local.get $n)))) (if (i32.ge_u (local.get $sz) (i32.const 0x7ffffff)) - (then - (call $caml_invalid_argument - (array.new_data $bytes $Array_make - (i32.const 0) (i32.const 10))))) + (then (call $caml_invalid_argument (global.get $Array_make)))) (if (i32.eqz (local.get $sz)) (then (return (global.get $empty_array)))) (local.set $f (struct.get $float 0 @@ -73,10 +67,7 @@ (local $sz i32) (local.set $sz (i31.get_s (ref.cast (ref i31) (local.get $n)))) (if (i32.ge_u (local.get $sz) (i32.const 0x7ffffff)) - (then - (call $caml_invalid_argument - (array.new_data $bytes $Array_make - (i32.const 0) (i32.const 10))))) + (then (call $caml_invalid_argument (global.get $Array_make)))) (if (i32.eqz (local.get $sz)) (then (return (global.get $empty_array)))) (array.new $float_array (f64.const 0) (local.get $sz))) diff --git a/runtime/wasm/backtrace.wat b/runtime/wasm/backtrace.wat index b411778759..62afca6fc1 100644 --- a/runtime/wasm/backtrace.wat +++ b/runtime/wasm/backtrace.wat @@ -38,14 +38,12 @@ (param (ref eq)) (result (ref eq)) (ref.i31 (i32.const 0))) - (data $raw_backtrace_slot_err + (@string $raw_backtrace_slot_err "Printexc.get_raw_backtrace_slot: index out of bounds") (func (export "caml_raw_backtrace_slot") (param (ref eq) (ref eq)) (result (ref eq)) - (call $caml_invalid_argument - (array.new_data $bytes $raw_backtrace_slot_err - (i32.const 0) (i32.const 52))) + (call $caml_invalid_argument (global.get $raw_backtrace_slot_err)) (ref.i31 (i32.const 0))) (func (export "caml_convert_raw_backtrace_slot") diff --git a/runtime/wasm/bigarray.wat b/runtime/wasm/bigarray.wat index 947f2e2bdb..2322ccf192 100644 --- a/runtime/wasm/bigarray.wat +++ b/runtime/wasm/bigarray.wat @@ -155,10 +155,7 @@ (global $bigarray_ops (export "bigarray_ops") (ref $custom_operations) (struct.new $custom_operations - (array.new_fixed $bytes 9 ;; "_bigarr02" - (i32.const 95) (i32.const 98) (i32.const 105) (i32.const 103) - (i32.const 97) (i32.const 114) (i32.const 114) (i32.const 48) - (i32.const 50)) + (@string "_bigarr02") (ref.func $caml_ba_compare) (ref.null $compare) (ref.func $bigarray_hash) @@ -596,7 +593,7 @@ (i32.mul (i32.add (i32.const 4) (local.get $num_dims)) (i32.const 4)) (i32.mul (i32.add (i32.const 4) (local.get $num_dims)) (i32.const 8)))) - (data $intern_overflow + (@string $intern_overflow "input_value: cannot read bigarray with 64-bit OCaml ints") (func $bigarray_deserialize @@ -680,10 +677,7 @@ (br $done)) ;; int (if (call $caml_deserialize_uint_1 (local.get $s)) - (then - (call $caml_failwith - (array.new_data $bytes $intern_overflow - (i32.const 0) (i32.const 56)))))) + (then (call $caml_failwith (global.get $intern_overflow))))) ;; int32 (loop $loop (if (i32.lt_u (local.get $i) (local.get $len)) @@ -792,8 +786,8 @@ (global $CAML_BA_MAX_NUM_DIMS i32 (i32.const 16)) - (data $ba_create_bad_dims "Bigarray.create: bad number of dimensions") - (data $ba_create_negative_dim "Bigarray.create: negative dimension") + (@string $ba_create_bad_dims "Bigarray.create: bad number of dimensions") + (@string $ba_create_negative_dim "Bigarray.create: negative dimension") (func (export "caml_ba_create") (param $vkind (ref eq)) (param $layout (ref eq)) (param $d (ref eq)) @@ -805,10 +799,7 @@ (local.set $vdim (ref.cast (ref $block) (local.get $d))) (local.set $num_dims (i32.sub (array.len (local.get $vdim)) (i32.const 1))) (if (i32.gt_u (local.get $num_dims) (global.get $CAML_BA_MAX_NUM_DIMS)) - (then - (call $caml_invalid_argument - (array.new_data $bytes $ba_create_bad_dims - (i32.const 0) (i32.const 41))))) + (then (call $caml_invalid_argument (global.get $ba_create_bad_dims)))) (local.set $dim (array.new $int_array (i32.const 0) (local.get $num_dims))) (local.set $i (i32.const 0)) @@ -823,8 +814,7 @@ (if (i32.lt_s (local.get $n) (i32.const 0)) (then (call $caml_invalid_argument - (array.new_data $bytes $ba_create_negative_dim - (i32.const 0) (i32.const 35))))) + (global.get $ba_create_negative_dim)))) (array.set $int_array (local.get $dim) (local.get $i) (local.get $n)) (local.set $i (i32.add (local.get $i) (i32.const 1))) @@ -838,8 +828,8 @@ (local.get $kind) (i31.get_s (ref.cast (ref i31) (local.get $layout))))) - (data $ta_unsupported_kind "Typed_array.to_genarray: unsupported kind") - (data $ta_too_large "Typed_array.to_genarray: too large") + (@string $ta_unsupported_kind "Typed_array.to_genarray: unsupported kind") + (@string $ta_too_large "Typed_array.to_genarray: too large") (func (export "caml_ba_from_typed_array") (param (ref eq)) (result (ref eq)) (local $data (ref extern)) @@ -850,18 +840,12 @@ (ref.as_non_null (extern.convert_any (call $unwrap (local.get 0)))))) (local.set $kind (call $ta_kind (local.get $data))) (if (i32.lt_s (local.get $kind) (i32.const 0)) - (then - (call $caml_invalid_argument - (array.new_data $bytes $ta_unsupported_kind - (i32.const 0) (i32.const 41))))) + (then (call $caml_invalid_argument (global.get $ta_unsupported_kind)))) (if (i32.eq (local.get $kind) (i32.const 14)) ;; Uint8ClampedArray (then (local.set $kind (i32.const 3)))) (local.set $len (call $ta_length (local.get $data))) (if (i32.lt_s (local.get $len) (i32.const 0)) - (then - (call $caml_invalid_argument - (array.new_data $bytes $ta_too_large - (i32.const 0) (i32.const 34))))) + (then (call $caml_invalid_argument (global.get $ta_too_large)))) (struct.new $bigarray (global.get $bigarray_ops) (local.get $data) @@ -1050,7 +1034,7 @@ (struct.get $float 0 (ref.cast (ref $float) (local.get $v)))) (return)) - (data $Bigarray_dim "Bigarray.dim") + (@string $Bigarray_dim "Bigarray.dim") (func $caml_ba_dim (export "caml_ba_dim") (param (ref eq)) (param (ref eq)) (result (ref eq)) @@ -1061,9 +1045,7 @@ (ref.cast (ref $bigarray) (local.get 0)))) (local.set $i (i31.get_s (ref.cast (ref i31) (local.get 1)))) (if (i32.ge_u (local.get $i) (array.len (local.get $dim))) - (then (call $caml_invalid_argument - (array.new_data $bytes $Bigarray_dim - (i32.const 0) (i32.const 12))))) + (then (call $caml_invalid_argument (global.get $Bigarray_dim)))) (ref.i31 (array.get $int_array (local.get $dim) (local.get $i)))) (func (export "caml_ba_dim_1") (param (ref eq)) (result (ref eq)) @@ -1409,7 +1391,7 @@ (local.get $v)) (ref.i31 (i32.const 0))) - (data $too_many_indices "Bigarray.slice: too many indices") + (@string $too_many_indices "Bigarray.slice: too many indices") (func (export "caml_ba_slice") (param $vb (ref eq)) (param $vind (ref eq)) (result (ref eq)) @@ -1425,10 +1407,7 @@ (local.set $num_dims (struct.get $bigarray $ba_num_dims (local.get $b))) (if (i32.gt_u (local.get $num_inds) (struct.get $bigarray $ba_num_dims (local.get $b))) - (then - (call $caml_invalid_argument - (array.new_data $bytes $too_many_indices - (i32.const 0) (i32.const 32))))) + (then (call $caml_invalid_argument (global.get $too_many_indices)))) (local.set $sub_dim (array.new $int_array (i32.const 0) (i32.sub (local.get $num_dims) (local.get $num_inds)))) @@ -1492,7 +1471,7 @@ (struct.get $bigarray $ba_kind (local.get $b)) (struct.get $bigarray $ba_layout (local.get $b)))) - (data $bad_subarray "Bigarray.sub: bad sub-array") + (@string $bad_subarray "Bigarray.sub: bad sub-array") (func (export "caml_ba_sub") (param $vba (ref eq)) (param $vofs (ref eq)) (param $vlen (ref eq)) @@ -1542,10 +1521,7 @@ (i32.gt_s (i32.add (local.get $ofs) (local.get $len)) (array.get $int_array (local.get $dim) (local.get $changed_dim)))) - (then - (call $caml_invalid_argument - (array.new_data $bytes $bad_subarray - (i32.const 0) (i32.const 27))))) + (then (call $caml_invalid_argument (global.get $bad_subarray)))) (local.set $new_dim (array.new $int_array (i32.const 0) (local.get $num_dims))) (array.copy $int_array $int_array @@ -1658,7 +1634,7 @@ (struct.get $float 0 (ref.cast (ref $float) (local.get $v)))) (return (ref.i31 (i32.const 0)))) - (data $dim_mismatch "Bigarray.blit: dimension mismatch") + (@string $dim_mismatch "Bigarray.blit: dimension mismatch") (func (export "caml_ba_blit") (param $vsrc (ref eq)) (param $vdst (ref eq)) (result (ref eq)) @@ -1672,10 +1648,7 @@ (local.set $len (struct.get $bigarray $ba_num_dims (local.get $dst))) (if (i32.ne (local.get $len) (struct.get $bigarray $ba_num_dims (local.get $src))) - (then - (call $caml_invalid_argument - (array.new_data $bytes $dim_mismatch - (i32.const 0) (i32.const 33))))) + (then (call $caml_invalid_argument (global.get $dim_mismatch)))) (local.set $sdim (struct.get $bigarray $ba_dim (local.get $src))) (local.set $ddim (struct.get $bigarray $ba_dim (local.get $dst))) (loop $loop @@ -1685,9 +1658,7 @@ (array.get $int_array (local.get $sdim) (local.get $i)) (array.get $int_array (local.get $ddim) (local.get $i))) (then - (call $caml_invalid_argument - (array.new_data $bytes $dim_mismatch - (i32.const 0) (i32.const 33))))) + (call $caml_invalid_argument (global.get $dim_mismatch)))) (local.set $i (i32.add (local.get $i) (i32.const 1))) (br $loop)))) (call $ta_blit @@ -1695,9 +1666,9 @@ (struct.get $bigarray $ba_data (local.get $dst))) (ref.i31 (i32.const 0))) - (data $bad_number_dim "Bigarray.reshape: bad number of dimensions") - (data $negative_dim "Bigarray.reshape: negative dimension") - (data $size_mismatch "Bigarray.reshape: size mismatch") + (@string $bad_number_dim "Bigarray.reshape: bad number of dimensions") + (@string $negative_dim "Bigarray.reshape: negative dimension") + (@string $size_mismatch "Bigarray.reshape: size mismatch") (func (export "caml_ba_reshape") (param $vb (ref eq)) (param $vd (ref eq)) (result (ref eq)) @@ -1709,10 +1680,7 @@ (local.set $num_dims (i32.sub (array.len (local.get $vdim)) (i32.const 1))) (local.set $b (ref.cast (ref $bigarray) (local.get $vb))) (if (i32.gt_u (local.get $num_dims) (global.get $CAML_BA_MAX_NUM_DIMS)) - (then - (call $caml_invalid_argument - (array.new_data $bytes $bad_number_dim - (i32.const 0) (i32.const 42))))) + (then (call $caml_invalid_argument (global.get $bad_number_dim)))) (local.set $num_elts (i64.const 1)) (local.set $dim (array.new $int_array (i32.const 0) (local.get $num_dims))) (loop $loop @@ -1725,9 +1693,7 @@ (i32.add (local.get $i) (i32.const 1)))))) (if (i32.lt_s (local.get $d) (i32.const 0)) (then - (call $caml_invalid_argument - (array.new_data $bytes $negative_dim - (i32.const 0) (i32.const 36))))) + (call $caml_invalid_argument (global.get $negative_dim)))) (array.set $int_array (local.get $dim) (local.get $i) (local.get $d)) (local.set $num_elts @@ -1741,10 +1707,7 @@ (if (i32.ne (i32.wrap_i64 (local.get $num_elts)) (call $caml_ba_get_size (struct.get $bigarray $ba_dim (local.get $b)))) - (then - (call $caml_invalid_argument - (array.new_data $bytes $size_mismatch - (i32.const 0) (i32.const 31))))) + (then (call $caml_invalid_argument (global.get $size_mismatch)))) (struct.new $bigarray (global.get $bigarray_ops) (struct.get $bigarray $ba_data (local.get $b)) diff --git a/runtime/wasm/bigstring.wat b/runtime/wasm/bigstring.wat index 3c816953ac..1d9afd2ae9 100644 --- a/runtime/wasm/bigstring.wat +++ b/runtime/wasm/bigstring.wat @@ -98,13 +98,13 @@ (local.set $h (call $caml_hash_mix_int (local.get $h) (local.get $w)))) (i32.xor (local.get $h) (local.get $len))) - (data $buffer "buffer") + (@string $buffer "buffer") (func (export "bigstring_to_array_buffer") (param $bs (ref eq)) (result (ref eq)) (return_call $caml_js_get (call $caml_ba_to_typed_array (local.get $bs)) - (array.new_data $bytes $buffer (i32.const 0) (i32.const 6)))) + (global.get $buffer))) (export "bigstring_to_typed_array" (func $caml_ba_to_typed_array)) diff --git a/runtime/wasm/compare.wat b/runtime/wasm/compare.wat index e17b223dbc..b6a48a62b7 100644 --- a/runtime/wasm/compare.wat +++ b/runtime/wasm/compare.wat @@ -215,9 +215,9 @@ (call $clear_compare_stack) (local.get $res)) - (data $abstract_value "compare: abstract value") - (data $functional_value "compare: functional value") - (data $continuation_value "compare: continuation value") + (@string $abstract_value "compare: abstract value") + (@string $functional_value "compare: functional value") + (@string $continuation_value "compare: continuation value") (func $do_compare_val (param $stack (ref $compare_stack)) @@ -477,9 +477,7 @@ (br_if $next_item (i32.eqz (local.get $res))) (return (local.get $res))) (call $clear_compare_stack) - (call $caml_invalid_argument - (array.new_data $bytes $abstract_value - (i32.const 0) (i32.const 23))) + (call $caml_invalid_argument (global.get $abstract_value)) (ref.i31 (i32.const 0)))) (drop (block $v1_not_js (result (ref eq)) (local.set $js1 @@ -514,8 +512,7 @@ (i32.eqz (call $caml_is_closure (local.get $v2))))) (call $clear_compare_stack) (call $caml_invalid_argument - (array.new_data $bytes $functional_value - (i32.const 0) (i32.const 25))))) + (global.get $functional_value)))) (if (call $caml_is_continuation (local.get $v1)) (then (drop (br_if $heterogeneous(ref.i31 (i32.const 0)) @@ -523,8 +520,7 @@ (call $caml_is_continuation (local.get $v2))))) (call $clear_compare_stack) (call $caml_invalid_argument - (array.new_data $bytes $continuation_value - (i32.const 0) (i32.const 27))))) + (global.get $continuation_value)))) (ref.i31 (i32.const 0)))) ;; fall through ;; heterogeneous comparison (local.set $t1 @@ -549,9 +545,7 @@ (if (i32.eqz (local.get $res)) (then (call $clear_compare_stack) - (call $caml_invalid_argument - (array.new_data $bytes $abstract_value - (i32.const 0) (i32.const 23))))) + (call $caml_invalid_argument (global.get $abstract_value)))) (return (local.get $res))) (if (call $compare_stack_is_not_empty (local.get $stack)) (then diff --git a/runtime/wasm/effect.wat b/runtime/wasm/effect.wat index 9b9430a871..1c457a6380 100644 --- a/runtime/wasm/effect.wat +++ b/runtime/wasm/effect.wat @@ -121,23 +121,18 @@ (field $cont (ref $cont)) (field $next (ref null $fiber))))) - (data $effect_unhandled "Effect.Unhandled") + (@string $effect_unhandled "Effect.Unhandled") (func $raise_unhandled (param $eff (ref eq)) (param (ref eq)) (result (ref eq)) - (local $effect_unhandled (ref $bytes)) - (local.set $effect_unhandled - (array.new_data $bytes $effect_unhandled - (i32.const 0) (i32.const 16))) (block $null (call $caml_raise_with_arg (br_on_null $null - (call $caml_named_value - (local.get $effect_unhandled))) + (call $caml_named_value (global.get $effect_unhandled))) (local.get $eff))) (call $caml_raise_constant (array.new_fixed $block 3 (ref.i31 (i32.const 248)) - (local.get $effect_unhandled) + (global.get $effect_unhandled) (call $caml_fresh_oo_id (ref.i31 (i32.const 0))))) (ref.i31 (i32.const 0))) @@ -218,7 +213,7 @@ (return_call_ref $cont_func (local.get $p) (local.get $k) (struct.get $cont $cont_func (local.get $k)))) - (data $already_resumed "Effect.Continuation_already_resumed") + (@string $already_resumed "Effect.Continuation_already_resumed") (func (export "%resume") (param $stack (ref eq)) (param $f (ref eq)) (param $v (ref eq)) (param $tail (ref eq)) @@ -229,9 +224,7 @@ (then (call $caml_raise_constant (ref.as_non_null - (call $caml_named_value - (array.new_data $bytes $already_resumed - (i32.const 0) (i32.const 35))))))) + (call $caml_named_value (global.get $already_resumed)))))) (return_call $capture_continuation (ref.func $do_resume) (struct.new $pair @@ -648,9 +641,7 @@ (return (local.get $k)))) (call $caml_raise_constant (ref.as_non_null - (call $caml_named_value - (array.new_data $bytes $already_resumed - (i32.const 0) (i32.const 35))))) + (call $caml_named_value (global.get $already_resumed)))) (ref.i31 (i32.const 0))) (func (export "caml_perform_effect") diff --git a/runtime/wasm/fail.wat b/runtime/wasm/fail.wat index 2661139d01..04a6092a0e 100644 --- a/runtime/wasm/fail.wat +++ b/runtime/wasm/fail.wat @@ -71,12 +71,10 @@ (global.get $INVALID_EXN)) (local.get 0))) - (data $index_out_of_bounds "index out of bounds") + (@string $index_out_of_bounds "index out of bounds") (func (export "caml_bound_error") - (return_call $caml_invalid_argument - (array.new_data $bytes $index_out_of_bounds - (i32.const 0) (i32.const 19)))) + (return_call $caml_invalid_argument (global.get $index_out_of_bounds))) (global $END_OF_FILE_EXN i32 (i32.const 4)) diff --git a/runtime/wasm/float.wat b/runtime/wasm/float.wat index 527581bbe0..12e33f88a9 100644 --- a/runtime/wasm/float.wat +++ b/runtime/wasm/float.wat @@ -194,7 +194,7 @@ (local.get $style)))))) (local.get $s)) - (data $format_error "format_float: bad format") + (@string $format_error "format_float: bad format") (func $parse_format (param $s (ref $bytes)) (result i32 i32 i32 i32) @@ -242,9 +242,7 @@ (i32.and (local.get $c) (i32.const 0xdf)) (i32.const 69))) ;; 'E' (br_if $return (i32.le_u (local.get $conversion) (i32.const 2)))) - (call $caml_invalid_argument - (array.new_data $bytes $format_error - (i32.const 0) (i32.const 22)))) + (call $caml_invalid_argument (global.get $format_error))) (tuple.make 4 (local.get $sign_style) (local.get $precision) @@ -339,7 +337,7 @@ (br_if $uppercase (i32.lt_u (local.get $i) (local.get $len)))))) (local.get $s)) - (data $float_of_string "float_of_string") + (@string $float_of_string "float_of_string") (func $caml_float_of_hex (param $s (ref $bytes)) (param $i i32) (result f64) (local $len i32) (local $c i32) (local $d i32) (local $m i64) @@ -480,8 +478,7 @@ (if (local.get $exp) (then (local.set $f (call $ldexp (local.get $f) (local.get $exp))))) (return (local.get $f))) - (call $caml_failwith - (array.new_data $bytes $float_of_string (i32.const 0) (i32.const 15))) + (call $caml_failwith (global.get $float_of_string)) (f64.const 0)) (func $on_whitespace (param $s (ref $bytes)) (param $i i32) (result i32) @@ -665,8 +662,7 @@ (call $parse_float (call $jsstring_of_bytes (local.get $s)))) (br_if $error (f64.ne (local.get $f) (local.get $f))) (return (struct.new $float (local.get $f)))) - (call $caml_failwith - (array.new_data $bytes $float_of_string (i32.const 0) (i32.const 15))) + (call $caml_failwith (global.get $float_of_string)) (return (ref.i31 (i32.const 0)))) (func (export "caml_nextafter_float") diff --git a/runtime/wasm/fs.wat b/runtime/wasm/fs.wat index abe6dab066..7012050c6d 100644 --- a/runtime/wasm/fs.wat +++ b/runtime/wasm/fs.wat @@ -44,6 +44,8 @@ (tag $javascript_exception (param externref))) (import "sys" "caml_handle_sys_error" (func $caml_handle_sys_error (param externref))) + (import "string" "caml_string_concat" + (func $caml_string_concat (param (ref eq) (ref eq)) (result (ref eq)))) (type $bytes (array (mut i8))) @@ -126,23 +128,12 @@ (return_call $file_exists (call $unwrap (call $caml_jsstring_of_string (local.get $name))))) - (data $no_such_file ": No such file or directory") - - (func $caml_raise_no_such_file (param $vname (ref eq)) - (local $name (ref $bytes)) (local $msg (ref $bytes)) - (local $len i32) - (local.set $name (ref.cast (ref $bytes) (local.get $vname))) - (local.set $len (array.len (local.get $name))) - (local.set $msg - (array.new $bytes (i32.const 0) - (i32.add (local.get $len) (i32.const 27)))) - (array.copy $bytes $bytes - (local.get $msg) (i32.const 0) - (local.get $name) (i32.const 0) - (local.get $len)) - (array.init_data $bytes $no_such_file - (local.get $msg) (local.get $len) (i32.const 0) (i32.const 27)) - (call $caml_raise_sys_error (local.get $msg))) + (@string $no_such_file ": No such file or directory") + + (func $caml_raise_no_such_file (param $name (ref eq)) + (call $caml_raise_sys_error + (call $caml_string_concat (local.get $name) + (global.get $no_such_file)))) (func (export "caml_read_file_content") (param (ref eq)) (result (ref eq)) diff --git a/runtime/wasm/int32.wat b/runtime/wasm/int32.wat index 089c601964..bb3126fb53 100644 --- a/runtime/wasm/int32.wat +++ b/runtime/wasm/int32.wat @@ -18,7 +18,7 @@ (module (import "ints" "parse_int" (func $parse_int - (param (ref eq)) (param i32) (param (ref $bytes)) (result i32))) + (param (ref eq)) (param i32) (param (ref eq)) (result i32))) (import "ints" "format_int" (func $format_int (param (ref eq)) (param i32) (param i32) (result (ref eq)))) @@ -56,7 +56,7 @@ (global $int32_ops (export "int32_ops") (ref $custom_operations) (struct.new $custom_operations - (array.new_fixed $bytes 2 (i32.const 95) (i32.const 105)) ;; "_i" + (@string "_i") (ref.func $int32_cmp) (ref.null $compare) (ref.func $int32_hash) @@ -117,12 +117,7 @@ (i32.rotl (i32.and (local.get $i) (i32.const 0xFF00FF00)) (i32.const 8)))) - (global $INT32_ERRMSG (ref $bytes) - (array.new_fixed $bytes 15 ;; "Int32.of_string" - (i32.const 73) (i32.const 110) (i32.const 116) (i32.const 51) - (i32.const 50) (i32.const 46) (i32.const 111) (i32.const 102) - (i32.const 95) (i32.const 115) (i32.const 116) (i32.const 114) - (i32.const 105) (i32.const 110) (i32.const 103))) + (@string $INT32_ERRMSG "Int32.of_string") (func (export "caml_int32_of_string") (param $v (ref eq)) (result (ref eq)) (return_call $caml_copy_int32 @@ -137,7 +132,7 @@ (global $nativeint_ops (export "nativeint_ops") (ref $custom_operations) (struct.new $custom_operations - (array.new_fixed $bytes 2 (i32.const 95) (i32.const 110)) ;; "_n" + (@string "_n") (ref.func $int32_cmp) (ref.null $compare) (ref.func $int32_hash) @@ -153,15 +148,12 @@ (struct.get $int32 1 (ref.cast (ref $int32) (local.get $v)))) (tuple.make 2 (i32.const 4) (i32.const 8))) - (data $integer_too_large "input_value: native integer value too large") + (@string $integer_too_large "input_value: native integer value too large") (func $nativeint_deserialize (param $s (ref eq)) (result (ref eq)) (result i32) (if (i32.ne (call $caml_deserialize_uint_1 (local.get $s)) (i32.const 1)) - (then - (call $caml_failwith - (array.new_data $bytes $integer_too_large - (i32.const 0) (i32.const 43))))) + (then (call $caml_failwith (global.get $integer_too_large)))) (tuple.make 2 (struct.new $int32 (global.get $nativeint_ops) (call $caml_deserialize_int_4 (local.get $s))) @@ -171,12 +163,7 @@ (param $i i32) (result (ref eq)) (struct.new $int32 (global.get $nativeint_ops) (local.get $i))) - (global $NATIVEINT_ERRMSG (ref $bytes) - (array.new_fixed $bytes 16 ;; "Nativeint.of_string" - (i32.const 78) (i32.const 97) (i32.const 116) (i32.const 105) - (i32.const 118) (i32.const 101) (i32.const 46) (i32.const 111) - (i32.const 102) (i32.const 95) (i32.const 115) (i32.const 116) - (i32.const 114) (i32.const 105) (i32.const 110) (i32.const 103))) + (@string $NATIVEINT_ERRMSG "Nativeint.of_string") (func (export "caml_nativeint_of_string") (param $v (ref eq)) (result (ref eq)) diff --git a/runtime/wasm/int64.wat b/runtime/wasm/int64.wat index a873f39ff6..e419dcb229 100644 --- a/runtime/wasm/int64.wat +++ b/runtime/wasm/int64.wat @@ -57,7 +57,7 @@ (global $int64_ops (export "int64_ops") (ref $custom_operations) (struct.new $custom_operations - (array.new_fixed $bytes 2 (i32.const 95) (i32.const 106)) ;; "_j" + (@string "_j") (ref.func $int64_cmp) (ref.null $compare) (ref.func $int64_hash) @@ -128,12 +128,7 @@ (ref.i31 (i32.sub (i64.gt_s (local.get $i1) (local.get $i2)) (i64.lt_s (local.get $i1) (local.get $i2))))) - (global $INT64_ERRMSG (ref $bytes) - (array.new_fixed $bytes 15 ;; "Int64.of_string" - (i32.const 73) (i32.const 110) (i32.const 116) (i32.const 54) - (i32.const 52) (i32.const 46) (i32.const 111) (i32.const 102) - (i32.const 95) (i32.const 115) (i32.const 116) (i32.const 114) - (i32.const 105) (i32.const 110) (i32.const 103))) + (@string $INT64_ERRMSG "Int64.of_string") ;; Parse a sequence of digits into an i64 as dicted by $base, ;; $signedness and $sign. The sequence is read in $s starting from $i. @@ -142,7 +137,7 @@ ;; package "integers". (func $caml_i64_of_digits (export "caml_i64_of_digits") (param $base i32) (param $signedness i32) (param $sign i32) - (param $s (ref $bytes)) (param $i i32) (param $errmsg (ref $bytes)) + (param $s (ref $bytes)) (param $i i32) (param $errmsg (ref eq)) (result i64) (local $len i32) (local $d i32) (local $c i32) (local $res i64) (local $threshold i64) @@ -209,8 +204,6 @@ (local.get $i) (global.get $INT64_ERRMSG)))) - (data $caml_int64_create_lo_mi_hi "caml_int64_create_lo_mi_hi") - (func $format_int64_default (param $d i64) (result (ref eq)) (local $s (ref $bytes)) (local $negative i32) (local $i i32) (local $n i64) diff --git a/runtime/wasm/ints.wat b/runtime/wasm/ints.wat index 4ec4e3b0f6..1b256e0a9a 100644 --- a/runtime/wasm/ints.wat +++ b/runtime/wasm/ints.wat @@ -94,7 +94,7 @@ (return (i32.const -1))) (func $parse_int (export "parse_int") - (param $v (ref eq)) (param $nbits i32) (param $errmsg (ref $bytes)) + (param $v (ref eq)) (param $nbits i32) (param $errmsg (ref eq)) (result i32) (local $s (ref $bytes)) (local $i i32) (local $len i32) (local $d i32) (local $c i32) @@ -157,12 +157,7 @@ (then (local.set $res (i32.sub (i32.const 0) (local.get $res))))) (local.get $res)) - (global $INT_ERRMSG (ref $bytes) - (array.new_fixed $bytes 13 ;; "int.of_string" - (i32.const 105) (i32.const 110) (i32.const 116) (i32.const 95) - (i32.const 111) (i32.const 102) (i32.const 95) (i32.const 115) - (i32.const 116) (i32.const 114) (i32.const 105) (i32.const 110) - (i32.const 103))) + (@string $INT_ERRMSG "int_of_string") (func (export "caml_int_of_string") (param $v (ref eq)) (result (ref eq)) @@ -222,7 +217,7 @@ (i32.const 45)))) ;; '-' (local.get $s)) - (data $format_error "format_int: bad format") + (@string $format_error "format_int: bad format") (func $parse_int_format (export "parse_int_format") (param $s (ref $bytes)) (result i32 i32 i32 i32 i32) @@ -283,9 +278,7 @@ (else (br $bad_format))))))))))) (br $return)) - (call $caml_invalid_argument - (array.new_data $bytes $format_error - (i32.const 0) (i32.const 22)))) + (call $caml_invalid_argument (global.get $format_error))) (tuple.make 5 (local.get $sign_style) (local.get $alternate) diff --git a/runtime/wasm/io.wat b/runtime/wasm/io.wat index 3a4b2086e1..44fd1e4dc6 100644 --- a/runtime/wasm/io.wat +++ b/runtime/wasm/io.wat @@ -129,9 +129,7 @@ (global $channel_ops (ref $custom_operations) (struct.new $custom_operations - (array.new_fixed $bytes 5 ;; "_chan" - (i32.const 95) (i32.const 99) (i32.const 104) (i32.const 97) - (i32.const 110)) + (@string "_chan") (ref.func $custom_compare_id) (ref.null $compare) (ref.func $custom_hash_id) @@ -180,7 +178,7 @@ (func $release_fd_offset (export "release_fd_offset") (param $fd i32) (call $map_delete (call $get_fd_offsets) (local.get $fd))) - (data $bad_file_descriptor "Bad file descriptor") + (@string $bad_file_descriptor "Bad file descriptor") (func $get_fd_offset_unchecked (export "get_fd_offset_unchecked") (param $fd i32) (result (ref null $fd_offset)) @@ -190,10 +188,7 @@ (local $res (ref null $fd_offset)) (local.set $res (call $get_fd_offset_unchecked (local.get $fd))) (if (ref.is_null (local.get $res)) - (then - (call $caml_raise_sys_error - (array.new_data $bytes $bad_file_descriptor - (i32.const 0) (i32.const 19))))) + (then (call $caml_raise_sys_error (global.get $bad_file_descriptor)))) (ref.as_non_null (local.get $res))) (global $IO_BUFFER_SIZE (export "IO_BUFFER_SIZE") i32 (i32.const 65536)) diff --git a/runtime/wasm/jslib.wat b/runtime/wasm/jslib.wat index befb48306b..689853a2b3 100644 --- a/runtime/wasm/jslib.wat +++ b/runtime/wasm/jslib.wat @@ -627,12 +627,9 @@ (br $loop)))) (local.get $l)) - (global $jsError (ref $bytes) - (array.new_fixed $bytes 7 ;; 'jsError' - (i32.const 106) (i32.const 115) (i32.const 69) (i32.const 114) - (i32.const 114) (i32.const 111) (i32.const 114))) + (@string $jsError "jsError") - (data $toString "toString") + (@string $toString "toString") (func (export "caml_wrap_exception") (param externref) (result (ref eq)) (local $exn anyref) @@ -651,9 +648,7 @@ (call $meth_call (local.get $exn) (call $unwrap - (call $caml_jsstring_of_bytes - (array.new_data $bytes $toString - (i32.const 0) (i32.const 8)))) + (call $caml_jsstring_of_bytes (global.get $toString))) (any.convert_extern (call $new_array (i32.const 0)))))))) (func (export "caml_js_error_option_of_exception") diff --git a/runtime/wasm/jslib_js_of_ocaml.wat b/runtime/wasm/jslib_js_of_ocaml.wat index ee6a58ece1..182453139c 100644 --- a/runtime/wasm/jslib_js_of_ocaml.wat +++ b/runtime/wasm/jslib_js_of_ocaml.wat @@ -42,19 +42,18 @@ (return_call $wrap (call $caml_js_html_entities (call $unwrap (local.get 0))))) - (data $console "console") + (@string $console "console") (func (export "caml_js_get_console") (param (ref eq)) (result (ref eq)) (return_call $caml_js_get (call $caml_js_global (ref.i31 (i32.const 0))) - (array.new_data $bytes $console (i32.const 0) (i32.const 7)))) + (global.get $console))) - (data $XMLHttpRequest "XMLHttpRequest") + (@string $XMLHttpRequest "XMLHttpRequest") (func (export "caml_xmlhttprequest_create") (param (ref eq)) (result (ref eq)) (return_call $caml_js_new (call $caml_js_get (call $caml_js_global (ref.i31 (i32.const 0))) - (array.new_data $bytes $XMLHttpRequest - (i32.const 0) (i32.const 14))) + (global.get $XMLHttpRequest)) (array.new_fixed $block 1 (ref.i31 (i32.const 0))))) ) diff --git a/runtime/wasm/lexing.wat b/runtime/wasm/lexing.wat index 5ff59fdd0b..5016d8a379 100644 --- a/runtime/wasm/lexing.wat +++ b/runtime/wasm/lexing.wat @@ -52,7 +52,7 @@ (global $lex_check_code i32 (i32.const 10)) (global $lex_code i32 (i32.const 11)) - (data $lexing_empty_token "lexing: empty token") + (@string $lexing_empty_token "lexing: empty token") (func (export "caml_lex_engine") (param $vtbl (ref eq)) (param $start_state (ref eq)) @@ -172,10 +172,7 @@ (array.get $block (local.get $lexbuf) (global.get $lex_last_action))) (if (ref.eq (local.get $action) (ref.i31 (i32.const -1))) - (then - (call $caml_failwith - (array.new_data $bytes $lexing_empty_token - (i32.const 0) (i32.const 19))))) + (then (call $caml_failwith (global.get $lexing_empty_token)))) (return (local.get $action)))) (if (i32.eq (local.get $c) (i32.const 256)) (then @@ -363,10 +360,7 @@ (array.get $block (local.get $lexbuf) (global.get $lex_last_action))) (if (ref.eq (local.get $action) (ref.i31 (i32.const -1))) - (then - (call $caml_failwith - (array.new_data $bytes $lexing_empty_token - (i32.const 0) (i32.const 19))))) + (then (call $caml_failwith (global.get $lexing_empty_token)))) (return (local.get $action)))) (local.set $base_code (call $get (local.get $lex_base_code) (local.get $pstate))) diff --git a/runtime/wasm/marshal.wat b/runtime/wasm/marshal.wat index 5db0a1a788..3840b22434 100644 --- a/runtime/wasm/marshal.wat +++ b/runtime/wasm/marshal.wat @@ -50,14 +50,7 @@ (func $caml_find_custom_operations (param (ref $bytes)) (result (ref null $custom_operations)))) - (global $input_val_from_string (ref $bytes) - (array.new_fixed $bytes 21 - (i32.const 105) (i32.const 110) (i32.const 112) (i32.const 117) - (i32.const 116) (i32.const 95) (i32.const 118) (i32.const 97) - (i32.const 108) (i32.const 95) (i32.const 102) (i32.const 114) - (i32.const 111) (i32.const 109) (i32.const 95) (i32.const 115) - (i32.const 116) (i32.const 114) (i32.const 105) (i32.const 110) - (i32.const 103))) + (@string $input_val_from_string "input_value_from_string") (export "caml_input_value_from_string" (func $caml_input_value_from_bytes)) (func $caml_input_value_from_bytes (export "caml_input_value_from_bytes") @@ -81,13 +74,9 @@ (call $bad_length (global.get $input_val_from_string)))) (return_call $intern_rec (local.get $s) (local.get $h))) - (data $truncated_obj "input_value: truncated object") + (@string $truncated_obj "input_value: truncated object") - (global $input_value (ref $bytes) - (array.new_fixed $bytes 11 - (i32.const 105) (i32.const 110) (i32.const 112) (i32.const 117) - (i32.const 116) (i32.const 95) (i32.const 118) (i32.const 97) - (i32.const 108) (i32.const 117) (i32.const 101))) + (@string $input_value "input_value") (func (export "caml_input_value") (param $ch (ref eq)) (result (ref eq)) ;; ZZZ check binary channel? @@ -101,10 +90,7 @@ (if (i32.eqz (local.get $r)) (then (call $caml_raise_end_of_file))) (if (i32.lt_u (local.get $r) (i32.const 20)) - (then - (call $caml_failwith - (array.new_data $bytes $truncated_obj - (i32.const 0) (i32.const 29))))) + (then (call $caml_failwith (global.get $truncated_obj)))) (local.set $s (call $get_intern_state (local.get $header) (i32.const 0))) (local.set $h @@ -115,10 +101,7 @@ (call $caml_really_getblock (local.get $ch) (local.get $buf) (i32.const 0) (local.get $len)) (local.get $len)) - (then - (call $caml_failwith - (array.new_data $bytes $truncated_obj - (i32.const 0) (i32.const 29))))) + (then (call $caml_failwith (global.get $truncated_obj)))) (local.set $s (call $get_intern_state (local.get $buf) (i32.const 0))) (return_call $intern_rec (local.get $s) (local.get $h))) @@ -393,13 +376,13 @@ (field $pos (mut i32)) (field $next (ref null $stack_item)))) - (data $integer_too_large "input_value: integer too large") - (data $code_pointer "input_value: code pointer") - (data $ill_formed "input_value: ill-formed message") + (@string $integer_too_large "input_value: integer too large") + (@string $code_pointer "input_value: code pointer") + (@string $ill_formed "input_value: ill-formed message") - (data $unknown_custom "input_value: unknown custom block identifier") - (data $expected_size "input_value: expected a fixed-size custom block") - (data $incorrect_size + (@string $unknown_custom "input_value: unknown custom block identifier") + (@string $expected_size "input_value: expected a fixed-size custom block") + (@string $incorrect_size "input_value: incorrect length of serialized custom block") (func $intern_custom @@ -436,17 +419,10 @@ (i32.ne (tuple.extract 2 1 (local.get $r)) (local.get $expected_size)) (i32.ne (local.get $code) (global.get $CODE_CUSTOM))) - (then - (call $caml_failwith - (array.new_data $bytes $incorrect_size - (i32.const 0) (i32.const 56))))) + (then (call $caml_failwith (global.get $incorrect_size)))) (return (tuple.extract 2 0 (local.get $r)))) - (call $caml_failwith - (array.new_data $bytes $expected_size - (i32.const 0) (i32.const 47)))) - (call $caml_failwith - (array.new_data $bytes $unknown_custom - (i32.const 0) (i32.const 44))) + (call $caml_failwith (global.get $expected_size))) + (call $caml_failwith (global.get $unknown_custom)) (ref.i31 (i32.const 0))) (func $intern_rec @@ -542,8 +518,7 @@ (local.get $code))) ;; default (call $caml_failwith - (array.new_data $bytes $ill_formed - (i32.const 0) (i32.const 31))) + (global.get $ill_formed)) (br $done)) ;; CUSTOM (local.set $v @@ -554,8 +529,7 @@ (br $done)) ;; CODEPOINTER (call $caml_failwith - (array.new_data $bytes $code_pointer - (i32.const 0) (i32.const 25))) + (global.get $code_pointer)) (br $done)) ;; DOUBLE_ARRAY32 (local.set $len @@ -599,8 +573,7 @@ (br $read_shared)) ;; INT64 (call $caml_failwith - (array.new_data $bytes $integer_too_large - (i32.const 0) (i32.const 30))) + (global.get $integer_too_large)) (br $done)) ;; INT32 (local.set $v (ref.i31 (call $read32 (local.get $s)))) @@ -672,26 +645,23 @@ (br $loop))) (array.get $block (local.get $res) (i32.const 0))) - (data $too_large ": object too large to be read back on a 32-bit platform") + (@string $too_large ": object too large to be read back on a 32-bit platform") - (func $too_large (param $prim (ref $bytes)) + (func $too_large (param $prim (ref eq)) (call $caml_failwith - (call $caml_string_concat (local.get $prim) - (array.new_data $bytes $too_large (i32.const 0) (i32.const 55))))) + (call $caml_string_concat (local.get $prim) (global.get $too_large)))) - (data $bad_object ": bad object") + (@string $bad_object ": bad object") - (func $bad_object (param $prim (ref $bytes)) + (func $bad_object (param $prim (ref eq)) (call $caml_failwith - (call $caml_string_concat (local.get $prim) - (array.new_data $bytes $bad_object (i32.const 0) (i32.const 12))))) + (call $caml_string_concat (local.get $prim) (global.get $bad_object)))) - (data $bad_length ": bad length") + (@string $bad_length ": bad length") - (func $bad_length (param $prim (ref $bytes)) + (func $bad_length (param $prim (ref eq)) (call $caml_failwith - (call $caml_string_concat (local.get $prim) - (array.new_data $bytes $bad_length (i32.const 0) (i32.const 12))))) + (call $caml_string_concat (local.get $prim) (global.get $bad_length)))) (type $marshal_header (struct @@ -699,7 +669,7 @@ (field $num_objects i32))) (func $parse_header - (param $s (ref $intern_state)) (param $prim (ref $bytes)) + (param $s (ref $intern_state)) (param $prim (ref eq)) (result (ref $marshal_header)) (local $magic i32) (local $data_len i32) (local $num_objects i32) (local $whsize i32) @@ -718,7 +688,7 @@ (local.get $data_len) (local.get $num_objects))) - (data $marshal_data_size "Marshal.data_size") + (@string $marshal_data_size "Marshal.data_size") (@if (>= ocaml_version (5 1 0)) (@then @@ -740,15 +710,9 @@ (i31.get_u (ref.cast (ref i31) (local.get $ofs))))) (local.set $magic (call $read32 (local.get $s))) (if (i32.eq (local.get $magic) (global.get $Intext_magic_number_big)) - (then - (call $too_large - (array.new_data $bytes $marshal_data_size - (i32.const 0) (i32.const 17))))) + (then (call $too_large (global.get $marshal_data_size)))) (if (i32.ne (local.get $magic) (global.get $Intext_magic_number_small)) - (then - (call $bad_object - (array.new_data $bytes $marshal_data_size - (i32.const 0) (i32.const 17))))) + (then (call $bad_object (global.get $marshal_data_size)))) (ref.i31 (i32.add (i32.sub (i32.const 20) @@ -807,7 +771,7 @@ (local.get $output) (local.get $output))) - (data $buffer_overflow "Marshal.to_buffer: buffer overflow") + (@string $buffer_overflow "Marshal.to_buffer: buffer overflow") (global $SIZE_EXTERN_OUTPUT_BLOCK i32 (i32.const 8100)) @@ -824,10 +788,7 @@ (i32.add (local.get $pos) (local.get $required))) (return (local.get $pos)))) (if (struct.get $extern_state $user_provided_output (local.get $s)) - (then - (call $caml_failwith - (array.new_data $bytes $buffer_overflow - (i32.const 0) (i32.const 34))))) + (then (call $caml_failwith (global.get $buffer_overflow)))) (local.set $last (struct.get $extern_state $output_last (local.get $s))) (struct.set $output_block $end (local.get $last) (struct.get $extern_state $pos (local.get $s))) @@ -1081,7 +1042,7 @@ (global.get $CODE_DOUBLE_ARRAY32_LITTLE) (local.get $nfloats)))) (call $writefloats (local.get $s) (local.get $v))) - (data $incorrect_sizes "output_value: incorrect fixed sizes specified by ") + (@string $incorrect_sizes "output_value: incorrect fixed sizes specified by ") (func $extern_custom (param $s (ref $extern_state)) (param $v (ref $custom)) (result i32 i32) @@ -1117,8 +1078,7 @@ (then (call $caml_failwith (call $caml_string_concat - (array.new_data $bytes $incorrect_sizes - (i32.const 0) (i32.const 49)) + (global.get $incorrect_sizes) (struct.get $custom_operations $id (local.get $ops)))))) (return (local.get $r))) @@ -1138,15 +1098,14 @@ (call $store32 (local.get $buf) (i32.add (local.get $pos) (i32.const 8)) (tuple.extract 2 1 (local.get $r))) (return (local.get $r))) - (call $caml_invalid_argument - (array.new_data $bytes $cust_value (i32.const 0) (i32.const 37))) + (call $caml_invalid_argument (global.get $cust_value)) (return (tuple.make 2 (i32.const 0) (i32.const 0)))) - (data $func_value "output_value: functional value") - (data $cont_value "output_value: continuation value") - (data $js_value "output_value: abstract value (JavaScript value)") - (data $abstract_value "output_value: abstract value") - (data $cust_value "output_value: abstract value (Custom)") + (@string $func_value "output_value: functional value") + (@string $cont_value "output_value: continuation value") + (@string $js_value "output_value: abstract value (JavaScript value)") + (@string $abstract_value "output_value: abstract value") + (@string $cust_value "output_value: abstract value (Custom)") (func $extern_rec (param $s (ref $extern_state)) (param $v (ref eq)) (local $sp (ref null $stack_item)) @@ -1254,24 +1213,12 @@ (i32.const 3))) (br $next_item))) (if (call $caml_is_closure (local.get $v)) - (then - (call $caml_invalid_argument - (array.new_data $bytes $func_value - (i32.const 0) (i32.const 30))))) + (then (call $caml_invalid_argument (global.get $func_value)))) (if (call $caml_is_continuation (local.get $v)) - (then - (call $caml_invalid_argument - (array.new_data $bytes $cont_value - (i32.const 0) (i32.const 32))))) + (then (call $caml_invalid_argument (global.get $cont_value)))) (if (ref.test (ref $js) (local.get $v)) - (then - (call $caml_invalid_argument - (array.new_data $bytes $js_value - (i32.const 0) (i32.const 47))))) - (call $caml_invalid_argument - (array.new_data $bytes $abstract_value - (i32.const 0) (i32.const 28))) - ) + (then (call $caml_invalid_argument (global.get $js_value)))) + (call $caml_invalid_argument (global.get $abstract_value))) ;; next_item (block $done (local.set $item (br_on_null $done (local.get $sp))) diff --git a/runtime/wasm/obj.wat b/runtime/wasm/obj.wat index e735b4f452..8e44ecd376 100644 --- a/runtime/wasm/obj.wat +++ b/runtime/wasm/obj.wat @@ -341,21 +341,18 @@ (local.get $v)) (ref.i31 (i32.const 0))) - (data $not_implemented "Obj.add_offset is not supported") + (@string $not_implemented "Obj.add_offset is not supported") (func (export "caml_obj_add_offset") (param (ref eq)) (param (ref eq)) (result (ref eq)) - (call $caml_failwith - (array.new_data $bytes $not_implemented (i32.const 0) (i32.const 31))) + (call $caml_failwith (global.get $not_implemented)) (ref.i31 (i32.const 0))) - (data $truncate_not_implemented "Obj.truncate is not supported") + (@string $truncate_not_implemented "Obj.truncate is not supported") (func (export "caml_obj_truncate") (param (ref eq)) (param (ref eq)) (result (ref eq)) - (call $caml_failwith - (array.new_data $bytes $truncate_not_implemented - (i32.const 0) (i32.const 29))) + (call $caml_failwith (global.get $truncate_not_implemented)) (ref.i31 (i32.const 0))) (global $method_cache (mut (ref $int_array)) diff --git a/runtime/wasm/parsing.wat b/runtime/wasm/parsing.wat index 8567734727..686f411145 100644 --- a/runtime/wasm/parsing.wat +++ b/runtime/wasm/parsing.wat @@ -111,7 +111,8 @@ (br $loop)))) (i32.sub (local.get $i) (local.get $p))) - (data $unknown_token "") + (@string $unknown_token "") + (func $token_name (param $vnames (ref eq)) (param $number i32) (result (ref eq)) (local $names (ref $bytes)) (local $i i32) (local $len i32) @@ -119,10 +120,7 @@ (local.set $names (ref.cast (ref $bytes) (local.get $vnames))) (loop $loop (if (i32.eqz (array.get_u $bytes (local.get $names) (local.get $i))) - (then - (return - (array.new_data $bytes $unknown_token - (i32.const 0) (i32.const 15))))) + (then (return (global.get $unknown_token)))) (if (i32.ne (local.get $number) (i32.const 0)) (then (local.set $i @@ -149,18 +147,16 @@ (func $output_nl (drop (call $caml_ml_output (global.get $caml_stderr) - (array.new_fixed $bytes 1 (i32.const 10)) + (@string "\n") (ref.i31 (i32.const 0)) (ref.i31 (i32.const 1)))) (drop (call $caml_ml_flush (global.get $caml_stderr)))) (func $output_int (param i32) (call $output - (call $caml_format_int - (array.new_fixed $bytes 2 (i32.const 37) (i32.const 100)) - (ref.i31 (local.get 0))))) + (call $caml_format_int (@string "%d") (ref.i31 (local.get 0))))) - (data $State "State ") - (data $read_token ": read token ") + (@string $State "State ") + (@string $read_token ": read token ") (func $print_token (param $tables (ref $block)) (param $state i32) (param $tok (ref eq)) @@ -168,11 +164,9 @@ (local $v (ref eq)) (if (ref.test (ref i31) (local.get $tok)) (then - (call $output - (array.new_data $bytes $State (i32.const 0) (i32.const 6))) + (call $output (global.get $State)) (call $output_int (local.get $state)) - (call $output - (array.new_data $bytes $read_token (i32.const 0) (i32.const 13))) + (call $output (global.get $read_token)) (call $output (call $token_name (array.get $block (local.get $tables) @@ -180,11 +174,9 @@ (i31.get_u (ref.cast (ref i31) (local.get $tok))))) (call $output_nl)) (else - (call $output - (array.new_data $bytes $State (i32.const 0) (i32.const 6))) + (call $output (global.get $State)) (call $output_int (local.get $state)) - (call $output - (array.new_data $bytes $read_token (i32.const 0) (i32.const 13))) + (call $output (global.get $read_token)) (local.set $b (ref.cast (ref $block) (local.get $tok))) (call $output (call $token_name @@ -193,7 +185,7 @@ (i31.get_u (ref.cast (ref i31) (array.get $block (local.get $b) (i32.const 0)))))) - (call $output (array.new_fixed $bytes 1 (i32.const 40))) ;; "(" + (call $output (@string "(")) (local.set $v (array.get $block (local.get $b) (i32.const 1))) (if (ref.test (ref i31) (local.get $v)) (then @@ -204,22 +196,18 @@ (else (if (ref.test (ref $float) (local.get $v)) (then (call $output - (call $caml_format_float - (array.new_fixed $bytes 2 - (i32.const 37) (i32.const 103)) - (local.get $v)))) + (call $caml_format_float (@string "%g") (local.get $v)))) (else - (call $output - (array.new_fixed $bytes 1 (i32.const 95))))))))) ;; '_' - (call $output (array.new_fixed $bytes 1 (i32.const 41))) ;; ")" + (call $output (@string "_")))))))) + (call $output (@string ")")) (call $output_nl)))) - (data $recovering_in_state "Recovering in state ") - (data $discarding_state "Discarding state ") - (data $no_more_states_to_discard "No more states to discard") - (data $discarding_last_token_read "Discarding last token read") - (data $shift_to_state ": shift to state ") - (data $reduce_by_rule ": reduce by rule ") + (@string $recovering_in_state "Recovering in state ") + (@string $discarding_state "Discarding state ") + (@string $no_more_states_to_discard "No more states to discard") + (@string $discarding_last_token_read "Discarding last token read") + (@string $shift_to_state ": shift to state ") + (@string $reduce_by_rule ": reduce by rule ") (func (export "caml_parse_engine") (param $vtables (ref eq)) (param $venv (ref eq)) (param $vcmd (ref eq)) @@ -456,10 +444,8 @@ (if (global.get $caml_parser_trace) (then (call $output - (array.new_data $bytes - $recovering_in_state - (i32.const 0) - (i32.const 20))) + (global.get + $recovering_in_state)) (call $output_int (local.get $state1)) (call $output_nl))) @@ -469,8 +455,7 @@ (if (global.get $caml_parser_trace) (then (call $output - (array.new_data $bytes $discarding_state - (i32.const 0) (i32.const 17))) + (global.get $discarding_state)) (call $output_int (local.get $state1)) (call $output_nl))) (if (i32.le_s (local.get $sp) @@ -482,9 +467,7 @@ (if (global.get $caml_parser_trace) (then (call $output - (array.new_data $bytes - $no_more_states_to_discard - (i32.const 0) (i32.const 25))) + (global.get $no_more_states_to_discard)) (call $output_nl))) (return (ref.i31 (global.get $RAISE_PARSE_ERROR))))) (local.set $sp (i32.sub (local.get $sp) (i32.const 1))) @@ -499,8 +482,7 @@ (if (global.get $caml_parser_trace) (then (call $output - (array.new_data $bytes $discarding_last_token_read - (i32.const 0) (i32.const 26))) + (global.get $discarding_last_token_read)) (call $output_nl))) (array.set $block (local.get $env) (global.get $env_curr_char) @@ -518,13 +500,9 @@ ;; shift_recover: (if (global.get $caml_parser_trace) (then - (call $output - (array.new_data $bytes $State - (i32.const 0) (i32.const 6))) + (call $output (global.get $State)) (call $output_int (local.get $state)) - (call $output - (array.new_data $bytes $shift_to_state - (i32.const 0) (i32.const 17))) + (call $output (global.get $shift_to_state)) (call $output_int (call $get (local.get $tbl_table) (local.get $n2))) (call $output_nl))) @@ -568,12 +546,9 @@ ;; reduce: (if (global.get $caml_parser_trace) (then - (call $output - (array.new_data $bytes $State (i32.const 0) (i32.const 6))) + (call $output (global.get $State)) (call $output_int (local.get $state)) - (call $output - (array.new_data $bytes $reduce_by_rule - (i32.const 0) (i32.const 17))) + (call $output (global.get $reduce_by_rule)) (call $output_int (local.get $n)) (call $output_nl))) (local.set $m (call $get (local.get $tbl_len) (local.get $n))) diff --git a/runtime/wasm/printexc.wat b/runtime/wasm/printexc.wat index 0f93596955..b30bc45b6a 100644 --- a/runtime/wasm/printexc.wat +++ b/runtime/wasm/printexc.wat @@ -117,8 +117,7 @@ (then (call $add_string (local.get $buf) (call $caml_format_int - (array.new_fixed $bytes 2 - (i32.const 37) (i32.const 100)) ;; %d + (@string "%d") (ref.cast (ref i31) (local.get $v))))) (else (if (ref.test (ref $bytes) (local.get $v)) (then diff --git a/runtime/wasm/stdlib.wat b/runtime/wasm/stdlib.wat index 3fbaae82a0..62ff000f26 100644 --- a/runtime/wasm/stdlib.wat +++ b/runtime/wasm/stdlib.wat @@ -181,9 +181,9 @@ (type $func (func (result (ref eq)))) - (data $fatal_error "Fatal error: exception ") - (data $handle_uncaught_exception "Printexc.handle_uncaught_exception") - (data $do_at_exit "Pervasives.do_at_exit") + (@string $fatal_error "Fatal error: exception ") + (@string $handle_uncaught_exception "Printexc.handle_uncaught_exception") + (@string $do_at_exit "Pervasives.do_at_exit") (global $uncaught_exception (mut externref) (ref.null extern)) @@ -211,9 +211,7 @@ (call $caml_callback_2 (br_on_null $not_registered (call $caml_named_value - (array.new_data $bytes - $handle_uncaught_exception - (i32.const 0) (i32.const 34)))) + (global.get $handle_uncaught_exception))) (local.get $exn) (ref.i31 (i32.const 0))))) (catch $ocaml_exit @@ -223,19 +221,15 @@ (drop (call $caml_callback_1 (br_on_null $null - (call $caml_named_value - (array.new_data $bytes $do_at_exit - (i32.const 0) (i32.const 21)))) + (call $caml_named_value (global.get $do_at_exit))) (ref.i31 (i32.const 0))))) (call $write (i32.const 2) (call $unwrap (call $caml_jsstring_of_string (call $caml_string_concat - (array.new_data $bytes $fatal_error - (i32.const 0) (i32.const 23)) + (global.get $fatal_error) (call $caml_string_concat (call $caml_format_exception (local.get $exn)) - (array.new_fixed $bytes 1 - (i32.const 10)))))))) ;; `\n` + (@string "\n"))))))) (call $exit (i32.const 2))))) ) diff --git a/runtime/wasm/str.wat b/runtime/wasm/str.wat index 5890d6b2e0..47b92bd5da 100644 --- a/runtime/wasm/str.wat +++ b/runtime/wasm/str.wat @@ -507,7 +507,7 @@ ;; reject (ref.i31 (i32.const 0))) - (data $search_forward "Str.search_forward") + (@string $search_forward "Str.search_forward") (func (export "re_search_forward") (param $re (ref eq)) (param $vs (ref eq)) (param $vpos (ref eq)) @@ -520,10 +520,7 @@ (local.set $pos (i31.get_s (ref.cast (ref i31) (local.get $vpos)))) (local.set $len (array.len (local.get $s))) (if (i32.gt_u (local.get $pos) (local.get $len)) - (then - (call $caml_invalid_argument - (array.new_data $bytes $search_forward - (i32.const 0) (i32.const 18))))) + (then (call $caml_invalid_argument (global.get $search_forward)))) (loop $loop (local.set $res (call $re_match @@ -535,7 +532,7 @@ (br_if $loop (i32.le_u (local.get $pos) (local.get $len)))) (array.new_fixed $block 1 (ref.i31 (i32.const 0)))) - (data $search_backward "Str.search_backward") + (@string $search_backward "Str.search_backward") (func (export "re_search_backward") (param $re (ref eq)) (param $vs (ref eq)) (param $vpos (ref eq)) @@ -549,9 +546,7 @@ (local.set $len (array.len (local.get $s))) (if (i32.gt_u (local.get $pos) (local.get $len)) (then - (call $caml_invalid_argument - (array.new_data $bytes $search_backward - (i32.const 0) (i32.const 19))))) + (call $caml_invalid_argument (global.get $search_backward)))) (loop $loop (local.set $res (call $re_match @@ -563,7 +558,7 @@ (br_if $loop (i32.ge_s (local.get $pos) (i32.const 0)))) (array.new_fixed $block 1 (ref.i31 (i32.const 0)))) - (data $string_match "Str.string_match") + (@string $string_match "Str.string_match") (func (export "re_string_match") (param $re (ref eq)) (param $vs (ref eq)) (param $vpos (ref eq)) @@ -576,10 +571,7 @@ (local.set $pos (i31.get_s (ref.cast (ref i31) (local.get $vpos)))) (local.set $len (array.len (local.get $s))) (if (i32.gt_u (local.get $pos) (local.get $len)) - (then - (call $caml_invalid_argument - (array.new_data $bytes $string_match - (i32.const 0) (i32.const 16))))) + (then (call $caml_invalid_argument (global.get $string_match)))) (local.set $res (call $re_match (local.get $re) (local.get $s) (local.get $pos) (i32.const 0))) @@ -588,7 +580,7 @@ (return (local.get $res)))) (array.new_fixed $block 1 (ref.i31 (i32.const 0)))) - (data $string_partial_match "Str.string_partial_match") + (@string $string_partial_match "Str.string_partial_match") (func (export "re_partial_match") (param $re (ref eq)) (param $vs (ref eq)) (param $vpos (ref eq)) @@ -602,9 +594,7 @@ (local.set $len (array.len (local.get $s))) (if (i32.gt_u (local.get $pos) (local.get $len)) (then - (call $caml_invalid_argument - (array.new_data $bytes $string_partial_match - (i32.const 0) (i32.const 24))))) + (call $caml_invalid_argument (global.get $string_partial_match)))) (local.set $res (call $re_match (local.get $re) (local.get $s) (local.get $pos) (i32.const 1))) @@ -613,8 +603,8 @@ (return (local.get $res)))) (array.new_fixed $block 1 (ref.i31 (i32.const 0)))) - (data $illegal_backslash "Str.replace: illegal backslash sequence") - (data $unmatched_group "Str.replace: reference to unmatched group") + (@string $illegal_backslash "Str.replace: illegal backslash sequence") + (@string $unmatched_group "Str.replace: reference to unmatched group") (func (export "re_replacement_text") (param $vrepl (ref eq)) (param $vgroups (ref eq)) (param $vorig (ref eq)) @@ -640,10 +630,7 @@ (local.set $len (i32.add (local.get $len) (i32.const 1))) (br $loop))) (if (i32.eq (local.get $i) (local.get $l)) - (then - (call $caml_failwith - (array.new_data $bytes $illegal_backslash - (i32.const 0) (i32.const 39))))) + (then (call $caml_failwith (global.get $illegal_backslash)))) (local.set $c (array.get_u $bytes (local.get $repl) (local.get $i))) (local.set $i (i32.add (local.get $i) (i32.const 1))) @@ -659,10 +646,7 @@ (local.set $c (i32.shl (local.get $c) (i32.const 1))) (if (i32.gt_u (i32.add (local.get $c) (i32.const 1)) (array.len (local.get $groups))) - (then - (call $caml_failwith - (array.new_data $bytes $unmatched_group - (i32.const 0) (i32.const 41))))) + (then (call $caml_failwith (global.get $unmatched_group)))) (local.set $start (i31.get_s (ref.cast (ref i31) @@ -674,10 +658,7 @@ (array.get $block (local.get $groups) (i32.add (local.get $c) (i32.const 2)))))) (if (i32.eq (local.get $start) (i32.const -1)) - (then - (call $caml_failwith - (array.new_data $bytes $unmatched_group - (i32.const 0) (i32.const 41))))) + (then (call $caml_failwith (global.get $unmatched_group)))) (local.set $len (i32.add (local.get $len) (i32.sub (local.get $end) (local.get $start)))) @@ -718,10 +699,7 @@ (local.set $c (i32.shl (local.get $c) (i32.const 1))) (if (i32.gt_u (i32.add (local.get $c) (i32.const 1)) (array.len (local.get $groups))) - (then - (call $caml_failwith - (array.new_data $bytes $unmatched_group - (i32.const 0) (i32.const 41))))) + (then (call $caml_failwith (global.get $unmatched_group)))) (local.set $start (i31.get_s (ref.cast (ref i31) diff --git a/runtime/wasm/string.wat b/runtime/wasm/string.wat index 10b8f89cb3..66183061b4 100644 --- a/runtime/wasm/string.wat +++ b/runtime/wasm/string.wat @@ -119,17 +119,14 @@ (param $v (ref eq)) (result (ref eq)) (local.get $v)) - (data $Bytes_create "Bytes.create") + (@string $Bytes_create "Bytes.create") (func (export "caml_create_bytes") (param $len (ref eq)) (result (ref eq)) (local $l i32) (local.set $l (i31.get_s (ref.cast (ref i31) (local.get $len)))) (if (i32.lt_s (local.get $l) (i32.const 0)) - (then - (call $caml_invalid_argument - (array.new_data $bytes $Bytes_create - (i32.const 0) (i32.const 12))))) + (then (call $caml_invalid_argument (global.get $Bytes_create)))) (array.new $bytes (i32.const 0) (local.get $l))) (export "caml_blit_bytes" (func $caml_blit_string)) diff --git a/runtime/wasm/sync.wat b/runtime/wasm/sync.wat index 7d18263301..1b498d4a93 100644 --- a/runtime/wasm/sync.wat +++ b/runtime/wasm/sync.wat @@ -53,9 +53,7 @@ (global $mutex_ops (ref $custom_operations) (struct.new $custom_operations - (array.new_fixed $bytes 6 ;; "_mutex" - (i32.const 95) (i32.const 109) (i32.const 117) (i32.const 116) - (i32.const 101) (i32.const 120)) + (@string "_mutex") (ref.func $custom_compare_id) (ref.null $compare) (ref.func $custom_hash_id) @@ -75,16 +73,13 @@ (struct.new $mutex (global.get $mutex_ops) (call $custom_next_id) (i32.const 0))) - (data $lock_failure "Mutex.lock: mutex already locked. Cannot wait.") + (@string $lock_failure "Mutex.lock: mutex already locked. Cannot wait.") (func (export "caml_ml_mutex_lock") (param (ref eq)) (result (ref eq)) (local $t (ref $mutex)) (local.set $t (ref.cast (ref $mutex) (local.get 0))) (if (struct.get $mutex $state (local.get $t)) - (then - (call $caml_failwith - (array.new_data $bytes $lock_failure - (i32.const 0) (i32.const 46))))) + (then (call $caml_failwith (global.get $lock_failure)))) (struct.set $mutex $state (local.get $t) (i32.const 1)) (ref.i31 (i32.const 0))) @@ -106,13 +101,11 @@ (func (export "caml_ml_condition_new") (param (ref eq)) (result (ref eq)) (ref.i31 (i32.const 0))) - (data $condition_failure "Condition.wait: cannot wait") + (@string $condition_failure "Condition.wait: cannot wait") (func (export "caml_ml_condition_wait") (param (ref eq)) (param (ref eq)) (result (ref eq)) - (call $caml_failwith - (array.new_data $bytes $condition_failure - (i32.const 0) (i32.const 27))) + (call $caml_failwith (global.get $condition_failure)) (ref.i31 (i32.const 0))) (func (export "caml_ml_condition_signal") (param (ref eq)) (result (ref eq)) diff --git a/runtime/wasm/sys.wat b/runtime/wasm/sys.wat index feff58e716..788e0ee478 100644 --- a/runtime/wasm/sys.wat +++ b/runtime/wasm/sys.wat @@ -154,17 +154,14 @@ (param (ref eq)) (result (ref eq)) (ref.i31 (i32.const 0))) - (data $Unix "Unix") - (data $Win32 "Win32") + (@string $Unix "Unix") + (@string $Win32 "Win32") (func (export "caml_sys_get_config") (param (ref eq)) (result (ref eq)) (array.new_fixed $block 4 (ref.i31 (i32.const 0)) - (if (result (ref eq)) (global.get $on_windows) - (then - (array.new_data $bytes $Win32 (i32.const 0) (i32.const 5))) - (else - (array.new_data $bytes $Unix (i32.const 0) (i32.const 4)))) + (select (result (ref eq)) (global.get $Win32) (global.get $Unix) + (global.get $on_windows)) (ref.i31 (i32.const 32)) (ref.i31 (i32.const 0)))) @@ -173,10 +170,10 @@ (return_call $isatty (call $caml_channel_descriptor (local.get $ch)))) (func (export "caml_runtime_variant") (param (ref eq)) (result (ref eq)) - (array.new_fixed $bytes 0)) + (@string "")) (func (export "caml_runtime_parameters") (param (ref eq)) (result (ref eq)) - (array.new_fixed $bytes 0)) + (@string "")) (func (export "caml_install_signal_handler") (param (ref eq) (ref eq)) (result (ref eq)) @@ -194,7 +191,7 @@ (param (ref eq)) (result (ref eq)) (ref.i31 (global.get $caml_runtime_warnings))) - (data $toString "toString") + (@string $toString "toString") (func $caml_handle_sys_error (export "caml_handle_sys_error") (param $exn externref) @@ -202,6 +199,6 @@ (call $caml_string_of_jsstring (call $caml_js_meth_call (call $wrap (any.convert_extern (local.get $exn))) - (array.new_data $bytes $toString (i32.const 0) (i32.const 8)) + (global.get $toString) (array.new_fixed $block 1 (ref.i31 (i32.const 0))))))) ) diff --git a/runtime/wasm/unix.wat b/runtime/wasm/unix.wat index 867f22abde..8bb79b9c9a 100644 --- a/runtime/wasm/unix.wat +++ b/runtime/wasm/unix.wat @@ -128,9 +128,9 @@ (global $unix_error_exn (mut (ref eq)) (ref.i31 (i32.const 0))) - (data $unix_error "Unix.Unix_error") + (@string $unix_error_str "Unix.Unix_error") - (data $unix_error_not_initialized + (@string $unix_error_not_initialized "Exception Unix.Unix_error not initialized, please link unix.cma") (func $get_unix_error_exn (result (ref eq)) @@ -138,19 +138,16 @@ (if (ref.test (ref i31) (global.get $unix_error_exn)) (then (local.set $unix_error_exn - (call $caml_named_value - (array.new_data $bytes $unix_error - (i32.const 0) (i32.const 15)))) + (call $caml_named_value (global.get $unix_error_str))) (if (ref.is_null (local.get $unix_error_exn)) (then (call $caml_invalid_argument - (array.new_data $bytes $unix_error_not_initialized - (i32.const 0) (i32.const 63))))) + (global.get $unix_error_not_initialized)))) (global.set $unix_error_exn (ref.as_non_null (local.get $unix_error_exn))))) (global.get $unix_error_exn)) - (global $no_arg (ref eq) (array.new_fixed $bytes 0)) + (@string $no_arg "") (global $unix_error (ref eq) (struct.new $js (global.get $unix_error_js))) @@ -167,11 +164,11 @@ (return (call $caml_string_of_jsstring (local.get $s))))) (return (global.get $no_arg))) - (data $code "code") - (data $errno "errno") - (data $indexOf "indexOf") - (data $syscall "syscall") - (data $path "path") + (@string $code "code") + (@string $errno "errno") + (@string $indexOf "indexOf") + (@string $syscall "syscall") + (@string $path "path") (func $caml_unix_error (param $exception externref) (param $cmd eqref) (local $exn (ref eq)) @@ -179,19 +176,16 @@ (local $errno (ref eq)) (local $variant (ref eq)) (local.set $exn (call $wrap (any.convert_extern (local.get $exception)))) - (local.set $code - (call $caml_js_get (local.get $exn) - (array.new_data $bytes $code (i32.const 0) (i32.const 4)))) + (local.set $code (call $caml_js_get (local.get $exn) (global.get $code))) (local.set $variant (call $caml_js_meth_call (global.get $unix_error) - (array.new_data $bytes $indexOf (i32.const 0) (i32.const 7)) + (global.get $indexOf) (array.new_fixed $block 2 (ref.i31 (i32.const 0)) (local.get $code)))) (if (ref.eq (local.get $variant) (ref.i31 (i32.const -1))) (then (local.set $errno - (call $caml_js_get (local.get $exn) - (array.new_data $bytes $errno (i32.const 0) (i32.const 4)))) + (call $caml_js_get (local.get $exn) (global.get $errno))) (local.set $errno (ref.i31 (if (result i32) (ref.test (ref i31) (local.get $errno)) @@ -212,13 +206,11 @@ (then (call $ensure_string (call $caml_js_get (local.get $exn) - (array.new_data $bytes $syscall - (i32.const 0) (i32.const 7))))) + (global.get $syscall)))) (else (ref.as_non_null (local.get $cmd)))) (call $ensure_string - (call $caml_js_get (local.get $exn) - (array.new_data $bytes $path (i32.const 0) (i32.const 4))))))) + (call $caml_js_get (local.get $exn) (global.get $path)))))) (func (export "unix_error_message") (export "caml_unix_error_message") (param $err (ref eq)) (result (ref eq)) @@ -1007,14 +999,14 @@ (i64.add (local.get $offset) (i64.extend_i32_s (local.get $n)))) (ref.i31 (local.get $n))) - (data $lseek "lseek") + (@string $lseek "lseek") (func $lseek_exn (param $errno i32) (result (ref eq)) (array.new_fixed $block 5 (ref.i31 (i32.const 0)) (call $get_unix_error_exn) (ref.i31 (local.get $errno)) - (array.new_data $bytes $lseek (i32.const 0) (i32.const 5)) + (global.get $lseek) (global.get $no_arg))) (func $lseek @@ -1074,17 +1066,14 @@ (call $caml_unix_error (pop externref) (ref.null eq)))) (ref.i31 (i32.const 0))) - (data $out_channel_of_descr "out_channel_of_descr") - (data $in_channel_of_descr "in_channel_of_descr") + (@string $out_channel_of_descr "out_channel_of_descr") + (@string $in_channel_of_descr "in_channel_of_descr") (func $channel_of_descr_name (param $out i32) (result (ref eq)) - (if (result (ref eq)) (local.get $out) - (then - (array.new_data $bytes $out_channel_of_descr - (i32.const 0) (i32.const 20))) - (else - (array.new_data $bytes $in_channel_of_descr - (i32.const 0) (i32.const 19))))) + (select (result (ref eq)) + (global.get $out_channel_of_descr) + (global.get $in_channel_of_descr) + (local.get $out))) (func $caml_unix_check_stream_semantics (param $fd (ref eq)) (param $out i32) (local $s (ref $block)) (local $kind i32) diff --git a/runtime/wasm/weak.wat b/runtime/wasm/weak.wat index 8f1403606d..1f704b8071 100644 --- a/runtime/wasm/weak.wat +++ b/runtime/wasm/weak.wat @@ -275,7 +275,7 @@ (call $caml_ephe_set_data_opt (local.get $vx) (local.get $d)) (ref.i31 (i32.const 0))) - (data $Weak_create "Weak.create") + (@string $Weak_create "Weak.create") (export "caml_weak_create" (func $caml_ephe_create)) (func $caml_ephe_create (export "caml_ephe_create") @@ -284,10 +284,7 @@ (local $res (ref $block)) (local.set $len (i31.get_s (ref.cast (ref i31) (local.get $vlen)))) (if (i32.lt_s (local.get $len) (i32.const 0)) - (then - (call $caml_invalid_argument - (array.new_data $bytes $Weak_create - (i32.const 0) (i32.const 11))))) + (then (call $caml_invalid_argument (global.get $Weak_create)))) (local.set $res (array.new $block (global.get $caml_ephe_none) (i32.add (local.get $len) (global.get $caml_ephe_key_offset)))) From 89db4dde05b50d22e7efd2c976fe344a664f419c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Fri, 31 Jan 2025 12:36:09 +0100 Subject: [PATCH 15/29] Preprocessor: use the export name to name functions without id This provides a better debugging experience since reference to these functions will now use an id rather than a number in disassembled code. --- compiler/lib-wasm/wat_preprocess.ml | 28 +++++++++++++++++++++++++++- manual/wasm_runtime.wiki | 2 ++ runtime/wasm/jslib_js_of_ocaml.wat | 8 ++++---- 3 files changed, 33 insertions(+), 5 deletions(-) diff --git a/compiler/lib-wasm/wat_preprocess.ml b/compiler/lib-wasm/wat_preprocess.ml index 97ec321deb..29bb76c781 100644 --- a/compiler/lib-wasm/wat_preprocess.ml +++ b/compiler/lib-wasm/wat_preprocess.ml @@ -288,6 +288,11 @@ let type_name (t : typ) = | String -> "string" | Version -> "version" +let variable_is_set st nm = + match StringMap.find_opt nm st.variables with + | Some (Bool true) -> true + | _ -> false + let check_type ?typ expr actual_typ = match typ with | None -> () @@ -520,6 +525,25 @@ and rewrite st elt = | { desc = List ({ desc = Atom "@string"; _ } :: _ :: _ :: { loc; _ } :: _); _ } -> raise (Error (position_of_loc loc, Printf.sprintf "Expecting a closing parenthesis.\n")) + | { desc = + List + ({ desc = Atom "func"; loc = _, pos } + :: { desc = + List + [ { desc = Atom "export"; _ } + ; { desc = Atom export_name; loc = export_loc } + ] + ; loc = pos', _ + } + :: l) + ; _ + } + when variable_is_set st "name-wasm-functions" + && is_id ("$" ^ parse_string export_loc export_name) -> + write st pos; + insert st (Printf.sprintf " $%s " (parse_string export_loc export_name)); + skip st pos'; + rewrite_list st l | { desc = List l; _ } -> rewrite_list st l | _ -> () @@ -529,12 +553,14 @@ let ocaml_version = Scanf.sscanf Sys.ocaml_version "%d.%d.%d" (fun major minor patchlevel -> Version (major, minor, patchlevel)) +let default_settings = [ "name-wasm-functions", Bool true ] + let f ~variables ~filename ~contents:text = let variables = List.fold_left ~f:(fun m (k, v) -> StringMap.add k v m) ~init:StringMap.empty - variables + (default_settings @ variables) in let variables = StringMap.add "ocaml_version" ocaml_version variables in let lexbuf = Sedlexing.Utf8.from_string text in diff --git a/manual/wasm_runtime.wiki b/manual/wasm_runtime.wiki index 972dbd91c1..4dfd37812d 100644 --- a/manual/wasm_runtime.wiki +++ b/manual/wasm_runtime.wiki @@ -62,6 +62,8 @@ To form conditional expressions, the following operators are available: It also provides some syntactic sugar to write strings. The expression{{{(@string "ab")}}} is expanded into {{{(array.new_fixed $bytes 2 (i32.const 97) (i32.const 98))}}}. The statement {{{(@string $s "ab")}}} is an abbreviation for {{{(global $s (ref eq) (@string "ab"))}}}. +To provide a better debugging experience, the function export name is used to name functions with no explicit id: {{{(func (export "foo") ...)}}}} is expanded into {{{(func $foo (export "foo") ...)}}}}. + == Implementing primitives == You define a primitive by exporting a Wasm function with parameters and return value of type {{{(ref eq)}}}. diff --git a/runtime/wasm/jslib_js_of_ocaml.wat b/runtime/wasm/jslib_js_of_ocaml.wat index 182453139c..5f3c4c14e0 100644 --- a/runtime/wasm/jslib_js_of_ocaml.wat +++ b/runtime/wasm/jslib_js_of_ocaml.wat @@ -27,20 +27,20 @@ (import "jslib" "caml_js_from_array" (func $caml_js_from_array (param (ref eq)) (result (ref eq)))) (import "js" "caml_js_html_escape" - (func $caml_js_html_escape (param anyref) (result anyref))) + (func $caml_js_html_escape_js (param anyref) (result anyref))) (import "js" "caml_js_html_entities" - (func $caml_js_html_entities (param anyref) (result anyref))) + (func $caml_js_html_entities_js (param anyref) (result anyref))) (type $block (array (mut (ref eq)))) (type $bytes (array (mut i8))) (func (export "caml_js_html_escape") (param (ref eq)) (result (ref eq)) (return_call $wrap - (call $caml_js_html_escape (call $unwrap (local.get 0))))) + (call $caml_js_html_escape_js (call $unwrap (local.get 0))))) (func (export "caml_js_html_entities") (param (ref eq)) (result (ref eq)) (return_call $wrap - (call $caml_js_html_entities (call $unwrap (local.get 0))))) + (call $caml_js_html_entities_js (call $unwrap (local.get 0))))) (@string $console "console") From 6252a07ce27870adb836f96f2f6789c0410cac58 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Mon, 3 Feb 2025 12:22:04 +0100 Subject: [PATCH 16/29] Preprocessor: add references to the Wasm standards --- compiler/lib-wasm/wat_preprocess.ml | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/compiler/lib-wasm/wat_preprocess.ml b/compiler/lib-wasm/wat_preprocess.ml index 29bb76c781..5637781e9c 100644 --- a/compiler/lib-wasm/wat_preprocess.ml +++ b/compiler/lib-wasm/wat_preprocess.ml @@ -9,6 +9,14 @@ let report_error loc msg = (****) +(* +See the WebAssembly Text Format Specification: +https://webassembly.github.io/spec/core/text/index.html + +We use custom annotations to extend the syntax +(https://github.com/WebAssembly/annotations). +*) + let digit = [%sedlex.regexp? '0' .. '9'] let hexdigit = [%sedlex.regexp? '0' .. '9' | 'a' .. 'f' | 'A' .. 'F'] From 0aaae8bb8dd387661691a9927dbb48f5303070ba Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Tue, 4 Feb 2025 15:49:58 +0100 Subject: [PATCH 17/29] Preprocessor: move tools as subcommands inside wasm_of_ocaml --- compiler/bin-wasm_of_ocaml/dune | 6 +- compiler/bin-wasm_of_ocaml/info.ml | 4 +- compiler/bin-wasm_of_ocaml/link_wasm.ml | 110 +++++++++++ compiler/bin-wasm_of_ocaml/link_wasm.mli | 19 ++ compiler/bin-wasm_of_ocaml/preprocess.ml | 152 +++++++++++++++ .../preprocess.mli} | 30 +-- compiler/bin-wasm_of_ocaml/wasm_of_ocaml.ml | 8 +- .../bin-wasm_of_ocaml/wasmoo_link_wasm.ml | 43 +++++ .../bin-wasm_of_ocaml/wasmoo_link_wasm.mli | 17 ++ compiler/bin-wasmoo_util/cmd_arg.ml | 181 ------------------ compiler/bin-wasmoo_util/dune | 17 -- compiler/bin-wasmoo_util/tests/dune | 12 -- compiler/bin-wasmoo_util/wasmoo_util.ml | 121 ------------ .../preprocess}/cram.t | 70 +++---- compiler/tests-wasm_of_ocaml/preprocess/dune | 21 ++ .../preprocess}/tests.expected | 0 .../preprocess}/tests.txt | 0 runtime/wasm/dune | 3 +- 18 files changed, 415 insertions(+), 399 deletions(-) create mode 100644 compiler/bin-wasm_of_ocaml/link_wasm.ml create mode 100644 compiler/bin-wasm_of_ocaml/link_wasm.mli create mode 100644 compiler/bin-wasm_of_ocaml/preprocess.ml rename compiler/{bin-wasmoo_util/cmd_arg.mli => bin-wasm_of_ocaml/preprocess.mli} (61%) create mode 100644 compiler/bin-wasm_of_ocaml/wasmoo_link_wasm.ml create mode 100644 compiler/bin-wasm_of_ocaml/wasmoo_link_wasm.mli delete mode 100644 compiler/bin-wasmoo_util/cmd_arg.ml delete mode 100644 compiler/bin-wasmoo_util/dune delete mode 100644 compiler/bin-wasmoo_util/tests/dune delete mode 100644 compiler/bin-wasmoo_util/wasmoo_util.ml rename compiler/{bin-wasmoo_util/tests => tests-wasm_of_ocaml/preprocess}/cram.t (63%) create mode 100644 compiler/tests-wasm_of_ocaml/preprocess/dune rename compiler/{bin-wasmoo_util/tests => tests-wasm_of_ocaml/preprocess}/tests.expected (100%) rename compiler/{bin-wasmoo_util/tests => tests-wasm_of_ocaml/preprocess}/tests.txt (100%) diff --git a/compiler/bin-wasm_of_ocaml/dune b/compiler/bin-wasm_of_ocaml/dune index 19598ca764..48619f0fe4 100644 --- a/compiler/bin-wasm_of_ocaml/dune +++ b/compiler/bin-wasm_of_ocaml/dune @@ -1,6 +1,6 @@ -(executable - (name wasm_of_ocaml) - (public_name wasm_of_ocaml) +(executables + (names wasm_of_ocaml wasmoo_link_wasm) + (public_names wasm_of_ocaml -) (package wasm_of_ocaml-compiler) (libraries jsoo_cmdline diff --git a/compiler/bin-wasm_of_ocaml/info.ml b/compiler/bin-wasm_of_ocaml/info.ml index c297de5b6c..9a440d48c9 100644 --- a/compiler/bin-wasm_of_ocaml/info.ml +++ b/compiler/bin-wasm_of_ocaml/info.ml @@ -32,9 +32,9 @@ let make ~name ~doc ~description = ; `S "AUTHORS" ; `P "Jerome Vouillon, Hugo Heuzard." ; `S "LICENSE" - ; `P "Copyright (C) 2010-2024." + ; `P "Copyright (C) 2010-2025." ; `P - "js_of_ocaml is free software, you can redistribute it and/or modify it under \ + "wasm_of_ocaml is free software, you can redistribute it and/or modify it under \ the terms of the GNU Lesser General Public License as published by the Free \ Software Foundation, with linking exception; either version 2.1 of the License, \ or (at your option) any later version." diff --git a/compiler/bin-wasm_of_ocaml/link_wasm.ml b/compiler/bin-wasm_of_ocaml/link_wasm.ml new file mode 100644 index 0000000000..3a87a32a37 --- /dev/null +++ b/compiler/bin-wasm_of_ocaml/link_wasm.ml @@ -0,0 +1,110 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +open Cmdliner +open Js_of_ocaml_compiler.Stdlib +open Wasm_of_ocaml_compiler + +type binaryen_options = + { common : string list + ; opt : string list + ; merge : string list + } + +type options = + { input_modules : (string * string) list + ; output_file : string + ; variables : Preprocess.variables + ; binaryen_options : binaryen_options + } + +let options = + let input_modules = + let doc = + "Specify an input module with name $(i,NAME) in Wasm text file $(i,FILE)." + in + Arg.( + value + & pos_right 0 (pair ~sep:':' string string) [] + & info [] ~docv:"NAME:FILE" ~doc) + in + let output_file = + let doc = "Specify the Wasm binary output file $(docv)." in + Arg.(required & pos 0 (some string) None & info [] ~docv:"WASM_FILE" ~doc) + in + let binaryen_options = + let doc = "Pass option $(docv) to binaryen tools" in + Arg.(value & opt_all string [] & info [ "binaryen" ] ~docv:"OPT" ~doc) + in + let opt_options = + let doc = "Pass option $(docv) to $(b,wasm-opt)" in + Arg.(value & opt_all string [] & info [ "binaryen-opt" ] ~docv:"OPT" ~doc) + in + let merge_options = + let doc = "Pass option $(docv) to $(b,wasm-merge)" in + Arg.(value & opt_all string [] & info [ "binaryen-merge" ] ~docv:"OPT" ~doc) + in + let build_t input_modules output_file variables common opt merge = + `Ok + { input_modules; output_file; variables; binaryen_options = { common; opt; merge } } + in + let t = + Term.( + const build_t + $ input_modules + $ output_file + $ Preprocess.variable_options + $ binaryen_options + $ opt_options + $ merge_options) + in + Term.ret t + +let link + { input_modules; output_file; variables; binaryen_options = { common; merge; opt } } = + let inputs = + List.map + ~f:(fun (module_name, file) -> + { Wat_preprocess.module_name + ; file + ; source = + (if Link.Wasm_binary.check_file ~file + then File + else Contents (Js_of_ocaml_compiler.Fs.read_file file)) + }) + input_modules + in + Runtime.build + ~link_options:(common @ merge) + ~opt_options:(common @ opt) + ~variables:(Preprocess.set_variables variables) + ~inputs + ~output_file + +let info = + Info.make + ~name:"link-wasm" + ~doc:"Wasm linker" + ~description: + "$(b,wasmoo_link_wasm) is a Wasm linker. It takes as input a list of Wasm text \ + files, preprocesses them, links them together, and outputs a single Wasm binary \ + module" + +let term = Cmdliner.Term.(const link $ options) + +let command = Cmdliner.Cmd.v info term diff --git a/compiler/bin-wasm_of_ocaml/link_wasm.mli b/compiler/bin-wasm_of_ocaml/link_wasm.mli new file mode 100644 index 0000000000..952975461c --- /dev/null +++ b/compiler/bin-wasm_of_ocaml/link_wasm.mli @@ -0,0 +1,19 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +val command : unit Cmdliner.Cmd.t diff --git a/compiler/bin-wasm_of_ocaml/preprocess.ml b/compiler/bin-wasm_of_ocaml/preprocess.ml new file mode 100644 index 0000000000..277527ff64 --- /dev/null +++ b/compiler/bin-wasm_of_ocaml/preprocess.ml @@ -0,0 +1,152 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +open Cmdliner +open Js_of_ocaml_compiler.Stdlib +open Wasm_of_ocaml_compiler + +let () = Sys.catch_break true + +let read_contents ch = + let buf = Buffer.create 65536 in + let b = Bytes.create 65536 in + let rec read () = + let n = input ch b 0 (Bytes.length b) in + if n > 0 + then ( + Buffer.add_subbytes buf b 0 n; + read ()) + in + read (); + Buffer.contents buf + +type variables = + { enable : string list + ; disable : string list + ; set : (string * string) list + } + +type options = + { input_file : string option + ; output_file : string option + ; variables : variables + } + +let variable_options = + let enable = + let doc = "Set preprocessor variable $(docv) to true." in + let arg = + Arg.(value & opt_all (list string) [] & info [ "enable" ] ~docv:"VAR" ~doc) + in + Term.(const List.flatten $ arg) + in + let disable = + let doc = "Set preprocessor variable $(docv) to false." in + let arg = + Arg.(value & opt_all (list string) [] & info [ "disable" ] ~docv:"VAR" ~doc) + in + Term.(const List.flatten $ arg) + in + let set = + let doc = "Set preprocessor variable $(i,VAR) to value $(i,VALUE)." in + let arg = + Arg.( + value + & opt_all (list (pair ~sep:'=' string string)) [] + & info [ "set" ] ~docv:"VAR=VALUE" ~doc) + in + Term.(const List.flatten $ arg) + in + let build_t enable disable set = { enable; disable; set } in + Term.(const build_t $ enable $ disable $ set) + +let options = + let input_file = + let doc = + "Use the Wasm text file $(docv) as input (default to the standard input)." + in + Arg.(value & pos 0 (some string) None & info [] ~docv:"INPUT_FILE" ~doc) + in + let output_file = + let doc = "Specify the output file $(docv) (default to the standard output)." in + Arg.(value & opt (some string) None & info [ "o" ] ~docv:"OUTPUT_FILE" ~doc) + in + let build_t input_file output_file variables = + `Ok { input_file; output_file; variables } + in + let t = Term.(const build_t $ input_file $ output_file $ variable_options) in + Term.ret t + +let set_variables { enable; disable; set } = + List.map ~f:(fun nm -> nm, Wat_preprocess.Bool true) enable + @ List.map ~f:(fun nm -> nm, Wat_preprocess.Bool false) disable + @ List.map ~f:(fun (nm, v) -> nm, Wat_preprocess.String v) set + +let preprocess { input_file; output_file; variables } = + let with_input f = + match input_file with + | None -> f stdin + | Some file -> + let ch = open_in file in + let res = f ch in + close_in ch; + res + in + let with_output f = + match output_file with + | Some "-" | None -> f stdout + | Some file -> Filename.gen_file file f + in + let contents = with_input read_contents in + let res = + Wat_preprocess.f + ~filename:(Option.value ~default:"-" input_file) + ~contents + ~variables:(set_variables variables) + in + with_output (fun ch -> output_string ch res) + +let term = Cmdliner.Term.(const preprocess $ options) + +let info = + Info.make + ~name:"preprocess" + ~doc:"Wasm text file preprocessor" + ~description:"$(b,wasmoo_util pp) is a Wasm text file preprocessor." + +let command = Cmdliner.Cmd.v info term + +(* Adapted from + https://github.com/ocaml/opam/blob/fbbe93c3f67034da62d28c8666ec6b05e0a9b17c/s +rc/client/opamArg.ml#L759 *) +let alias_command ?orig_name cmd term name = + let orig = + match orig_name with + | Some s -> s + | None -> Cmd.name cmd + in + let doc = Printf.sprintf "An alias for $(b,%s)." orig in + let man = + [ `S "DESCRIPTION" + ; `P (Printf.sprintf "$(mname)$(b, %s) is an alias for $(mname)$(b, %s)." name orig) + ; `P (Printf.sprintf "See $(mname)$(b, %s --help) for details." orig) + ] + in + Cmd.v (Cmd.info name ~docs:"COMMAND ALIASES" ~doc ~man) term + +let command_alias = alias_command ~orig_name:"preprocess" command term "pp" diff --git a/compiler/bin-wasmoo_util/cmd_arg.mli b/compiler/bin-wasm_of_ocaml/preprocess.mli similarity index 61% rename from compiler/bin-wasmoo_util/cmd_arg.mli rename to compiler/bin-wasm_of_ocaml/preprocess.mli index e23e53c35e..9ad1de2fff 100644 --- a/compiler/bin-wasmoo_util/cmd_arg.mli +++ b/compiler/bin-wasm_of_ocaml/preprocess.mli @@ -22,31 +22,11 @@ type variables = ; set : (string * string) list } -type preprocess_options = - { input_file : string option - ; output_file : string option - ; variables : variables - } - -val preprocess_options : preprocess_options Cmdliner.Term.t - -val preprocess_info : Cmdliner.Cmd.info - -type binaryen_options = - { common : string list - ; opt : string list - ; merge : string list - } - -type link_options = - { input_modules : (string * string) list - ; output_file : string - ; variables : variables - ; binaryen_options : binaryen_options - } +val variable_options : variables Cmdliner.Term.t -val link_options : link_options Cmdliner.Term.t +val set_variables : + variables -> (string * Wasm_of_ocaml_compiler.Wat_preprocess.value) list -val link_info : Cmdliner.Cmd.info +val command : unit Cmdliner.Cmd.t -val info : Cmdliner.Cmd.info +val command_alias : unit Cmdliner.Cmd.t diff --git a/compiler/bin-wasm_of_ocaml/wasm_of_ocaml.ml b/compiler/bin-wasm_of_ocaml/wasm_of_ocaml.ml index fdb2df384e..1ffcba57c5 100644 --- a/compiler/bin-wasm_of_ocaml/wasm_of_ocaml.ml +++ b/compiler/bin-wasm_of_ocaml/wasm_of_ocaml.ml @@ -48,7 +48,13 @@ let () = (Cmdliner.Cmd.group ~default:Compile.term (Compile.info "wasm_of_ocaml") - [ Link.command; Build_runtime.command; Compile.command ]) + [ Link.command + ; Build_runtime.command + ; Compile.command + ; Preprocess.command + ; Preprocess.command_alias + ; Link_wasm.command + ]) with | Ok (`Ok () | `Help | `Version) -> if !warnings > 0 && !werror diff --git a/compiler/bin-wasm_of_ocaml/wasmoo_link_wasm.ml b/compiler/bin-wasm_of_ocaml/wasmoo_link_wasm.ml new file mode 100644 index 0000000000..d9f7a24766 --- /dev/null +++ b/compiler/bin-wasm_of_ocaml/wasmoo_link_wasm.ml @@ -0,0 +1,43 @@ +(* Js_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * Copyright (C) 2013 Hugo Heuzard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +open Js_of_ocaml_compiler.Stdlib + +let (_ : int) = + try + Cmdliner.Cmd.eval + ~catch:false + ~argv:(Jsoo_cmdline.normalize_argv ~warn:(warn "%s") Sys.argv) + Link_wasm.command + with + | (Match_failure _ | Assert_failure _ | Not_found) as exc -> + let backtrace = Printexc.get_backtrace () in + Format.eprintf + "%s: You found a bug. Please report it at \ + https://github.com/ocsigen/js_of_ocaml/issues :@." + Sys.argv.(0); + Format.eprintf "Error: %s@." (Printexc.to_string exc); + prerr_string backtrace; + exit 1 + | Failure s -> + Format.eprintf "%s: Error: %s@." Sys.argv.(0) s; + exit 1 + | exc -> + Format.eprintf "%s: Error: %s@." Sys.argv.(0) (Printexc.to_string exc); + exit 1 diff --git a/compiler/bin-wasm_of_ocaml/wasmoo_link_wasm.mli b/compiler/bin-wasm_of_ocaml/wasmoo_link_wasm.mli new file mode 100644 index 0000000000..cc6700682b --- /dev/null +++ b/compiler/bin-wasm_of_ocaml/wasmoo_link_wasm.mli @@ -0,0 +1,17 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) diff --git a/compiler/bin-wasmoo_util/cmd_arg.ml b/compiler/bin-wasmoo_util/cmd_arg.ml deleted file mode 100644 index d9c6d01bdd..0000000000 --- a/compiler/bin-wasmoo_util/cmd_arg.ml +++ /dev/null @@ -1,181 +0,0 @@ -(* Js_of_ocaml compiler - * http://www.ocsigen.org/js_of_ocaml/ - * Copyright (C) 2014 Hugo Heuzard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - *) - -open Cmdliner - -type variables = - { enable : string list - ; disable : string list - ; set : (string * string) list - } - -type preprocess_options = - { input_file : string option - ; output_file : string option - ; variables : variables - } - -let variable_options = - let enable = - let doc = "Set preprocessor variable $(docv) to true." in - let arg = - Arg.(value & opt_all (list string) [] & info [ "enable" ] ~docv:"VAR" ~doc) - in - Term.(const List.flatten $ arg) - in - let disable = - let doc = "Set preprocessor variable $(docv) to false." in - let arg = - Arg.(value & opt_all (list string) [] & info [ "disable" ] ~docv:"VAR" ~doc) - in - Term.(const List.flatten $ arg) - in - let set = - let doc = "Set preprocessor variable $(i,VAR) to value $(i,VALUE)." in - let arg = - Arg.( - value - & opt_all (list (pair ~sep:'=' string string)) [] - & info [ "set" ] ~docv:"VAR=VALUE" ~doc) - in - Term.(const List.flatten $ arg) - in - let build_t enable disable set = { enable; disable; set } in - Term.(const build_t $ enable $ disable $ set) - -let preprocess_options = - let input_file = - let doc = - "Use the Wasm text file $(docv) as input (default to the standard input)." - in - Arg.(value & pos 0 (some string) None & info [] ~docv:"INPUT_FILE" ~doc) - in - let output_file = - let doc = "Specify the output file $(docv) (default to the standard output)." in - Arg.(value & opt (some string) None & info [ "o" ] ~docv:"OUTPUT_FILE" ~doc) - in - let build_t input_file output_file variables = - `Ok { input_file; output_file; variables } - in - let t = Term.(const build_t $ input_file $ output_file $ variable_options) in - Term.ret t - -type binaryen_options = - { common : string list - ; opt : string list - ; merge : string list - } - -type link_options = - { input_modules : (string * string) list - ; output_file : string - ; variables : variables - ; binaryen_options : binaryen_options - } - -let link_options = - let input_modules = - let doc = - "Specify an input module with name $(i,NAME) in Wasm text file $(i,FILE)." - in - Arg.( - value - & pos_right 0 (pair ~sep:':' string string) [] - & info [] ~docv:"NAME:FILE" ~doc) - in - let output_file = - let doc = "Specify the Wasm binary output file $(docv)." in - Arg.(required & pos 0 (some string) None & info [] ~docv:"WASM_FILE" ~doc) - in - let binaryen_options = - let doc = "Pass option $(docv) to binaryen tools" in - Arg.(value & opt_all string [] & info [ "binaryen" ] ~docv:"OPT" ~doc) - in - let opt_options = - let doc = "Pass option $(docv) to $(b,wasm-opt)" in - Arg.(value & opt_all string [] & info [ "binaryen-opt" ] ~docv:"OPT" ~doc) - in - let merge_options = - let doc = "Pass option $(docv) to $(b,wasm-merge)" in - Arg.(value & opt_all string [] & info [ "binaryen-merge" ] ~docv:"OPT" ~doc) - in - let build_t input_modules output_file variables common opt merge = - `Ok - { input_modules; output_file; variables; binaryen_options = { common; opt; merge } } - in - let t = - Term.( - const build_t - $ input_modules - $ output_file - $ variable_options - $ binaryen_options - $ opt_options - $ merge_options) - in - Term.ret t - -let make_info ~name ~doc ~description = - let man = - [ `S "DESCRIPTION" - ; `P description - ; `S "BUGS" - ; `P - "Bugs are tracked on github at \ - $(i,https://github.com/ocsigen/js_of_ocaml/issues)." - ; `S "SEE ALSO" - ; `P "wasm_of_ocaml(1)" - ; `S "AUTHORS" - ; `P "Jerome Vouillon, Hugo Heuzard." - ; `S "LICENSE" - ; `P "Copyright (C) 2010-2025." - ; `P - "wasmoo_util is free software, you can redistribute it and/or modify it under \ - the terms of the GNU Lesser General Public License as published by the Free \ - Software Foundation, with linking exception; either version 2.1 of the License, \ - or (at your option) any later version." - ] - in - let version = - match Js_of_ocaml_compiler.Compiler_version.git_version with - | "" -> Js_of_ocaml_compiler.Compiler_version.s - | v -> Printf.sprintf "%s+%s" Js_of_ocaml_compiler.Compiler_version.s v - in - Cmd.info name ~version ~doc ~man - -let preprocess_info = - make_info - ~name:"pp" - ~doc:"Wasm text file preprocessor" - ~description:"$(b,wasmoo_util pp) is a Wasm text file preprocessor." - -let link_info = - make_info - ~name:"link" - ~doc:"Wasm linker" - ~description: - "$(b,wasmoo_util link) is a Wasm linker. It takes as input a list of Wasm text \ - files, preprocesses them, links them together, and outputs a single Wasm binary \ - module" - -let info = - make_info - ~name:"wasmoo_util" - ~doc:"Wasm utilities" - ~description:"wasmoo_util is a collection of utilities for $(b,wasm_of_ocaml)" diff --git a/compiler/bin-wasmoo_util/dune b/compiler/bin-wasmoo_util/dune deleted file mode 100644 index d09db61954..0000000000 --- a/compiler/bin-wasmoo_util/dune +++ /dev/null @@ -1,17 +0,0 @@ -(executable - (name wasmoo_util) - (public_name wasmoo_util) - (package wasm_of_ocaml-compiler) - (libraries wasm_of_ocaml-compiler jsoo_cmdline cmdliner)) - -(rule - (targets wasmoo_util.1) - (action - (with-stdout-to - %{targets} - (run %{bin:wasmoo_util} --help=groff)))) - -(install - (section man) - (package wasm_of_ocaml-compiler) - (files wasmoo_util.1)) diff --git a/compiler/bin-wasmoo_util/tests/dune b/compiler/bin-wasmoo_util/tests/dune deleted file mode 100644 index efe865bf23..0000000000 --- a/compiler/bin-wasmoo_util/tests/dune +++ /dev/null @@ -1,12 +0,0 @@ -(rule - (with-stdout-to - tests.output - (run wasmoo_util pp --enable a --disable b --set c=1 %{dep:tests.txt}))) - -(rule - (alias runtest) - (action - (diff tests.expected tests.output))) - -(cram - (deps %{bin:wasmoo_util})) diff --git a/compiler/bin-wasmoo_util/wasmoo_util.ml b/compiler/bin-wasmoo_util/wasmoo_util.ml deleted file mode 100644 index 6f0cc37e29..0000000000 --- a/compiler/bin-wasmoo_util/wasmoo_util.ml +++ /dev/null @@ -1,121 +0,0 @@ -(* Js_of_ocaml compiler - * http://www.ocsigen.org/js_of_ocaml/ - * Copyright (C) 2013 Hugo Heuzard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - *) - -open Js_of_ocaml_compiler.Stdlib -open Wasm_of_ocaml_compiler - -let () = Sys.catch_break true - -let read_contents ch = - let buf = Buffer.create 65536 in - let b = Bytes.create 65536 in - let rec read () = - let n = input ch b 0 (Bytes.length b) in - if n > 0 - then ( - Buffer.add_subbytes buf b 0 n; - read ()) - in - read (); - Buffer.contents buf - -let set_variables { Cmd_arg.enable; disable; set } = - List.map ~f:(fun nm -> nm, Wat_preprocess.Bool true) enable - @ List.map ~f:(fun nm -> nm, Wat_preprocess.Bool false) disable - @ List.map ~f:(fun (nm, v) -> nm, Wat_preprocess.String v) set - -let preprocess { Cmd_arg.input_file; output_file; variables } = - let with_input f = - match input_file with - | None -> f stdin - | Some file -> - let ch = open_in file in - let res = f ch in - close_in ch; - res - in - let with_output f = - match output_file with - | Some "-" | None -> f stdout - | Some file -> Filename.gen_file file f - in - let contents = with_input read_contents in - let res = - Wat_preprocess.f - ~filename:(Option.value ~default:"-" input_file) - ~contents - ~variables:(set_variables variables) - in - with_output (fun ch -> output_string ch res) - -let preprocess_term = Cmdliner.Term.(const preprocess $ Cmd_arg.preprocess_options) - -let preprocess_command = Cmdliner.Cmd.v Cmd_arg.preprocess_info preprocess_term - -let link - { Cmd_arg.input_modules - ; output_file - ; variables - ; binaryen_options = { common; merge; opt } - } = - let inputs = - List.map - ~f:(fun (module_name, file) -> - { Wat_preprocess.module_name - ; file - ; source = - (if Link.Wasm_binary.check_file ~file - then File - else Contents (Js_of_ocaml_compiler.Fs.read_file file)) - }) - input_modules - in - Runtime.build - ~link_options:(common @ merge) - ~opt_options:(common @ opt) - ~variables:(set_variables variables) - ~inputs - ~output_file - -let link_term = Cmdliner.Term.(const link $ Cmd_arg.link_options) - -let link_command = Cmdliner.Cmd.v Cmd_arg.link_info link_term - -let (_ : int) = - try - Cmdliner.Cmd.eval - ~catch:false - ~argv:(Jsoo_cmdline.normalize_argv ~warn:(warn "%s") Sys.argv) - (Cmdliner.Cmd.group Cmd_arg.info [ preprocess_command; link_command ]) - with - | (Match_failure _ | Assert_failure _ | Not_found) as exc -> - let backtrace = Printexc.get_backtrace () in - Format.eprintf - "%s: You found a bug. Please report it at \ - https://github.com/ocsigen/js_of_ocaml/issues :@." - Sys.argv.(0); - Format.eprintf "Error: %s@." (Printexc.to_string exc); - prerr_string backtrace; - exit 1 - | Failure s -> - Format.eprintf "%s: Error: %s@." Sys.argv.(0) s; - exit 1 - | exc -> - Format.eprintf "%s: Error: %s@." Sys.argv.(0) (Printexc.to_string exc); - exit 1 diff --git a/compiler/bin-wasmoo_util/tests/cram.t b/compiler/tests-wasm_of_ocaml/preprocess/cram.t similarity index 63% rename from compiler/bin-wasmoo_util/tests/cram.t rename to compiler/tests-wasm_of_ocaml/preprocess/cram.t index 2e8807637d..d21009864c 100644 --- a/compiler/bin-wasmoo_util/tests/cram.t +++ b/compiler/tests-wasm_of_ocaml/preprocess/cram.t @@ -1,189 +1,189 @@ Too many parentheses - $ echo '())' | wasmoo_util pp + $ echo '())' | wasm_of_ocaml pp File "-", line 1, characters 2-3: Unexpected closing parenthesis. [1] - $ echo '();)' | wasmoo_util pp + $ echo '();)' | wasm_of_ocaml pp File "-", line 1, characters 2-4: Unmatched closing comment. [1] Missing parenthesis - $ echo '(()' | wasmoo_util pp + $ echo '(()' | wasm_of_ocaml pp File "-", line 1, characters 0-1: Unclosed parenthesis. [1] - $ echo '(; ()' | wasmoo_util pp + $ echo '(; ()' | wasm_of_ocaml pp File "-", line 1, characters 0-2: Unclosed comment. [1] - $ echo '(; (; ()' | wasmoo_util pp + $ echo '(; (; ()' | wasm_of_ocaml pp File "-", line 1, characters 3-5: Unclosed comment. [1] Unterminated string (we point at the newline) - $ echo '"abcd' | wasmoo_util pp + $ echo '"abcd' | wasm_of_ocaml pp File "-", line 1, characters 5-5: Malformed string. [1] Bad conditional - $ echo '(@if)' | wasmoo_util pp + $ echo '(@if)' | wasm_of_ocaml pp File "-", line 1, characters 4-5: Expecting condition. [1] - $ echo '(@if a)' | wasmoo_util pp + $ echo '(@if a)' | wasm_of_ocaml pp File "-", line 1, characters 6-7: Expecting @then clause. [1] - $ echo '(@if a xxx)' | wasmoo_util pp + $ echo '(@if a xxx)' | wasm_of_ocaml pp File "-", line 1, characters 7-10: Expecting @then clause. [1] - $ echo '(@if a (@then) xx)' | wasmoo_util pp + $ echo '(@if a (@then) xx)' | wasm_of_ocaml pp File "-", line 1, characters 15-17: Expecting @else clause or closing parenthesis. [1] - $ echo '(@if a (@then) (@else) xx)' | wasmoo_util pp + $ echo '(@if a (@then) (@else) xx)' | wasm_of_ocaml pp File "-", line 1, characters 23-25: Expecting closing parenthesis. [1] Syntax error in condition - $ echo '(@if () (@then))' | wasmoo_util pp + $ echo '(@if () (@then))' | wasm_of_ocaml pp File "-", line 1, characters 5-7: Syntax error. [1] - $ echo '(@if (not) (@then))' | wasmoo_util pp + $ echo '(@if (not) (@then))' | wasm_of_ocaml pp File "-", line 1, characters 5-10: Syntax error. [1] - $ echo '(@if (not (and) (or)) (@then))' | wasmoo_util pp + $ echo '(@if (not (and) (or)) (@then))' | wasm_of_ocaml pp File "-", line 1, characters 5-21: Syntax error. [1] - $ echo '(@if (= "a") (@then))' | wasmoo_util pp + $ echo '(@if (= "a") (@then))' | wasm_of_ocaml pp File "-", line 1, characters 5-12: Syntax error. [1] - $ echo '(@if (= "a" "b" "c") (@then))' | wasmoo_util pp + $ echo '(@if (= "a" "b" "c") (@then))' | wasm_of_ocaml pp File "-", line 1, characters 5-20: Syntax error. [1] Unicode escape sequences - $ echo '(@if (= "\u{1F600}" "b") (@then))' | wasmoo_util pp + $ echo '(@if (= "\u{1F600}" "b") (@then))' | wasm_of_ocaml pp - $ echo '(@if (= "\u{D800}" "b") (@then))' | wasmoo_util pp + $ echo '(@if (= "\u{D800}" "b") (@then))' | wasm_of_ocaml pp File "-", line 1, characters 8-18: Invalid Unicode escape sequences. [1] - $ echo '(@if (= "\u{110000}" "b") (@then))' | wasmoo_util pp + $ echo '(@if (= "\u{110000}" "b") (@then))' | wasm_of_ocaml pp File "-", line 1, characters 8-20: Invalid Unicode escape sequences. [1] Lonely @then or @else - $ echo '(@then)' | wasmoo_util pp + $ echo '(@then)' | wasm_of_ocaml pp File "-", line 1, characters 1-6: Unexpected @then clause. Maybe you forgot a parenthesis. [1] - $ echo '(@else)' | wasmoo_util pp + $ echo '(@else)' | wasm_of_ocaml pp File "-", line 1, characters 1-6: Unexpected @else clause. Maybe you forgot a parenthesis. [1] - $ echo '(@if (and) (@then (@else)))' | wasmoo_util pp + $ echo '(@if (and) (@then (@else)))' | wasm_of_ocaml pp File "-", line 1, characters 19-24: Unexpected @else clause. Maybe you forgot a parenthesis. [1] Undefined variable - $ echo '(@if a (@then))' | wasmoo_util pp + $ echo '(@if a (@then))' | wasm_of_ocaml pp File "-", line 1, characters 5-6: Unknown variable 'a'. [1] Wrong type - $ echo '(@if "" (@then))' | wasmoo_util pp + $ echo '(@if "" (@then))' | wasm_of_ocaml pp File "-", line 1, characters 5-7: Expected a boolean but this is a string. [1] - $ echo '(@if (not "") (@then))' | wasmoo_util pp + $ echo '(@if (not "") (@then))' | wasm_of_ocaml pp File "-", line 1, characters 10-12: Expected a boolean but this is a string. [1] - $ echo '(@if (and "") (@then))' | wasmoo_util pp + $ echo '(@if (and "") (@then))' | wasm_of_ocaml pp File "-", line 1, characters 10-12: Expected a boolean but this is a string. [1] - $ echo '(@if (or "") (@then))' | wasmoo_util pp + $ echo '(@if (or "") (@then))' | wasm_of_ocaml pp File "-", line 1, characters 9-11: Expected a boolean but this is a string. [1] - $ echo '(@if (= (and) "") (@then))' | wasmoo_util pp + $ echo '(@if (= (and) "") (@then))' | wasm_of_ocaml pp File "-", line 1, characters 14-16: Expected a boolean but this is a string. [1] Bad strings - $ echo '(@string)' | wasmoo_util pp + $ echo '(@string)' | wasm_of_ocaml pp File "-", line 1, characters 8-9: Expecting an id or a string. [1] - $ echo '(@string a "b")' | wasmoo_util pp + $ echo '(@string a "b")' | wasm_of_ocaml pp File "-", line 1, characters 9-10: Expecting an id [1] - $ echo '(@string $a b)' | wasmoo_util pp + $ echo '(@string $a b)' | wasm_of_ocaml pp File "-", line 1, characters 12-13: Expecting a string [1] - $ echo '(@string $good "\u{1F600}")' | wasmoo_util pp + $ echo '(@string $good "\u{1F600}")' | wasm_of_ocaml pp (global $good (ref eq) (array.new_fixed $bytes 4 (i32.const 240) (i32.const 159) (i32.const 152) (i32.const 128))) - $ echo '(@string $bad "\u{D800}")' | wasmoo_util pp + $ echo '(@string $bad "\u{D800}")' | wasm_of_ocaml pp File "-", line 1, characters 14-24: Invalid Unicode escape sequences. [1] - $ echo '(@string a)' | wasmoo_util pp + $ echo '(@string a)' | wasm_of_ocaml pp File "-", line 1, characters 9-10: Expecting a string [1] - $ echo '(@string a b c)' | wasmoo_util pp + $ echo '(@string a b c)' | wasm_of_ocaml pp File "-", line 1, characters 13-14: Expecting a closing parenthesis. [1] diff --git a/compiler/tests-wasm_of_ocaml/preprocess/dune b/compiler/tests-wasm_of_ocaml/preprocess/dune new file mode 100644 index 0000000000..bb37a89e75 --- /dev/null +++ b/compiler/tests-wasm_of_ocaml/preprocess/dune @@ -0,0 +1,21 @@ +(rule + (with-stdout-to + tests.output + (run + %{bin:wasm_of_ocaml} + pp + --enable + a + --disable + b + --set + c=1 + %{dep:tests.txt}))) + +(rule + (alias runtest) + (action + (diff tests.expected tests.output))) + +(cram + (deps %{bin:wasm_of_ocaml})) diff --git a/compiler/bin-wasmoo_util/tests/tests.expected b/compiler/tests-wasm_of_ocaml/preprocess/tests.expected similarity index 100% rename from compiler/bin-wasmoo_util/tests/tests.expected rename to compiler/tests-wasm_of_ocaml/preprocess/tests.expected diff --git a/compiler/bin-wasmoo_util/tests/tests.txt b/compiler/tests-wasm_of_ocaml/preprocess/tests.txt similarity index 100% rename from compiler/bin-wasmoo_util/tests/tests.txt rename to compiler/tests-wasm_of_ocaml/preprocess/tests.txt diff --git a/runtime/wasm/dune b/runtime/wasm/dune index c55cb470cd..0df18be889 100644 --- a/runtime/wasm/dune +++ b/runtime/wasm/dune @@ -10,8 +10,7 @@ (glob_files *.wat)) (action (run - wasmoo_util - link + ../../compiler/bin-wasm_of_ocaml/wasmoo_link_wasm.exe --binaryen=-g --binaryen-opt=-O3 %{target} From 285fea80849d3cf18891391825838e89ff466cf3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Tue, 4 Feb 2025 16:42:10 +0100 Subject: [PATCH 18/29] CHANGES.md --- CHANGES.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGES.md b/CHANGES.md index 443bd1d74d..d1f73325eb 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -2,6 +2,7 @@ ## Features/Changes * Runtime: support more Unix functions (#1829) +* Compiler: use a Wasm text files preprocessor (#1822) # 6.0.1 (2025-02-07) - Lille From 3cc68be6f8ba28a25e7aafb3a4451397eadfc399 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Tue, 17 Dec 2024 16:53:01 +0100 Subject: [PATCH 19/29] Support for several Wasm runtimes (depending on flags) The runtimes will either be precompiled for most common flag combinations, or compiled on the flight for unusual combinations. --- compiler/bin-wasm_of_ocaml/compile.ml | 33 +++++++++++++++- compiler/bin-wasm_of_ocaml/dune | 5 ++- compiler/bin-wasm_of_ocaml/gen/gen.ml | 56 +++++++++++++++++++++++++-- runtime/wasm/dune | 7 +++- 4 files changed, 91 insertions(+), 10 deletions(-) diff --git a/compiler/bin-wasm_of_ocaml/compile.ml b/compiler/bin-wasm_of_ocaml/compile.ml index 8b0f4a0f31..1d19b50c16 100644 --- a/compiler/bin-wasm_of_ocaml/compile.ml +++ b/compiler/bin-wasm_of_ocaml/compile.ml @@ -88,6 +88,35 @@ let with_runtime_files ~runtime_wasm_files f = in Wat_preprocess.with_preprocessed_files ~variables:[] ~inputs f +let build_runtime ~runtime_file = + (* Keep this variables in sync with gen/gen.ml *) + let variables = [] in + match + List.find_opt Runtime_files.precompiled_runtimes ~f:(fun (flags, _) -> + assert ( + List.length flags = List.length variables + && List.for_all2 ~f:(fun (k, _) (k', _) -> String.equal k k') flags variables); + Poly.equal flags variables) + with + | Some (_, contents) -> Fs.write_file ~name:runtime_file ~contents + | None -> + let inputs = + List.map + ~f:(fun (module_name, contents) -> + { Wat_preprocess.module_name + ; file = module_name ^ ".wat" + ; source = Contents contents + }) + Runtime_files.wat_files + in + Runtime.build + ~link_options:[ "-g" ] + ~opt_options:[ "-g"; "-O2" ] + ~variables: + (List.map ~f:(fun (k, v) : (_ * Wat_preprocess.value) -> k, Bool v) variables) + ~inputs + ~output_file:runtime_file + let link_and_optimize ~profile ~sourcemap_root @@ -106,7 +135,7 @@ let link_and_optimize let enable_source_maps = Option.is_some opt_sourcemap_file in Fs.with_intermediate_file (Filename.temp_file "runtime" ".wasm") @@ fun runtime_file -> - Fs.write_file ~name:runtime_file ~contents:Runtime_files.wasm_runtime; + build_runtime ~runtime_file; Fs.with_intermediate_file (Filename.temp_file "wasm-merged" ".wasm") @@ fun temp_file -> opt_with @@ -153,7 +182,7 @@ let link_and_optimize let link_runtime ~profile runtime_wasm_files output_file = Fs.with_intermediate_file (Filename.temp_file "runtime" ".wasm") @@ fun runtime_file -> - Fs.write_file ~name:runtime_file ~contents:Runtime_files.wasm_runtime; + build_runtime ~runtime_file; Fs.with_intermediate_file (Filename.temp_file "wasm-merged" ".wasm") @@ fun temp_file -> with_runtime_files ~runtime_wasm_files diff --git a/compiler/bin-wasm_of_ocaml/dune b/compiler/bin-wasm_of_ocaml/dune index 48619f0fe4..1870a60f7c 100644 --- a/compiler/bin-wasm_of_ocaml/dune +++ b/compiler/bin-wasm_of_ocaml/dune @@ -25,9 +25,10 @@ (target runtime_files.ml) (deps gen/gen.exe - ../../runtime/wasm/runtime.wasm ../../runtime/wasm/runtime.js - ../../runtime/wasm/deps.json) + ../../runtime/wasm/deps.json + (glob_files ../../runtime/wasm/*.wat) + (glob_files ../../runtime/wasm/runtime-*.wasm)) (action (with-stdout-to %{target} diff --git a/compiler/bin-wasm_of_ocaml/gen/gen.ml b/compiler/bin-wasm_of_ocaml/gen/gen.ml index b7a20c4e3e..c4e4e01469 100644 --- a/compiler/bin-wasm_of_ocaml/gen/gen.ml +++ b/compiler/bin-wasm_of_ocaml/gen/gen.ml @@ -1,13 +1,61 @@ let read_file ic = really_input_string ic (in_channel_length ic) +(* Keep the two variables below in sync with function build_runtime in + ../compile.ml *) + +let default_flags = [] + +let interesting_runtimes = [ [] ] + +let name_runtime l = + let flags = List.filter_map (fun (k, v) -> if v then Some k else None) l in + String.concat "-" ("runtime" :: (if flags = [] then [ "standard" ] else flags)) + ^ ".wasm" + +let print_flags f flags = + Format.fprintf + f + "@[<2>[ %a ]@]" + (Format.pp_print_list + ~pp_sep:(fun f () -> Format.fprintf f ";@ ") + (fun f (k, v) -> + Format.fprintf f "@[\"%s\",@ %s@]" k (if v then "true" else "false"))) + flags + let () = let () = set_binary_mode_out stdout true in Format.printf - "let wasm_runtime = \"%s\"@." + "let js_runtime = \"%s\"@." (String.escaped (read_file (open_in_bin Sys.argv.(1)))); Format.printf - "let js_runtime = \"%s\"@." + "let dependencies = \"%s\"@." (String.escaped (read_file (open_in_bin Sys.argv.(2)))); + let wat_files, runtimes = + List.partition + (fun f -> Filename.check_suffix f ".wat") + (Array.to_list (Array.sub Sys.argv 3 (Array.length Sys.argv - 3))) + in Format.printf - "let dependencies = \"%s\"@." - (String.escaped (read_file (open_in_bin Sys.argv.(3)))) + "let wat_files = [%a]@." + (Format.pp_print_list (fun f file -> + Format.fprintf + f + "\"%s\", \"%s\"; " + Filename.(chop_suffix (basename file) ".wat") + (String.escaped (read_file (open_in_bin file))))) + wat_files; + Format.printf + "let precompiled_runtimes = [%a]@." + (Format.pp_print_list (fun f flags -> + let flags = flags @ default_flags in + let name = name_runtime flags in + match List.find_opt (fun file -> Filename.basename file = name) runtimes with + | None -> failwith ("Missing runtime " ^ name) + | Some file -> + Format.fprintf + f + "%a, \"%s\"; " + print_flags + flags + (String.escaped (read_file (open_in_bin file))))) + interesting_runtimes diff --git a/runtime/wasm/dune b/runtime/wasm/dune index 0df18be889..ddbdf30bb8 100644 --- a/runtime/wasm/dune +++ b/runtime/wasm/dune @@ -1,10 +1,13 @@ (install (section lib) (package wasm_of_ocaml-compiler) - (files runtime.wasm runtime.js)) + (files + (glob_files *.wat) + (glob_files runtime-*.wasm) + runtime.js)) (rule - (target runtime.wasm) + (target runtime-standard.wasm) (deps args (glob_files *.wat)) From 11a8b7763443df3b58fabf5fd19752827d74988a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Wed, 19 Feb 2025 11:46:44 +0100 Subject: [PATCH 20/29] Runtimes: add primitive caml_throw_js_exception To remove any dependency of Jsoo_runtime on JavaScript. --- lib/runtime/js_of_ocaml_runtime_stubs.c | 4 ++++ lib/runtime/jsoo_runtime.ml | 2 +- runtime/js/jslib.js | 5 +++++ runtime/wasm/jslib.wat | 7 +++++++ 4 files changed, 17 insertions(+), 1 deletion(-) diff --git a/lib/runtime/js_of_ocaml_runtime_stubs.c b/lib/runtime/js_of_ocaml_runtime_stubs.c index 4e9ad9bd29..44ea7ecb8a 100644 --- a/lib/runtime/js_of_ocaml_runtime_stubs.c +++ b/lib/runtime/js_of_ocaml_runtime_stubs.c @@ -272,6 +272,10 @@ void caml_string_of_uint8_array () { caml_fatal_error("Unimplemented Javascript primitive caml_string_of_uint8_array!"); } +void caml_throw_js_exception () { + caml_fatal_error("Unimplemented Javascript primitive caml_throw_js_exception!"); +} + void caml_unmount () { caml_fatal_error("Unimplemented Javascript primitive caml_unmount!"); } diff --git a/lib/runtime/jsoo_runtime.ml b/lib/runtime/jsoo_runtime.ml index c69b5b4937..4dee5f64a9 100644 --- a/lib/runtime/jsoo_runtime.ml +++ b/lib/runtime/jsoo_runtime.ml @@ -177,7 +177,7 @@ end = struct let _ = Callback.register_exception "jsError" (Exn (Obj.magic [||])) - let raise_ : t -> 'a = Js.js_expr "(function (exn) { throw exn })" + external raise_ : t -> 'a = "caml_throw_js_exception" external of_exn : exn -> t option = "caml_js_error_option_of_exception" diff --git a/runtime/js/jslib.js b/runtime/js/jslib.js index 8b974912d4..6f538410f7 100644 --- a/runtime/js/jslib.js +++ b/runtime/js/jslib.js @@ -203,6 +203,11 @@ function caml_js_error_option_of_exception(exn) { return 0; } +//Provides: caml_throw_js_exception +function caml_throw_js_exception(exn) { + throw exn; +} + //Provides: caml_js_from_bool const (const) function caml_js_from_bool(x) { return !!x; diff --git a/runtime/wasm/jslib.wat b/runtime/wasm/jslib.wat index 689853a2b3..9ac0c66f7f 100644 --- a/runtime/wasm/jslib.wat +++ b/runtime/wasm/jslib.wat @@ -75,6 +75,8 @@ (func $wrap_fun_arguments (param anyref) (result anyref))) (import "fail" "caml_failwith_tag" (func $caml_failwith_tag (result (ref eq)))) + (import "fail" "javascript_exception" + (tag $javascript_exception (param externref))) (import "stdlib" "caml_named_value" (func $caml_named_value (param (ref eq)) (result (ref null eq)))) (import "obj" "caml_callback_1" @@ -666,6 +668,11 @@ (array.get $block (local.get $exn) (i32.const 2)))))))) (ref.i31 (i32.const 0))) + (func (export "caml_throw_js_exception") + (param $exn (ref eq)) (result (ref eq)) + (throw $javascript_exception + (extern.convert_any (call $unwrap (local.get $exn))))) + (func (export "caml_js_error_of_exception") (param (ref eq)) (result (ref eq)) (local $exn (ref $block)) From 682eb701265514464d0d4d9b71e41ce2bf168b37 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Tue, 17 Dec 2024 16:53:01 +0100 Subject: [PATCH 21/29] WASI runtime --- compiler/bin-wasm_of_ocaml/compile.ml | 19 +- compiler/bin-wasm_of_ocaml/dune | 3 + compiler/bin-wasm_of_ocaml/gen/gen.ml | 15 +- compiler/lib-wasm/binaryen.ml | 1 + compiler/lib-wasm/gc_target.ml | 65 +- compiler/lib/config.ml | 2 + compiler/lib/config.mli | 2 + compiler/lib/inline.ml | 2 +- compiler/tests-jsoo/dune | 23 + .../lib-effects/assume_no_perform.ml | 2 +- .../assume_no_perform_nested_handler.ml | 2 +- .../assume_no_perform_unhandled.ml | 2 +- compiler/tests-jsoo/lib-effects/dune | 8 +- compiler/tests-jsoo/test_unix.ml | 79 - compiler/tests-jsoo/test_unix_perms.ml | 78 + compiler/tests-ocaml/basic-io-2/dune | 3 + compiler/tests-ocaml/effect-syntax/dune | 4 + compiler/tests-ocaml/effects/dune | 4 + compiler/tests-ocaml/lib-channels/close_in.ml | 10 +- compiler/tests-ocaml/lib-marshal/intext.ml | 3 +- .../tests-ocaml/lib-marshal/intext_par.ml | 3 +- compiler/tests-ocaml/lib-unix/isatty/dune | 5 +- dune | 8 + lib/deriving_json/tests/dune | 2 + lib/tests/dune.inc | 20 +- lib/tests/gen-rules/gen.ml | 3 +- runtime/wasm/bigarray.wat | 547 ++++++- runtime/wasm/bigstring.wat | 29 + runtime/wasm/compare.wat | 3 + runtime/wasm/deps-wasi.json | 15 + runtime/wasm/dune | 50 + runtime/wasm/effect.wat | 72 +- runtime/wasm/fail.wat | 6 + runtime/wasm/float.wat | 86 + runtime/wasm/fs.wat | 614 +++++++- runtime/wasm/hash.wat | 3 + runtime/wasm/io.wat | 503 +++++- runtime/wasm/jslib.wat | 3 + runtime/wasm/jslib_js_of_ocaml.wat | 3 + runtime/wasm/jsstring.wat | 3 + runtime/wasm/libc.c | 175 +++ runtime/wasm/libc.wasm | Bin 0 -> 63480 bytes runtime/wasm/marshal.wat | 76 +- runtime/wasm/prng.wat | 10 + runtime/wasm/runtime-wasi.js | 84 + runtime/wasm/stdlib.wat | 82 +- runtime/wasm/sys.wat | 313 +++- runtime/wasm/unix.wat | 1397 ++++++++++++++++- runtime/wasm/wasi_errors.wat | 86 + runtime/wasm/wasi_memory.wat | 98 ++ runtime/wasm/weak.wat | 27 +- 51 files changed, 4336 insertions(+), 317 deletions(-) create mode 100644 compiler/tests-jsoo/test_unix_perms.ml create mode 100644 runtime/wasm/deps-wasi.json create mode 100644 runtime/wasm/libc.c create mode 100644 runtime/wasm/libc.wasm create mode 100644 runtime/wasm/runtime-wasi.js create mode 100644 runtime/wasm/wasi_errors.wat create mode 100644 runtime/wasm/wasi_memory.wat diff --git a/compiler/bin-wasm_of_ocaml/compile.ml b/compiler/bin-wasm_of_ocaml/compile.ml index 1d19b50c16..09c7e66dc4 100644 --- a/compiler/bin-wasm_of_ocaml/compile.ml +++ b/compiler/bin-wasm_of_ocaml/compile.ml @@ -90,7 +90,7 @@ let with_runtime_files ~runtime_wasm_files f = let build_runtime ~runtime_file = (* Keep this variables in sync with gen/gen.ml *) - let variables = [] in + let variables = [ "wasi", Config.Flag.wasi () ] in match List.find_opt Runtime_files.precompiled_runtimes ~f:(fun (flags, _) -> assert ( @@ -107,7 +107,9 @@ let build_runtime ~runtime_file = ; file = module_name ^ ".wat" ; source = Contents contents }) - Runtime_files.wat_files + (if Config.Flag.wasi () + then ("libc", Runtime_files.wasi_libc) :: Runtime_files.wat_files + else Runtime_files.wat_files) in Runtime.build ~link_options:[ "-g" ] @@ -161,7 +163,10 @@ let link_and_optimize @@ fun opt_temp_sourcemap' -> let primitives = Binaryen.dead_code_elimination - ~dependencies:Runtime_files.dependencies + ~dependencies: + (if Config.Flag.wasi () + then Runtime_files.wasi_dependencies + else Runtime_files.dependencies) ~opt_input_sourcemap:opt_temp_sourcemap ~opt_output_sourcemap:opt_temp_sourcemap' ~input_file:temp_file @@ -269,7 +274,13 @@ let build_js_runtime ~primitives ?runtime_arguments () = in let prelude = Link.output_js always_required_js in let init_fun = - match Parse_js.parse (Parse_js.Lexer.of_string Runtime_files.js_runtime) with + match + Parse_js.parse + (Parse_js.Lexer.of_string + (if Config.Flag.wasi () + then Runtime_files.js_wasi_launcher + else Runtime_files.js_launcher)) + with | [ (Expression_statement f, _) ] -> f | _ -> assert false in diff --git a/compiler/bin-wasm_of_ocaml/dune b/compiler/bin-wasm_of_ocaml/dune index 1870a60f7c..024b987d36 100644 --- a/compiler/bin-wasm_of_ocaml/dune +++ b/compiler/bin-wasm_of_ocaml/dune @@ -27,6 +27,9 @@ gen/gen.exe ../../runtime/wasm/runtime.js ../../runtime/wasm/deps.json + ../../runtime/wasm/runtime-wasi.js + ../../runtime/wasm/deps-wasi.json + ../../runtime/wasm/libc.wasm (glob_files ../../runtime/wasm/*.wat) (glob_files ../../runtime/wasm/runtime-*.wasm)) (action diff --git a/compiler/bin-wasm_of_ocaml/gen/gen.ml b/compiler/bin-wasm_of_ocaml/gen/gen.ml index c4e4e01469..9aa293250c 100644 --- a/compiler/bin-wasm_of_ocaml/gen/gen.ml +++ b/compiler/bin-wasm_of_ocaml/gen/gen.ml @@ -5,7 +5,7 @@ let read_file ic = really_input_string ic (in_channel_length ic) let default_flags = [] -let interesting_runtimes = [ [] ] +let interesting_runtimes = [ [ "wasi", false ]; [ "wasi", true ] ] let name_runtime l = let flags = List.filter_map (fun (k, v) -> if v then Some k else None) l in @@ -25,15 +25,24 @@ let print_flags f flags = let () = let () = set_binary_mode_out stdout true in Format.printf - "let js_runtime = \"%s\"@." + "let js_launcher = \"%s\"@." (String.escaped (read_file (open_in_bin Sys.argv.(1)))); Format.printf "let dependencies = \"%s\"@." (String.escaped (read_file (open_in_bin Sys.argv.(2)))); + Format.printf + "let js_wasi_launcher = \"%s\"@." + (String.escaped (read_file (open_in_bin Sys.argv.(3)))); + Format.printf + "let wasi_dependencies = \"%s\"@." + (String.escaped (read_file (open_in_bin Sys.argv.(4)))); + Format.printf + "let wasi_libc = \"%s\"@." + (String.escaped (read_file (open_in_bin Sys.argv.(5)))); let wat_files, runtimes = List.partition (fun f -> Filename.check_suffix f ".wat") - (Array.to_list (Array.sub Sys.argv 3 (Array.length Sys.argv - 3))) + (Array.to_list (Array.sub Sys.argv 6 (Array.length Sys.argv - 6))) in Format.printf "let wat_files = [%a]@." diff --git a/compiler/lib-wasm/binaryen.ml b/compiler/lib-wasm/binaryen.ml index f0a6679e83..581c6d6939 100644 --- a/compiler/lib-wasm/binaryen.ml +++ b/compiler/lib-wasm/binaryen.ml @@ -36,6 +36,7 @@ let common_options () = ; "--enable-bulk-memory" ; "--enable-nontrapping-float-to-int" ; "--enable-strings" + ; "--enable-multimemory" (* To keep wasm-merge happy *) ] in if Config.Flag.pretty () then "-g" :: l else l diff --git a/compiler/lib-wasm/gc_target.ml b/compiler/lib-wasm/gc_target.ml index 7a1bd27867..cda5f4a92c 100644 --- a/compiler/lib-wasm/gc_target.ml +++ b/compiler/lib-wasm/gc_target.ml @@ -573,9 +573,13 @@ module Value = struct return ()) (val_int (if negate then Arith.eqz n else n)) - let eq x y = eq_gen ~negate:false x y + let eq x y = + if Config.Flag.wasi () then val_int (ref_eq x y) else eq_gen ~negate:false x y - let neq x y = eq_gen ~negate:true x y + let neq x y = + if Config.Flag.wasi () + then val_int (Arith.eqz (ref_eq x y)) + else eq_gen ~negate:true x y let ult = binop Arith.(ult) @@ -1294,7 +1298,12 @@ module Math = struct { W.params = List.init ~len:n ~f:(fun _ : W.value_type -> F64); result = [ F64 ] } let unary name x = - let* f = register_import ~import_module:"Math" ~name (Fun (float_func_type 1)) in + let* f = + register_import + ~import_module:(if Config.Flag.wasi () then "env" else "Math") + ~name + (Fun (float_func_type 1)) + in let* x = x in return (W.Call (f, [ x ])) @@ -1337,7 +1346,12 @@ module Math = struct let log10 f = unary "log10" f let binary name x y = - let* f = register_import ~import_module:"Math" ~name (Fun (float_func_type 2)) in + let* f = + register_import + ~import_module:(if Config.Flag.wasi () then "env" else "Math") + ~name + (Fun (float_func_type 2)) + in let* x = x in let* y = y in return (W.Call (f, [ x; y ])) @@ -1676,21 +1690,34 @@ let handle_exceptions ~result_typ ~fall_through ~context body x exn_handler = x (block_expr { params = []; result = [ Value.value ] } - (let* exn = - block_expr - { params = []; result = [ externref ] } - (let* e = - try_expr - { params = []; result = [ externref ] } - (body - ~result_typ:[ externref ] - ~fall_through:`Skip - ~context:(`Skip :: `Skip :: `Catch :: context)) - [ ocaml_tag, 1, Value.value; js_tag, 0, externref ] - in - instr (W.Push e)) - in - instr (W.CallInstr (f, [ exn ])))) + (if Config.Flag.wasi () + then + let* e = + try_expr + { params = []; result = [ Value.value ] } + (body + ~result_typ:[ Value.value ] + ~fall_through:`Skip + ~context:(`Skip :: `Catch :: context)) + [ ocaml_tag, 0, Value.value ] + in + instr (W.Push e) + else + let* exn = + block_expr + { params = []; result = [ externref ] } + (let* e = + try_expr + { params = []; result = [ externref ] } + (body + ~result_typ:[ externref ] + ~fall_through:`Skip + ~context:(`Skip :: `Skip :: `Catch :: context)) + [ ocaml_tag, 1, Value.value; js_tag, 0, externref ] + in + instr (W.Push e)) + in + instr (W.CallInstr (f, [ exn ])))) in let* () = no_event in exn_handler ~result_typ ~fall_through ~context) diff --git a/compiler/lib/config.ml b/compiler/lib/config.ml index 3e662dd517..28031afa8f 100644 --- a/compiler/lib/config.ml +++ b/compiler/lib/config.ml @@ -101,6 +101,8 @@ module Flag = struct let auto_link = o ~name:"auto-link" ~default:true let es6 = o ~name:"es6" ~default:false + + let wasi = o ~name:"wasi" ~default:false end module Param = struct diff --git a/compiler/lib/config.mli b/compiler/lib/config.mli index 71642430bf..a4f7a5538f 100644 --- a/compiler/lib/config.mli +++ b/compiler/lib/config.mli @@ -76,6 +76,8 @@ module Flag : sig val es6 : unit -> bool + val wasi : unit -> bool + val enable : string -> unit val disable : string -> unit diff --git a/compiler/lib/inline.ml b/compiler/lib/inline.ml index 2637480062..ec5b70b6f8 100644 --- a/compiler/lib/inline.ml +++ b/compiler/lib/inline.ml @@ -328,7 +328,7 @@ let inline ~first_class_primitives live_vars closures name pc (outer, p) = let times = Debug.find "times" -let f p live_vars = +let f p (live_vars : Deadcode.variable_uses) = let first_class_primitives = match Config.target (), Config.effects () with | `JavaScript, `Disabled -> true diff --git a/compiler/tests-jsoo/dune b/compiler/tests-jsoo/dune index 7ccd92ca4e..2a89e85128 100644 --- a/compiler/tests-jsoo/dune +++ b/compiler/tests-jsoo/dune @@ -11,6 +11,8 @@ (enabled_if (>= %{ocaml_version} 4.14)) (inline_tests + (deps + (sandbox preserve_file_kind)) (modes js wasm best)) (preprocess (pps ppx_expect))) @@ -22,6 +24,8 @@ (enabled_if (>= %{ocaml_version} 5.1.1)) (inline_tests + (deps + (sandbox preserve_file_kind)) (modes js wasm best)) (preprocess (pps ppx_expect))) @@ -33,6 +37,22 @@ (enabled_if (>= %{ocaml_version} 5.1.1)) (inline_tests + (deps + (sandbox preserve_file_kind)) + (modes js wasm best)) + (preprocess + (pps ppx_expect))) + +(library + (name jsoo_testsuite_perms) + (modules test_unix_perms) + (libraries unix) + ;; WASI has no notion of file permissions (it uses capabilities instead) + (enabled_if + (<> %{profile} wasi)) + (inline_tests + (deps + (sandbox preserve_file_kind)) (modes js wasm best)) (preprocess (pps ppx_expect))) @@ -47,6 +67,7 @@ test_float16 test_marshal_compressed test_parsing + test_unix_perms calc_parser calc_lexer)) (libraries unix compiler-libs.common js_of_ocaml-compiler) @@ -54,6 +75,8 @@ (language c) (names bigarray_stubs)) (inline_tests + (deps + (sandbox preserve_file_kind)) (modes js wasm best)) (preprocess (pps ppx_expect))) diff --git a/compiler/tests-jsoo/lib-effects/assume_no_perform.ml b/compiler/tests-jsoo/lib-effects/assume_no_perform.ml index e655c33c4c..aca8728f15 100644 --- a/compiler/tests-jsoo/lib-effects/assume_no_perform.ml +++ b/compiler/tests-jsoo/lib-effects/assume_no_perform.ml @@ -125,7 +125,7 @@ let () = (* The code below should be called in direct style despite the installed effect handler *) - Js_of_ocaml.Effect_js.assume_no_perform (fun () -> + Jsoo_runtime.Effect.assume_no_perform (fun () -> let m, sd = benchmark iter_fun 5 in let () = printf "Iter: mean = %f, sd = %f\n%!" m sd in diff --git a/compiler/tests-jsoo/lib-effects/assume_no_perform_nested_handler.ml b/compiler/tests-jsoo/lib-effects/assume_no_perform_nested_handler.ml index c164b5462e..fc771da918 100644 --- a/compiler/tests-jsoo/lib-effects/assume_no_perform_nested_handler.ml +++ b/compiler/tests-jsoo/lib-effects/assume_no_perform_nested_handler.ml @@ -6,7 +6,7 @@ type _ Effect.t += Dummy : unit t let () = try_with (fun () -> - Js_of_ocaml.Effect_js.assume_no_perform (fun () -> + Jsoo_runtime.Effect.assume_no_perform (fun () -> try_with (fun () -> ()) () { effc = (fun (type a) (_ : a Effect.t) -> None) }); perform Dummy) () diff --git a/compiler/tests-jsoo/lib-effects/assume_no_perform_unhandled.ml b/compiler/tests-jsoo/lib-effects/assume_no_perform_unhandled.ml index ad055ac3a9..6d0516436a 100644 --- a/compiler/tests-jsoo/lib-effects/assume_no_perform_unhandled.ml +++ b/compiler/tests-jsoo/lib-effects/assume_no_perform_unhandled.ml @@ -6,7 +6,7 @@ type _ Effect.t += Dummy : unit t let must_raise () = try_with (fun () -> - Js_of_ocaml.Effect_js.assume_no_perform (fun () -> + Jsoo_runtime.Effect.assume_no_perform (fun () -> (* Should raise [Effect.Unhandled] despite the installed handler *) perform Dummy)) () diff --git a/compiler/tests-jsoo/lib-effects/dune b/compiler/tests-jsoo/lib-effects/dune index d3ca13c41f..113ee4a090 100644 --- a/compiler/tests-jsoo/lib-effects/dune +++ b/compiler/tests-jsoo/lib-effects/dune @@ -1,6 +1,10 @@ (env (with-effects-double-translation) (with-effects) + (wasi + (wasm_of_ocaml + (flags + (:standard --enable effects)))) (_ (js_of_ocaml (flags @@ -11,6 +15,8 @@ (enabled_if (>= %{ocaml_version} 5)) (inline_tests + (deps + (sandbox preserve_file_kind)) (modes js wasm best)) (modules (:standard @@ -41,7 +47,7 @@ assume_no_perform assume_no_perform_unhandled assume_no_perform_nested_handler) - (libraries js_of_ocaml) + (libraries jsoo_runtime) (action (ignore-outputs (with-accepted-exit-codes diff --git a/compiler/tests-jsoo/test_unix.ml b/compiler/tests-jsoo/test_unix.ml index aa25c0baad..3546260463 100644 --- a/compiler/tests-jsoo/test_unix.ml +++ b/compiler/tests-jsoo/test_unix.ml @@ -14,85 +14,6 @@ let%expect_test "Unix.times" = then Printf.printf "OK\n"; [%expect {| OK |}] -let on_windows = Sys.os_type = "Win32" - -let%expect_test "Unix.chmod / Unix.fchmod / Unix.access" = - let tmp = Filename.temp_file "a" "txt" in - let test ?(ok_on_windows = false) flags = - try - Unix.access tmp flags; - if on_windows && ok_on_windows - then Printf.printf "denied (success on Windows)\n" - else Printf.printf "success\n" - with - | Unix.Unix_error ((EPERM | EACCES), _, _) -> - if (not on_windows) && ok_on_windows - then Printf.printf "denied (success on Windows)\n" - else Printf.printf "denied\n" - | Unix.Unix_error (ENOENT, _, _) -> Printf.printf "absent\n" - in - let touch perms = - Unix.chmod tmp 0o600; - Unix.unlink tmp; - let fd = Unix.openfile tmp [ O_WRONLY; O_CREAT; O_TRUNC ] perms in - Unix.close fd - in - let test_perms set = - set 0o200; - test ~ok_on_windows:true [ R_OK ]; - test [ W_OK ]; - test ~ok_on_windows:true [ R_OK; W_OK ]; - [%expect - {| - denied (success on Windows) - success - denied (success on Windows) - |}]; - set 0o400; - test [ R_OK ]; - test [ W_OK ]; - test [ R_OK; W_OK ]; - [%expect {| - success - denied - denied |}]; - set 0o600; - test [ R_OK ]; - test [ W_OK ]; - test [ R_OK; W_OK ]; - [%expect {| - success - success - success |}]; - set 0o000; - test ~ok_on_windows:true [ R_OK ]; - test [ W_OK ]; - test [ R_OK; W_OK ]; - [%expect {| - denied (success on Windows) - denied - denied - |}] - in - test [ F_OK ]; - [%expect {| - success |}]; - Unix.chmod tmp 0o600; - Unix.unlink tmp; - test [ F_OK ]; - [%expect {| - absent |}]; - let fd = Unix.openfile tmp [ O_WRONLY; O_CREAT; O_TRUNC ] 0o666 in - test [ F_OK ]; - [%expect {| - success |}]; - if not on_windows then test_perms (Unix.fchmod fd); - Unix.close fd; - test_perms (Unix.chmod tmp); - test_perms touch; - Unix.chmod tmp 0o600; - Unix.unlink tmp - let%expect_test "Unix.link" = let tmp = Filename.temp_file "a" "txt" in let ch = open_out tmp in diff --git a/compiler/tests-jsoo/test_unix_perms.ml b/compiler/tests-jsoo/test_unix_perms.ml new file mode 100644 index 0000000000..8f07952db9 --- /dev/null +++ b/compiler/tests-jsoo/test_unix_perms.ml @@ -0,0 +1,78 @@ +let on_windows = Sys.os_type = "Win32" + +let%expect_test "Unix.chmod / Unix.fchmod / Unix.access" = + let tmp = Filename.temp_file "a" "txt" in + let test ?(ok_on_windows = false) flags = + try + Unix.access tmp flags; + if on_windows && ok_on_windows + then Printf.printf "denied (success on Windows)\n" + else Printf.printf "success\n" + with + | Unix.Unix_error ((EPERM | EACCES), _, _) -> + if (not on_windows) && ok_on_windows + then Printf.printf "denied (success on Windows)\n" + else Printf.printf "denied\n" + | Unix.Unix_error (ENOENT, _, _) -> Printf.printf "absent\n" + in + let touch perms = + Unix.chmod tmp 0o600; + Unix.unlink tmp; + let fd = Unix.openfile tmp [ O_WRONLY; O_CREAT; O_TRUNC ] perms in + Unix.close fd + in + let test_perms set = + set 0o200; + test ~ok_on_windows:true [ R_OK ]; + test [ W_OK ]; + test ~ok_on_windows:true [ R_OK; W_OK ]; + [%expect + {| + denied (success on Windows) + success + denied (success on Windows) + |}]; + set 0o400; + test [ R_OK ]; + test [ W_OK ]; + test [ R_OK; W_OK ]; + [%expect {| + success + denied + denied |}]; + set 0o600; + test [ R_OK ]; + test [ W_OK ]; + test [ R_OK; W_OK ]; + [%expect {| + success + success + success |}]; + set 0o000; + test ~ok_on_windows:true [ R_OK ]; + test [ W_OK ]; + test [ R_OK; W_OK ]; + [%expect {| + denied (success on Windows) + denied + denied + |}] + in + test [ F_OK ]; + [%expect {| + success |}]; + Unix.chmod tmp 0o600; + Unix.unlink tmp; + test [ F_OK ]; + [%expect {| + absent |}]; + let fd = Unix.openfile tmp [ O_WRONLY; O_CREAT; O_TRUNC ] 0o666 in + test [ F_OK ]; + [%expect {| + success |}]; + if not on_windows then test_perms (Unix.fchmod fd); + Unix.close fd; + test_perms (Unix.chmod tmp); + test_perms touch; + Unix.chmod tmp 0o600; + Unix.unlink tmp diff --git a/compiler/tests-ocaml/basic-io-2/dune b/compiler/tests-ocaml/basic-io-2/dune index 121f745198..e666404c1f 100644 --- a/compiler/tests-ocaml/basic-io-2/dune +++ b/compiler/tests-ocaml/basic-io-2/dune @@ -1,5 +1,8 @@ (tests (names io) (modes js wasm) + ;; Sys.command not available + (enabled_if + (<> %{profile} wasi)) (action (run node %{test} %{dep:test-file-short-lines}))) diff --git a/compiler/tests-ocaml/effect-syntax/dune b/compiler/tests-ocaml/effect-syntax/dune index 22b9fdf7e4..6b08c88e72 100644 --- a/compiler/tests-ocaml/effect-syntax/dune +++ b/compiler/tests-ocaml/effect-syntax/dune @@ -1,6 +1,10 @@ (env (with-effects-double-translation) (with-effects) + (wasi + (wasm_of_ocaml + (flags + (:standard --enable=effects)))) (_ (js_of_ocaml (flags diff --git a/compiler/tests-ocaml/effects/dune b/compiler/tests-ocaml/effects/dune index 019935b596..d832b983a7 100644 --- a/compiler/tests-ocaml/effects/dune +++ b/compiler/tests-ocaml/effects/dune @@ -1,6 +1,10 @@ (env (with-effects-double-translation) (with-effects) + (wasi + (wasm_of_ocaml + (flags + (:standard --enable=effects)))) (_ (js_of_ocaml (flags diff --git a/compiler/tests-ocaml/lib-channels/close_in.ml b/compiler/tests-ocaml/lib-channels/close_in.ml index 9b3717362a..8697d78c6a 100644 --- a/compiler/tests-ocaml/lib-channels/close_in.ml +++ b/compiler/tests-ocaml/lib-channels/close_in.ml @@ -6,8 +6,14 @@ between 1 and IO_BUFFER_SIZE *) let nb_bytes = 3 +let temp_file = + let name, ch = Filename.open_temp_file "data" ".txt" in + output_string ch (String.make 1024 'a'); + close_out ch; + name + let () = - let ic = open_in_bin (Filename.basename Sys.argv.(0)) in + let ic = open_in_bin temp_file in seek_in ic nb_bytes; close_in ic; assert ( @@ -21,7 +27,7 @@ let () = (* A variant of #11878, which #11965 failed to fix. *) let () = - let ic = open_in_bin (Filename.basename Sys.argv.(0)) in + let ic = open_in_bin temp_file in close_in ic; begin try seek_in ic (-1); diff --git a/compiler/tests-ocaml/lib-marshal/intext.ml b/compiler/tests-ocaml/lib-marshal/intext.ml index 3e0477dffd..5340806495 100644 --- a/compiler/tests-ocaml/lib-marshal/intext.ml +++ b/compiler/tests-ocaml/lib-marshal/intext.ml @@ -4,7 +4,8 @@ (* Test for output_value / input_value *) -let max_data_depth = 500000 +let max_data_depth = 10000 +(* Reduced since we use a quadratic algorithm for sharing in the WASI runtime *) type t = A | B of int | C of float | D of string | E of char | F of t | G of t * t | H of int * t | I of t * float | J diff --git a/compiler/tests-ocaml/lib-marshal/intext_par.ml b/compiler/tests-ocaml/lib-marshal/intext_par.ml index f93c55c685..fbf0a8dec9 100644 --- a/compiler/tests-ocaml/lib-marshal/intext_par.ml +++ b/compiler/tests-ocaml/lib-marshal/intext_par.ml @@ -17,7 +17,8 @@ let test_size = let num_domains = 1 lsl test_size -let max_data_depth = 500000 +let max_data_depth = 10000 +(* Reduced since we use a quadratic algorithm for sharing in the WASI runtime *) type t = A | B of int | C of float | D of string | E of char | F of t | G of t * t | H of int * t | I of t * float | J diff --git a/compiler/tests-ocaml/lib-unix/isatty/dune b/compiler/tests-ocaml/lib-unix/isatty/dune index 6740efe55b..852dd49d6a 100644 --- a/compiler/tests-ocaml/lib-unix/isatty/dune +++ b/compiler/tests-ocaml/lib-unix/isatty/dune @@ -6,7 +6,10 @@ (tests (names isatty_tty) (enabled_if - (not %{env:CI=false})) + (and + (<> %{profile} wasi) + (not %{env:CI=false}))) + ; WASI has no notion of tty ; isatty_tty does not work on the CI since we are not running in a tty there (libraries ocaml_testing unix) (modes js wasm)) diff --git a/dune b/dune index a4064b14a9..150a7dacbd 100644 --- a/dune +++ b/dune @@ -30,6 +30,14 @@ (binaries (tools/node_wrapper.exe as node) (tools/node_wrapper.exe as node.exe))) + (wasi + (wasm_of_ocaml + (flags + (:standard --pretty --enable wasi)) + (compilation_mode whole_program)) + (binaries + (tools/node_wrapper.exe as node) + (tools/node_wrapper.exe as node.exe))) (bench_no_debug (flags (:standard \ -g)) diff --git a/lib/deriving_json/tests/dune b/lib/deriving_json/tests/dune index c1e0147b3d..b7772e347e 100644 --- a/lib/deriving_json/tests/dune +++ b/lib/deriving_json/tests/dune @@ -2,6 +2,8 @@ (name deriving_expect_tests) (libraries unix js_of_ocaml js_of_ocaml.deriving) (inline_tests + (enabled_if + (<> %{profile} wasi)) (modes js wasm)) (preprocess (pps ppx_expect ppx_deriving_json))) diff --git a/lib/tests/dune.inc b/lib/tests/dune.inc index 85b9beb929..723489479a 100644 --- a/lib/tests/dune.inc +++ b/lib/tests/dune.inc @@ -2,7 +2,7 @@ (library ;; lib/tests/test_css_angle.ml (name test_css_angle_75) - (enabled_if true) + (enabled_if (<> %{profile} wasi)) (modules test_css_angle) (libraries js_of_ocaml unix) (inline_tests (modes js wasm)) @@ -12,7 +12,7 @@ (library ;; lib/tests/test_css_color.ml (name test_css_color_75) - (enabled_if true) + (enabled_if (<> %{profile} wasi)) (modules test_css_color) (libraries js_of_ocaml unix) (inline_tests (modes js wasm)) @@ -22,7 +22,7 @@ (library ;; lib/tests/test_css_length.ml (name test_css_length_75) - (enabled_if true) + (enabled_if (<> %{profile} wasi)) (modules test_css_length) (libraries js_of_ocaml unix) (inline_tests (modes js wasm)) @@ -42,7 +42,7 @@ (library ;; lib/tests/test_fun_call_2.ml (name test_fun_call_2_75) - (enabled_if true) + (enabled_if (<> %{profile} wasi)) (modules test_fun_call_2) (libraries js_of_ocaml unix) (inline_tests (modes js wasm)) @@ -62,7 +62,7 @@ (library ;; lib/tests/test_nodejs_filesystem_errors.ml (name test_nodejs_filesystem_errors_75) - (enabled_if true) + (enabled_if (<> %{profile} wasi)) (modules test_nodejs_filesystem_errors) (libraries js_of_ocaml unix) (inline_tests (modes js wasm)) @@ -82,7 +82,7 @@ (library ;; lib/tests/test_poly_equal.ml (name test_poly_equal_75) - (enabled_if true) + (enabled_if (<> %{profile} wasi)) (modules test_poly_equal) (libraries js_of_ocaml unix) (inline_tests (modes js wasm)) @@ -92,7 +92,7 @@ (library ;; lib/tests/test_regexp.ml (name test_regexp_75) - (enabled_if true) + (enabled_if (<> %{profile} wasi)) (modules test_regexp) (libraries js_of_ocaml unix) (inline_tests (modes js wasm)) @@ -112,7 +112,7 @@ (library ;; lib/tests/test_typed_array.ml (name test_typed_array_75) - (enabled_if true) + (enabled_if (<> %{profile} wasi)) (modules test_typed_array) (libraries js_of_ocaml unix) (inline_tests (modes js wasm)) @@ -122,7 +122,7 @@ (library ;; lib/tests/test_unsafe_set_get.ml (name test_unsafe_set_get_75) - (enabled_if true) + (enabled_if (<> %{profile} wasi)) (modules test_unsafe_set_get) (libraries js_of_ocaml unix) (inline_tests (modes js wasm)) @@ -132,7 +132,7 @@ (library ;; lib/tests/test_url.ml (name test_url_75) - (enabled_if true) + (enabled_if (<> %{profile} wasi)) (modules test_url) (libraries js_of_ocaml unix) (inline_tests (modes js wasm)) diff --git a/lib/tests/gen-rules/gen.ml b/lib/tests/gen-rules/gen.ml index 980e2f0cc8..6c6dab4671 100644 --- a/lib/tests/gen-rules/gen.ml +++ b/lib/tests/gen-rules/gen.ml @@ -81,7 +81,8 @@ let () = basename (Hashtbl.hash prefix mod 100) (match enabled_if basename with - | Any | Not_wasm -> "true" + | Any -> "(<> %{profile} wasi)" + | Not_wasm -> "true" | GE5 -> "(>= %{ocaml_version} 5)" | No_effects_not_wasm -> "(<> %{profile} with-effects)") basename diff --git a/runtime/wasm/bigarray.wat b/runtime/wasm/bigarray.wat index 2322ccf192..c468ada3f6 100644 --- a/runtime/wasm/bigarray.wat +++ b/runtime/wasm/bigarray.wat @@ -16,6 +16,497 @@ ;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (module + (import "fail" "caml_bound_error" (func $caml_bound_error)) + (import "fail" "caml_raise_out_of_memory" (func $caml_raise_out_of_memory)) + (import "fail" "caml_invalid_argument" + (func $caml_invalid_argument (param (ref eq)))) + (import "fail" "caml_failwith" (func $caml_failwith (param (ref eq)))) + (import "jslib" "wrap" (func $wrap (param anyref) (result (ref eq)))) + (import "jslib" "unwrap" (func $unwrap (param (ref eq)) (result anyref))) + (import "int32" "caml_copy_int32" + (func $caml_copy_int32 (param i32) (result (ref eq)))) + (import "int32" "Int32_val" + (func $Int32_val (param (ref eq)) (result i32))) + (import "int32" "caml_copy_nativeint" + (func $caml_copy_nativeint (param i32) (result (ref eq)))) + (import "int64" "caml_copy_int64" + (func $caml_copy_int64 (param i64) (result (ref eq)))) + (import "int64" "Int64_val" + (func $Int64_val (param (ref eq)) (result i64))) + (import "obj" "double_array_tag" (global $double_array_tag i32)) + (import "compare" "unordered" (global $unordered i32)) + (import "hash" "caml_hash_mix_int" + (func $caml_hash_mix_int (param i32) (param i32) (result i32))) + (import "hash" "caml_hash_mix_int64" + (func $caml_hash_mix_int64 (param i32) (param i64) (result i32))) + (import "hash" "caml_hash_mix_double" + (func $caml_hash_mix_double (param i32) (param f64) (result i32))) + (import "hash" "caml_hash_mix_float" + (func $caml_hash_mix_float (param i32) (param f32) (result i32))) + (import "hash" "caml_hash_mix_float16" + (func $caml_hash_mix_float16 (param i32) (param i32) (result i32))) + (import "marshal" "caml_serialize_int_1" + (func $caml_serialize_int_1 (param (ref eq)) (param i32))) + (import "marshal" "caml_serialize_int_2" + (func $caml_serialize_int_2 (param (ref eq)) (param i32))) + (import "marshal" "caml_serialize_int_4" + (func $caml_serialize_int_4 (param (ref eq)) (param i32))) + (import "marshal" "caml_serialize_int_8" + (func $caml_serialize_int_8 (param (ref eq)) (param i64))) + (import "marshal" "caml_deserialize_uint_1" + (func $caml_deserialize_uint_1 (param (ref eq)) (result i32))) + (import "marshal" "caml_deserialize_sint_1" + (func $caml_deserialize_sint_1 (param (ref eq)) (result i32))) + (import "marshal" "caml_deserialize_uint_2" + (func $caml_deserialize_uint_2 (param (ref eq)) (result i32))) + (import "marshal" "caml_deserialize_sint_2" + (func $caml_deserialize_sint_2 (param (ref eq)) (result i32))) + (import "marshal" "caml_deserialize_int_4" + (func $caml_deserialize_int_4 (param (ref eq)) (result i32))) + (import "marshal" "caml_deserialize_int_8" + (func $caml_deserialize_int_8 (param (ref eq)) (result i64))) + +(@if wasi +(@then + (type $i32_array (array (mut i32))) + (type $i16_array (array (mut i16))) + (type $f32_array (array (mut f32))) + + (type $data + (struct + (field $array (ref array)) + (field $offset i32) + (field $len i32))) + + (func $ta_create (export "ta_create") + (param $kind i32) (param $sz i32) (result (ref extern)) + (local $a (ref array)) + (local.set $a + (block $cont (result (ref array)) + (block $f32 + (block $f64 + (block $i8 + (block $i16 + (block $i32 + (br_table + $f32 $f64 $i8 $i8 $i16 $i16 $i32 + $i32 $i32 $i32 $f32 $f64 $i8 $i16 + (local.get $kind))) + ;; i32 + (br $cont (array.new $i32_array (i32.const 0) (local.get $sz)))) + ;; i16 + (br $cont (array.new $i16_array (i32.const 0) (local.get $sz)))) + ;; i8 + (br $cont (array.new $bytes (i32.const 0) (local.get $sz)))) + ;; f64 + (br $cont (array.new $float_array (f64.const 0) (local.get $sz)))) + ;; f32 + (array.new $f32_array (f32.const 0) (local.get $sz)))) + (extern.convert_any + (struct.new $data (local.get $a) (i32.const 0) (local.get $sz)))) + + (func $ta_length (export "ta_length") (param $b (ref extern)) (result i32) + (struct.get $data $len + (ref.cast (ref $data) (any.convert_extern (local.get $b))))) + + (func $ta_get_f64 (param $b (ref extern)) (param $i i32) (result f64) + (local $d (ref $data)) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $b)))) + (array.get $float_array + (ref.cast (ref $float_array) (struct.get $data $array (local.get $d))) + (i32.add (struct.get $data $offset (local.get $d)) (local.get $i)))) + + (func $ta_get_f32 (param $b (ref extern)) (param $i i32) (result f64) + (local $d (ref $data)) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $b)))) + (f64.promote_f32 + (array.get $f32_array + (ref.cast (ref $f32_array) (struct.get $data $array (local.get $d))) + (i32.add (struct.get $data $offset (local.get $d)) (local.get $i))))) + + (func $ta_get_i32 (export "ta_get_i32") + (param $b (ref extern)) (param $i i32) (result i32) + (local $d (ref $data)) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $b)))) + (array.get $i32_array + (ref.cast (ref $i32_array) (struct.get $data $array (local.get $d))) + (i32.add (struct.get $data $offset (local.get $d)) (local.get $i)))) + + (func $ta_get_i16 (param $b (ref extern)) (param $i i32) (result i32) + (local $d (ref $data)) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $b)))) + (array.get_s $i16_array + (ref.cast (ref $i16_array) (struct.get $data $array (local.get $d))) + (i32.add (struct.get $data $offset (local.get $d)) (local.get $i)))) + + (func $ta_get_ui16 (param $b (ref extern)) (param $i i32) (result i32) + (local $d (ref $data)) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $b)))) + (array.get_u $i16_array + (ref.cast (ref $i16_array) (struct.get $data $array (local.get $d))) + (i32.add (struct.get $data $offset (local.get $d)) (local.get $i)))) + + (func $ta_get_i8 (param $b (ref extern)) (param $i i32) (result i32) + (local $d (ref $data)) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $b)))) + (array.get_s $bytes + (ref.cast (ref $bytes) (struct.get $data $array (local.get $d))) + (i32.add (struct.get $data $offset (local.get $d)) (local.get $i)))) + + (func $ta_get_ui8 (export "ta_get_ui8") + (param $b (ref extern)) (param $i i32) (result i32) + (local $d (ref $data)) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $b)))) + (array.get_u $bytes + (ref.cast (ref $bytes) (struct.get $data $array (local.get $d))) + (i32.add (struct.get $data $offset (local.get $d)) (local.get $i)))) + + (func $ta_get32_ui8 (export "ta_get32_ui8") + (param $b (ref extern)) (param $i i32) (result i32) + (local $d (ref $data)) (local $s (ref $bytes)) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $b)))) + (local.set $s + (ref.cast (ref $bytes) (struct.get $data $array (local.get $d)))) + (local.set $i + (i32.add (struct.get $data $offset (local.get $d)) (local.get $i))) + (i32.or + (i32.or + (array.get_u $bytes (local.get $s) (local.get $i)) + (i32.shl + (array.get_u $bytes (local.get $s) + (i32.add (local.get $i) (i32.const 1))) + (i32.const 8))) + (i32.or + (i32.shl + (array.get_u $bytes (local.get $s) + (i32.add (local.get $i) (i32.const 2))) + (i32.const 16)) + (i32.shl + (array.get_u $bytes (local.get $s) + (i32.add (local.get $i) (i32.const 3))) + (i32.const 24))))) + + (func $ta_get16_ui8 (export "ta_get16_ui8") + (param $b (ref extern)) (param $i i32) (result i32) + (local $d (ref $data)) (local $s (ref $bytes)) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $b)))) + (local.set $s + (ref.cast (ref $bytes) (struct.get $data $array (local.get $d)))) + (local.set $i + (i32.add (struct.get $data $offset (local.get $d)) (local.get $i))) + (i32.or + (array.get_u $bytes (local.get $s) (local.get $i)) + (i32.shl + (array.get_u $bytes (local.get $s) + (i32.add (local.get $i) (i32.const 1))) + (i32.const 8)))) + + (func $ta_set_f64 (param $b (ref extern)) (param $i i32) (param $v f64) + (local $d (ref $data)) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $b)))) + (array.set $float_array + (ref.cast (ref $float_array) (struct.get $data $array (local.get $d))) + (i32.add (struct.get $data $offset (local.get $d)) (local.get $i)) + (local.get $v))) + + (func $ta_set_f32 (param $b (ref extern)) (param $i i32) (param $v f64) + (local $d (ref $data)) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $b)))) + (array.set $f32_array + (ref.cast (ref $f32_array) (struct.get $data $array (local.get $d))) + (i32.add (struct.get $data $offset (local.get $d)) (local.get $i)) + (f32.demote_f64 (local.get $v)))) + + (func $ta_set_i32 (export "ta_set_i32") + (param $b (ref extern)) (param $i i32) (param $v i32) + (local $d (ref $data)) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $b)))) + (array.set $i32_array + (ref.cast (ref $i32_array) (struct.get $data $array (local.get $d))) + (i32.add (struct.get $data $offset (local.get $d)) (local.get $i)) + (local.get $v))) + + (func $ta_set_i16 (param $b (ref extern)) (param $i i32) (param $v (ref i31)) + (local $d (ref $data)) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $b)))) + (array.set $i16_array + (ref.cast (ref $i16_array) (struct.get $data $array (local.get $d))) + (i32.add (struct.get $data $offset (local.get $d)) (local.get $i)) + (i31.get_u (local.get $v)))) + + (func $ta_set_ui16 (param $b (ref extern)) (param $i i32) (param $v (ref i31)) + (local $d (ref $data)) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $b)))) + (array.set $i16_array + (ref.cast (ref $i16_array) (struct.get $data $array (local.get $d))) + (i32.add (struct.get $data $offset (local.get $d)) (local.get $i)) + (i31.get_u (local.get $v)))) + + (func $ta_set_i8 (param $b (ref extern)) (param $i i32) (param $v (ref i31)) + (local $d (ref $data)) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $b)))) + (array.set $bytes + (ref.cast (ref $bytes) (struct.get $data $array (local.get $d))) + (i32.add (struct.get $data $offset (local.get $d)) (local.get $i)) + (i31.get_u (local.get $v)))) + + (func $ta_set_ui8 (export "ta_set_ui8") + (param $b (ref extern)) (param $i i32) (param $v (ref i31)) + (local $d (ref $data)) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $b)))) + (array.set $bytes + (ref.cast (ref $bytes) (struct.get $data $array (local.get $d))) + (i32.add (struct.get $data $offset (local.get $d)) (local.get $i)) + (i31.get_u (local.get $v)))) + + (func $ta_set16_ui8 + (param $b (ref extern)) (param $i i32) (param $v (ref i31)) + (local $d (ref $data)) (local $s (ref $bytes)) (local $j i32) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $b)))) + (local.set $s + (ref.cast (ref $bytes) (struct.get $data $array (local.get $d)))) + (local.set $j (i31.get_u (local.get $v))) + (local.set $i + (i32.add (struct.get $data $offset (local.get $d)) (local.get $i))) + (array.set $bytes (local.get $s) (local.get $i) (local.get $j)) + (array.set $bytes (local.get $s) (i32.add (local.get $i) (i32.const 1)) + (i32.shr_u (local.get $j) (i32.const 8)))) + + (func $ta_set32_ui8 (param $b (ref extern)) (param $i i32) (param $v i32) + (local $d (ref $data)) (local $s (ref $bytes)) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $b)))) + (local.set $s + (ref.cast (ref $bytes) (struct.get $data $array (local.get $d)))) + (local.set $i + (i32.add (struct.get $data $offset (local.get $d)) (local.get $i))) + (array.set $bytes (local.get $s) (local.get $i) (local.get $v)) + (array.set $bytes (local.get $s) (i32.add (local.get $i) (i32.const 1)) + (i32.shr_u (local.get $v) (i32.const 8))) + (array.set $bytes (local.get $s) (i32.add (local.get $i) (i32.const 2)) + (i32.shr_u (local.get $v) (i32.const 16))) + (array.set $bytes (local.get $s) (i32.add (local.get $i) (i32.const 3)) + (i32.shr_u (local.get $v) (i32.const 24)))) + + (func $ta_fill_int (param $b (ref extern)) (param $v i32) + (local $d (ref $data)) + (local $a (ref array)) + (local $a32 (ref $i32_array)) (local $a16 (ref $i16_array)) + (local $a8 (ref $bytes)) + (local $ofs i32) (local $i i32) (local $len i32) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $b)))) + (local.set $a (struct.get $data $array (local.get $d))) + (local.set $ofs (struct.get $data $offset (local.get $d))) + (local.set $len (struct.get $data $len (local.get $d))) + (if (ref.test (ref $i32_array) (local.get $a)) + (then + (local.set $a32 (ref.cast (ref $i32_array) (local.get $a))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (array.set $i32_array (local.get $a32) + (i32.add (local.get $ofs) (local.get $i)) + (local.get $v)) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop))))) + (else (if (ref.test (ref $i16_array) (local.get $a)) + (then + (local.set $a16 (ref.cast (ref $i16_array) (local.get $a))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (array.set $i16_array (local.get $a16) + (i32.add (local.get $ofs) (local.get $i)) + (local.get $v)) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop))))) + (else + (local.set $a8 (ref.cast (ref $bytes) (local.get $a))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (array.set $bytes (local.get $a8) + (i32.add (local.get $ofs) (local.get $i)) + (local.get $v)) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop))))))))) + + (func $ta_fill_float (param $b (ref extern)) (param $f f64) + (local $d (ref $data)) + (local $a (ref array)) + (local $a64 (ref $float_array)) (local $a32 (ref $f32_array)) + (local $f32 f32) + (local $ofs i32) (local $i i32) (local $len i32) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $b)))) + (local.set $a (struct.get $data $array (local.get $d))) + (local.set $ofs (struct.get $data $offset (local.get $d))) + (local.set $len (struct.get $data $len (local.get $d))) + (if (ref.test (ref $float_array) (local.get $a)) + (then + (local.set $a64 (ref.cast (ref $float_array) (local.get $a))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (array.set $float_array (local.get $a64) + (i32.add (local.get $ofs) (local.get $i)) + (local.get $f)) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop))))) + (else + (local.set $a32 (ref.cast (ref $f32_array) (local.get $a))) + (local.set $f32 (f32.demote_f64 (local.get $f))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (array.set $f32_array (local.get $a32) + (i32.add (local.get $ofs) (local.get $i)) + (local.get $f32)) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop))))))) + + (func $ta_set (export "ta_set") + (param $d (ref extern)) (param $s (ref extern)) (param $do i32) + (local $sd (ref $data)) (local $sa (ref array)) (local $so i32) + (local $dd (ref $data)) (local $da (ref array)) + (local $i i32) (local $len i32) + (local $sf64 (ref $float_array)) (local $df64 (ref $float_array)) + (local $sf32 (ref $f32_array)) (local $df32 (ref $f32_array)) + (local $si32 (ref $i32_array)) (local $di32 (ref $i32_array)) + (local $si16 (ref $i16_array)) (local $di16 (ref $i16_array)) + (local $si8 (ref $bytes)) (local $di8 (ref $bytes)) + (local.set $sd (ref.cast (ref $data) (any.convert_extern (local.get $s)))) + (local.set $sa (struct.get $data $array (local.get $sd))) + (local.set $so (struct.get $data $offset (local.get $sd))) + (local.set $len (struct.get $data $len (local.get $sd))) + (local.set $dd (ref.cast (ref $data) (any.convert_extern (local.get $d)))) + (local.set $da (struct.get $data $array (local.get $dd))) + (local.set $do + (i32.add (struct.get $data $offset (local.get $dd)) (local.get $do))) + (if (ref.test (ref $float_array) (local.get $sa)) + (then + (local.set $sf64 (ref.cast (ref $float_array) (local.get $sa))) + (local.set $df64 (ref.cast (ref $float_array) (local.get $da))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (array.set $float_array (local.get $df64) + (i32.add (local.get $do) (local.get $i)) + (array.get $float_array (local.get $sf64) + (i32.add (local.get $so) (local.get $i)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))))) + (if (ref.test (ref $f32_array) (local.get $sa)) + (then + (local.set $sf32 (ref.cast (ref $f32_array) (local.get $sa))) + (local.set $df32 (ref.cast (ref $f32_array) (local.get $da))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (array.set $f32_array (local.get $df32) + (i32.add (local.get $do) (local.get $i)) + (array.get $f32_array (local.get $sf32) + (i32.add (local.get $so) (local.get $i)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))))) + (if (ref.test (ref $i32_array) (local.get $sa)) + (then + (local.set $si32 (ref.cast (ref $i32_array) (local.get $sa))) + (local.set $di32 (ref.cast (ref $i32_array) (local.get $da))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (array.set $i32_array (local.get $di32) + (i32.add (local.get $do) (local.get $i)) + (array.get $i32_array (local.get $si32) + (i32.add (local.get $so) (local.get $i)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))))) + (if (ref.test (ref $i16_array) (local.get $sa)) + (then + (local.set $si16 (ref.cast (ref $i16_array) (local.get $sa))) + (local.set $di16 (ref.cast (ref $i16_array) (local.get $da))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (array.set $i16_array (local.get $di16) + (i32.add (local.get $do) (local.get $i)) + (array.get $i16_array (local.get $si16) + (i32.add (local.get $so) (local.get $i)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))))) + (if (ref.test (ref $bytes) (local.get $sa)) + (then + (local.set $si8 (ref.cast (ref $bytes) (local.get $sa))) + (local.set $di8 (ref.cast (ref $bytes) (local.get $da))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (array.set $bytes (local.get $di8) + (i32.add (local.get $do) (local.get $i)) + (array.get $bytes (local.get $si8) + (i32.add (local.get $so) (local.get $i)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop))))))) + + (func $ta_blit (param $s (ref extern)) (param $d (ref extern)) + (return_call $ta_set (local.get $d) (local.get $s) (i32.const 0))) + + (func $ta_subarray (export "ta_subarray") + (param $b (ref extern)) (param $s i32) (param $e i32) (result (ref extern)) + (local $d (ref $data)) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $b)))) + (extern.convert_any + (struct.new $data + (struct.get $data $array (local.get $d)) + (i32.add (struct.get $data $offset (local.get $d)) (local.get $s)) + (i32.sub (local.get $e) (local.get $s))))) + + (func $ta_blit_from_bytes (export "ta_blit_from_bytes") + (param $s (ref $bytes)) (param $so i32) + (param $b (ref extern)) (param $do i32) + (param $len i32) + (local $data (ref $data)) + (local $d (ref $bytes)) + (local $i i32) + (local.set $data + (ref.cast (ref $data) (any.convert_extern (local.get $b)))) + (local.set $d + (ref.cast (ref $bytes) (struct.get $data $array (local.get $data)))) + (local.set $do + (i32.add (local.get $do (struct.get $data $offset (local.get $data))))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (array.set $bytes (local.get $d) + (i32.add (local.get $do) (local.get $i)) + (array.get $bytes (local.get $s) + (i32.add (local.get $so) (local.get $i)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop))))) + + (func $ta_blit_to_bytes (export "ta_blit_to_bytes") + (param $b (ref extern)) (param $so i32) + (param $d (ref $bytes)) (param $do i32) + (param $len i32) + (local $data (ref $data)) + (local $s (ref $bytes)) + (local $i i32) + (local.set $data + (ref.cast (ref $data) (any.convert_extern (local.get $b)))) + (local.set $s + (ref.cast (ref $bytes) (struct.get $data $array (local.get $data)))) + (local.set $so + (i32.add (local.get $so (struct.get $data $offset (local.get $data))))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (array.set $bytes (local.get $d) + (i32.add (local.get $do) (local.get $i)) + (array.get $bytes (local.get $s) + (i32.add (local.get $so) (local.get $i)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop))))) +) +(@else (import "bindings" "ta_create" (func $ta_create (param i32) (param i32) (result (ref extern)))) (import "bindings" "ta_normalize" @@ -77,55 +568,7 @@ (func $ta_blit_to_bytes (param (ref extern)) (param i32) (param (ref $bytes)) (param i32) (param i32))) - (import "fail" "caml_bound_error" (func $caml_bound_error)) - (import "fail" "caml_raise_out_of_memory" (func $caml_raise_out_of_memory)) - (import "fail" "caml_invalid_argument" - (func $caml_invalid_argument (param (ref eq)))) - (import "fail" "caml_failwith" (func $caml_failwith (param (ref eq)))) - (import "jslib" "wrap" (func $wrap (param anyref) (result (ref eq)))) - (import "jslib" "unwrap" (func $unwrap (param (ref eq)) (result anyref))) - (import "int32" "caml_copy_int32" - (func $caml_copy_int32 (param i32) (result (ref eq)))) - (import "int32" "Int32_val" - (func $Int32_val (param (ref eq)) (result i32))) - (import "int32" "caml_copy_nativeint" - (func $caml_copy_nativeint (param i32) (result (ref eq)))) - (import "int64" "caml_copy_int64" - (func $caml_copy_int64 (param i64) (result (ref eq)))) - (import "int64" "Int64_val" - (func $Int64_val (param (ref eq)) (result i64))) - (import "obj" "double_array_tag" (global $double_array_tag i32)) - (import "compare" "unordered" (global $unordered i32)) - (import "hash" "caml_hash_mix_int" - (func $caml_hash_mix_int (param i32) (param i32) (result i32))) - (import "hash" "caml_hash_mix_int64" - (func $caml_hash_mix_int64 (param i32) (param i64) (result i32))) - (import "hash" "caml_hash_mix_double" - (func $caml_hash_mix_double (param i32) (param f64) (result i32))) - (import "hash" "caml_hash_mix_float" - (func $caml_hash_mix_float (param i32) (param f32) (result i32))) - (import "hash" "caml_hash_mix_float16" - (func $caml_hash_mix_float16 (param i32) (param i32) (result i32))) - (import "marshal" "caml_serialize_int_1" - (func $caml_serialize_int_1 (param (ref eq)) (param i32))) - (import "marshal" "caml_serialize_int_2" - (func $caml_serialize_int_2 (param (ref eq)) (param i32))) - (import "marshal" "caml_serialize_int_4" - (func $caml_serialize_int_4 (param (ref eq)) (param i32))) - (import "marshal" "caml_serialize_int_8" - (func $caml_serialize_int_8 (param (ref eq)) (param i64))) - (import "marshal" "caml_deserialize_uint_1" - (func $caml_deserialize_uint_1 (param (ref eq)) (result i32))) - (import "marshal" "caml_deserialize_sint_1" - (func $caml_deserialize_sint_1 (param (ref eq)) (result i32))) - (import "marshal" "caml_deserialize_uint_2" - (func $caml_deserialize_uint_2 (param (ref eq)) (result i32))) - (import "marshal" "caml_deserialize_sint_2" - (func $caml_deserialize_sint_2 (param (ref eq)) (result i32))) - (import "marshal" "caml_deserialize_int_4" - (func $caml_deserialize_int_4 (param (ref eq)) (result i32))) - (import "marshal" "caml_deserialize_int_8" - (func $caml_deserialize_int_8 (param (ref eq)) (result i64))) +)) (type $block (array (mut (ref eq)))) (type $bytes (array (mut i8))) @@ -831,6 +1274,8 @@ (@string $ta_unsupported_kind "Typed_array.to_genarray: unsupported kind") (@string $ta_too_large "Typed_array.to_genarray: too large") +(@if (not wasi) +(@then (func (export "caml_ba_from_typed_array") (param (ref eq)) (result (ref eq)) (local $data (ref extern)) (local $kind i32) @@ -859,6 +1304,7 @@ (any.convert_extern (struct.get $bigarray $ba_data (ref.cast (ref $bigarray) (local.get 0)))))) +)) (func $caml_ba_get_at_offset (param $ba (ref $bigarray)) (param $i i32) (result (ref eq)) @@ -2121,6 +2567,8 @@ (i32.wrap_i64 (i64.shr_u (local.get $d) (i64.const 32)))) (ref.i31 (i32.const 0))) +(@if (not wasi) +(@then (export "caml_bytes_of_uint8_array" (func $caml_string_of_uint8_array)) (func $caml_string_of_uint8_array (export "caml_string_of_uint8_array") (param (ref eq)) (result (ref eq)) @@ -2152,6 +2600,7 @@ (local.get $s) (i32.const 0) (local.get $ta) (i32.const 0) (local.get $len)) (call $wrap (any.convert_extern (local.get $ta)))) +)) (func (export "caml_ba_get_kind") (param (ref eq)) (result i32) (struct.get $bigarray $ba_kind (ref.cast (ref $bigarray) (local.get 0)))) diff --git a/runtime/wasm/bigstring.wat b/runtime/wasm/bigstring.wat index 1d9afd2ae9..ec3b903b02 100644 --- a/runtime/wasm/bigstring.wat +++ b/runtime/wasm/bigstring.wat @@ -31,6 +31,31 @@ (func $caml_ba_fill (param (ref eq)) (param (ref eq)) (result (ref eq)))) (import "bigarray" "caml_ba_get_data" (func $caml_ba_get_data (param (ref eq)) (result (ref extern)))) +(@if wasi +(@then + (import "bigarray" "ta_get_ui8" + (func $ta_get_ui8 (param (ref extern)) (param i32) (result i32))) + (import "bigarray" "ta_get32_ui8" + (func $ta_get32_ui8 (param (ref extern)) (param i32) (result i32))) + (import "bigarray" "ta_set_ui8" + (func $ta_set_ui8 (param (ref extern)) (param i32) (param (ref i31)))) + (import "bigarray" "ta_subarray" + (func $ta_subarray + (param (ref extern)) (param i32) (param i32) (result (ref extern)))) + (import "bigarray" "ta_set" + (func $ta_set (param (ref extern)) (param (ref extern)) (param i32))) + (import "bigarray" "ta_length" + (func $ta_length (param (ref extern)) (result i32))) + (import "bigarray" "ta_blit_from_bytes" + (func $ta_blit_from_bytes + (param (ref $bytes)) (param i32) (param (ref extern)) (param i32) + (param i32))) + (import "bigarray" "ta_blit_to_bytes" + (func $ta_blit_to_bytes + (param (ref extern)) (param i32) (param (ref $bytes)) (param i32) + (param i32))) +) +(@else (import "bindings" "ta_create" (func $ta_create (param i32) (param anyref) (result anyref))) (import "bindings" "ta_get_ui8" @@ -56,6 +81,7 @@ (func $ta_blit_to_bytes (param (ref extern)) (param i32) (param (ref $bytes)) (param i32) (param i32))) +)) (import "hash" "caml_hash_mix_int" (func $caml_hash_mix_int (param i32) (param i32) (result i32))) @@ -98,6 +124,8 @@ (local.set $h (call $caml_hash_mix_int (local.get $h) (local.get $w)))) (i32.xor (local.get $h) (local.get $len))) +(@if (not wasi) +(@then (@string $buffer "buffer") (func (export "bigstring_to_array_buffer") @@ -116,6 +144,7 @@ (func (export "bigstring_of_typed_array") (param (ref eq)) (result (ref eq)) (return_call $caml_ba_from_typed_array (call $wrap (call $ta_bytes (call $unwrap (local.get 0)))))) +)) (func (export "caml_bigstring_memset") (param $s (ref eq)) (param $pos (ref eq)) (param $len (ref eq)) diff --git a/runtime/wasm/compare.wat b/runtime/wasm/compare.wat index b6a48a62b7..4b8805a4a7 100644 --- a/runtime/wasm/compare.wat +++ b/runtime/wasm/compare.wat @@ -479,6 +479,8 @@ (call $clear_compare_stack) (call $caml_invalid_argument (global.get $abstract_value)) (ref.i31 (i32.const 0)))) +(@if (not wasi) +(@then (drop (block $v1_not_js (result (ref eq)) (local.set $js1 (struct.get $js 0 @@ -506,6 +508,7 @@ (call $equals (local.get $js1) (local.get $js2))) (return (global.get $unordered)))) (br $heterogeneous (ref.i31 (i32.const 0))))) +)) (if (call $caml_is_closure (local.get $v1)) (then (drop (br_if $heterogeneous (ref.i31 (i32.const 0)) diff --git a/runtime/wasm/deps-wasi.json b/runtime/wasm/deps-wasi.json new file mode 100644 index 0000000000..0a49660901 --- /dev/null +++ b/runtime/wasm/deps-wasi.json @@ -0,0 +1,15 @@ +[ + { + "name": "root", + "reaches": ["start", "memory"], + "root": true + }, + { + "name": "start", + "export": "_start" + }, + { + "name": "memory", + "export": "memory" + } +] diff --git a/runtime/wasm/dune b/runtime/wasm/dune index ddbdf30bb8..2a7e709d95 100644 --- a/runtime/wasm/dune +++ b/runtime/wasm/dune @@ -16,9 +16,28 @@ ../../compiler/bin-wasm_of_ocaml/wasmoo_link_wasm.exe --binaryen=-g --binaryen-opt=-O3 + --disable + wasi %{target} %{read-lines:args}))) +(rule + (target runtime-wasi.wasm) + (deps + args + (glob_files *.wat) + libc.wasm) + (action + (run + ../../compiler/bin-wasm_of_ocaml/wasmoo_link_wasm.exe + --binaryen=-g + --binaryen-opt=-O3 + --enable + wasi + %{target} + libc:libc.wasm + %{read-lines:args}))) + (rule (target args) (deps @@ -28,3 +47,34 @@ (with-stdout-to %{target} (run ocaml %{deps})))) + +(rule + (target libc.new.wasm) + (deps libc.c) + (enabled_if + (not %{env:CI=false})) + (mode promote) + (action + (with-stdout-to + %{target} + (pipe-stdout + (run + docker + run + -v + .:/src + -w + /src + ghcr.io/webassembly/wasi-sdk + /opt/wasi-sdk/bin/clang + -O2 + libc.c + -flto + -o + -) + (run wasm-opt -Oz --strip-debug --strip-dwarf - -o -))))) + +(rule + (alias recompile-libc) + (action + (cmp libc.wasm libc.new.wasm))) diff --git a/runtime/wasm/effect.wat b/runtime/wasm/effect.wat index 1c457a6380..d0443d17e9 100644 --- a/runtime/wasm/effect.wat +++ b/runtime/wasm/effect.wat @@ -23,11 +23,20 @@ (import "obj" "caml_fresh_oo_id" (func $caml_fresh_oo_id (param (ref eq)) (result (ref eq)))) (import "obj" "cont_tag" (global $cont_tag i32)) + (import "obj" "caml_callback_1" + (func $caml_callback_1 + (param (ref eq)) (param (ref eq)) (result (ref eq)))) (import "stdlib" "caml_named_value" (func $caml_named_value (param (ref eq)) (result (ref null eq)))) (import "fail" "ocaml_exception" (tag $ocaml_exception (param (ref eq)))) (import "fail" "javascript_exception" (tag $javascript_exception (param externref))) +(@if wasi +(@then + (func $caml_wrap_exception (param externref) (result (ref eq)) + (unreachable)) +) +(@else (import "jslib" "caml_wrap_exception" (func $caml_wrap_exception (param externref) (result (ref eq)))) (import "bindings" "start_fiber" (func $start_fiber (param (ref eq)))) @@ -36,9 +45,7 @@ (param $f funcref) (param $env eqref) (result anyref))) (import "bindings" "resume_fiber" (func $resume_fiber (param externref) (param (ref eq)))) - (import "obj" "caml_callback_1" - (func $caml_callback_1 - (param (ref eq)) (param (ref eq)) (result (ref eq)))) +)) (type $block (array (mut (ref eq)))) (type $bytes (array (mut i8))) @@ -50,6 +57,37 @@ (sub $closure (struct (field (ref $function_1)) (field (ref $function_3))))) + ;; Generic fibers + + (type $handlers + (struct + (field $value (ref eq)) + (field $exn (ref eq)) + (field $effect (ref eq)))) + + (type $generic_fiber (sub (struct (field $handlers (mut (ref $handlers)))))) + + (@string $already_resumed "Effect.Continuation_already_resumed") + + (@string $effect_unhandled "Effect.Unhandled") + + (func $raise_unhandled + (param $eff (ref eq)) (param (ref eq)) (result (ref eq)) + (block $null + (call $caml_raise_with_arg + (br_on_null $null + (call $caml_named_value (global.get $effect_unhandled))) + (local.get $eff))) + (call $caml_raise_constant + (array.new_fixed $block 3 (ref.i31 (i32.const 248)) + (global.get $effect_unhandled) + (call $caml_fresh_oo_id (ref.i31 (i32.const 0))))) + (ref.i31 (i32.const 0))) + + (global $effect_allowed (mut i32) (i32.const 1)) + +(@if (not wasi) +(@then ;; Apply a function f to a value v, both contained in a pair (f, v) (type $pair (struct (field (ref eq)) (field (ref eq)))) @@ -106,14 +144,6 @@ ;; Stack of fibers - (type $handlers - (struct - (field $value (ref eq)) - (field $exn (ref eq)) - (field $effect (ref eq)))) - - (type $generic_fiber (sub (struct (field $handlers (mut (ref $handlers)))))) - (type $fiber (sub final $generic_fiber (struct @@ -121,21 +151,6 @@ (field $cont (ref $cont)) (field $next (ref null $fiber))))) - (@string $effect_unhandled "Effect.Unhandled") - - (func $raise_unhandled - (param $eff (ref eq)) (param (ref eq)) (result (ref eq)) - (block $null - (call $caml_raise_with_arg - (br_on_null $null - (call $caml_named_value (global.get $effect_unhandled))) - (local.get $eff))) - (call $caml_raise_constant - (array.new_fixed $block 3 (ref.i31 (i32.const 248)) - (global.get $effect_unhandled) - (call $caml_fresh_oo_id (ref.i31 (i32.const 0))))) - (ref.i31 (i32.const 0))) - (func $uncaught_effect_handler (param $eff (ref eq)) (param $cont (ref eq)) (param $k (ref eq)) (param (ref eq)) (result (ref eq)) @@ -213,8 +228,6 @@ (return_call_ref $cont_func (local.get $p) (local.get $k) (struct.get $cont $cont_func (local.get $k)))) - (@string $already_resumed "Effect.Continuation_already_resumed") - (func (export "%resume") (param $stack (ref eq)) (param $f (ref eq)) (param $v (ref eq)) (param $tail (ref eq)) (result (ref eq)) @@ -299,8 +312,6 @@ (ref.func $do_perform) (struct.new $pair (local.get $eff) (local.get $cont)))) - (global $effect_allowed (mut i32) (i32.const 1)) - (func (export "%perform") (param $eff (ref eq)) (result (ref eq)) (if (i32.eqz (global.get $effect_allowed)) (then @@ -355,6 +366,7 @@ (struct.new $handlers (local.get $hv) (local.get $hx) (local.get $hf)) (struct.new $cont (ref.func $initial_cont)) (ref.null $fiber))) +)) ;; Other functions diff --git a/runtime/wasm/fail.wat b/runtime/wasm/fail.wat index 04a6092a0e..2aa44adf42 100644 --- a/runtime/wasm/fail.wat +++ b/runtime/wasm/fail.wat @@ -18,7 +18,13 @@ (module (import "stdlib" "caml_global_data" (global $caml_global_data (mut (ref $block)))) +(@if wasi +(@then + (tag $javascript_exception (param externref)) +) +(@else (import "bindings" "jstag" (tag $javascript_exception (param externref))) +)) (type $block (array (mut (ref eq)))) (type $bytes (array (mut i8))) diff --git a/runtime/wasm/float.wat b/runtime/wasm/float.wat index 12e33f88a9..c21cdc7551 100644 --- a/runtime/wasm/float.wat +++ b/runtime/wasm/float.wat @@ -16,12 +16,36 @@ ;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (module + (import "jslib" "unwrap" (func $unwrap (param (ref eq)) (result anyref))) +(@if wasi +(@then + (import "io" "IO_BUFFER_SIZE" (global $IO_BUFFER_SIZE i32)) + (import "libc" "memory" (memory 2)) + (import "libc" "free" (func $free (param i32))) + (import "libc" "format_float" + (func $format_float (param i32 i32 i32 f64) (result i32))) + (import "libc" "strtod" (func $strtod (param i32) (param i32) (result f64))) + (import "libc" "exp" (func $exp (param f64) (result f64))) + (import "wasi_memory" "checked_malloc" + (func $checked_malloc (param i32) (result i32))) + (import "wasi_memory" "get_buffer" (func $get_buffer (result i32))) + (import "wasi_memory" "write_string_to_memory" + (func $write_string_to_memory (param i32 i32 (ref eq)) (result i32))) + (import "wasi_memory" "release_memory" + (func $release_memory (param i32 i32))) + (import "wasi_memory" "blit_string_to_memory" + (func $blit_string_to_memory (param i32 (ref $bytes)))) + (import "wasi_memory" "blit_memory_to_string" + (func $blit_memory_to_string (param i32 i32) (result (ref $bytes)))) +) +(@else (import "bindings" "format_float" (func $format_float (param i32) (param i32) (param i32) (param f64) (result anyref))) (import "bindings" "identity" (func $parse_float (param anyref) (result f64))) (import "Math" "exp" (func $exp (param f64) (result f64))) +)) (import "fail" "caml_failwith" (func $caml_failwith (param (ref eq)))) (import "fail" "caml_invalid_argument" (func $caml_invalid_argument (param (ref eq)))) @@ -253,6 +277,49 @@ (array.new_fixed $chars 3 (i32.const 105) (i32.const 110) (i32.const 102))) +(@if wasi +(@then + (func (export "caml_format_float") + (param $vfmt (ref eq)) (param $arg (ref eq)) (result (ref eq)) + (local $fmt (ref $bytes)) (local $res (ref $bytes)) + (local $d f64) + (local $buffer i32) (local $out_buffer i32) + (local $fmt_len i32) (local $avail i32) (local $len i32) + (local.set $fmt (ref.cast (ref $bytes) (local.get $vfmt))) + (local.set $d + (struct.get $float 0 (ref.cast (ref $float) (local.get $arg)))) + (local.set $buffer (call $get_buffer)) + (local.set $fmt_len (array.len (local.get $fmt))) + (call $blit_string_to_memory (local.get $buffer) (local.get $fmt)) + (i32.store8 + (i32.add (local.get $buffer) (local.get $fmt_len)) (i32.const 0)) + (local.set $out_buffer + (i32.add (local.get $buffer) + (i32.add (local.get $fmt_len) (i32.const 1)))) + (local.set $avail + (i32.sub (global.get $IO_BUFFER_SIZE) (local.get $fmt_len))) + (local.set $len + (call $format_float + (local.get $out_buffer) (local.get $avail) + (local.get $buffer) (local.get $d))) + (if (i32.ge_u (local.get $len) (local.get $avail)) + (then + (local.set $out_buffer + (call $checked_malloc (i32.add (local.get $len) (i32.const 1)))) + (drop + (call $format_float + (local.get $out_buffer) + (i32.add (local.get $len) (i32.const 1)) + (local.get $buffer) (local.get $d))))) + (local.set $res + (call $blit_memory_to_string (local.get $out_buffer) (local.get $len))) + (if (i32.ge_u (local.get $len) (local.get $avail)) + (then + (call $free (local.get $out_buffer)))) + (local.get $res) + ) +) +(@else (func (export "caml_format_float") (param (ref eq)) (param (ref eq)) (result (ref eq)) (local $f f64) (local $b i64) (local $format (tuple i32 i32 i32 i32)) @@ -336,6 +403,7 @@ (local.set $i (i32.add (local.get $i) (i32.const 1))) (br_if $uppercase (i32.lt_u (local.get $i) (local.get $len)))))) (local.get $s)) +)) (@string $float_of_string "float_of_string") @@ -492,6 +560,7 @@ (local $s' (ref $bytes)) (local $negative i32) (local $c i32) (local $f f64) + (local $buffer i32) (local $buf i32) (local.set $s (ref.cast (ref $bytes) (local.get 0))) (local.set $len (array.len (local.get $s))) (loop $count @@ -658,9 +727,26 @@ (f64.const inf) (local.get $negative)))) )))))))))))))))))) +(@if wasi +(@then + (local.set $buffer (call $get_buffer)) + (local.set $buf + (call $write_string_to_memory + (i32.add (local.get $buffer) (i32.const 4)) + (global.get $IO_BUFFER_SIZE) + (local.get $s))) + (local.set $f (call $strtod (local.get $buf) (local.get $buffer))) + (call $release_memory (i32.add (local.get $buffer) (i32.const 4)) + (local.get $buf)) + (br_if $error + (i32.ne (i32.load (local.get $buffer)) + (i32.add (local.get $buf) (local.get $len)))) +) +(@else (local.set $f (call $parse_float (call $jsstring_of_bytes (local.get $s)))) (br_if $error (f64.ne (local.get $f) (local.get $f))) +)) (return (struct.new $float (local.get $f)))) (call $caml_failwith (global.get $float_of_string)) (return (ref.i31 (i32.const 0)))) diff --git a/runtime/wasm/fs.wat b/runtime/wasm/fs.wat index 7012050c6d..5301f33de4 100644 --- a/runtime/wasm/fs.wat +++ b/runtime/wasm/fs.wat @@ -16,6 +16,41 @@ ;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (module +(@if wasi +(@then + (import "libc" "memory" (memory 2)) + (import "libc" "free" (func $free (param i32))) + (import "wasi_memory" "checked_malloc" + (func $checked_malloc (param i32) (result i32))) + (import "wasi_memory" "get_buffer" (func $get_buffer (result i32))) + (import "wasi_memory" "write_string_to_memory" + (func $write_string_to_memory (param i32 i32 (ref eq)) (result i32))) + (import "wasi_memory" "blit_memory_to_string" + (func $blit_memory_to_string (param i32 i32) (result (ref $bytes)))) + (import "wasi_snapshot_preview1" "fd_prestat_get" + (func $fd_prestat_get (param i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "fd_prestat_dir_name" + (func $fd_prestat_dir_name (param i32 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "path_rename" + (func $path_rename (param i32 i32 i32 i32 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "path_unlink_file" + (func $path_unlink_file (param i32 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "path_create_directory" + (func $path_create_directory (param i32 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "path_remove_directory" + (func $path_remove_directory (param i32 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "path_filestat_get" + (func $path_filestat_get (param i32 i32 i32 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "path_open" + (func $path_open (param i32 i32 i32 i32 i32 i64 i64 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "fd_readdir" + (func $fd_readddir (param i32 i32 i32 i64 i32) (result i32))) + (import "wasi_snapshot_preview1" "fd_close" + (func $fd_close (param i32) (result i32))) + (import "sys" "caml_handle_sys_error" + (func $caml_handle_sys_error (param (ref eq) i32))) +) +(@else (import "bindings" "getcwd" (func $getcwd (result anyref))) (import "bindings" "chdir" (func $chdir (param anyref))) (import "bindings" "mkdir" (func $mkdir (param anyref) (param i32))) @@ -30,6 +65,8 @@ (import "bindings" "is_file" (func $is_file (param anyref) (result (ref eq)))) (import "bindings" "rename" (func $rename (param anyref) (param anyref))) + (import "fail" "javascript_exception" + (tag $javascript_exception (param externref))) (import "jslib" "wrap" (func $wrap (param anyref) (result (ref eq)))) (import "jslib" "unwrap" (func $unwrap (param (ref eq)) (result anyref))) (import "jslib" "caml_string_of_jsstring" @@ -38,17 +75,298 @@ (func $caml_jsstring_of_string (param (ref eq)) (result (ref eq)))) (import "jslib" "caml_js_to_string_array" (func $caml_js_to_string_array (param $a (ref extern)) (result (ref eq)))) - (import "fail" "caml_raise_sys_error" - (func $caml_raise_sys_error (param (ref eq)))) - (import "fail" "javascript_exception" - (tag $javascript_exception (param externref))) (import "sys" "caml_handle_sys_error" (func $caml_handle_sys_error (param externref))) +)) (import "string" "caml_string_concat" (func $caml_string_concat (param (ref eq) (ref eq)) (result (ref eq)))) + (import "fail" "caml_raise_sys_error" + (func $caml_raise_sys_error (param (ref eq)))) (type $bytes (array (mut i8))) + (type $block (array (mut (ref eq)))) + +(@if wasi +(@then + (type $preopen + (struct + (field $prefix (ref $bytes)) + (field $fd i32) + (field $next (ref null $preopen)))) + + (global $preopens (mut (ref null $preopen)) (ref.null $preopen)) + + (global $preopens_initialized (mut i32) (i32.const 0)) + + (func $normalize_prefix (param $prefix (ref $bytes)) (result (ref $bytes)) + (local $i i32) (local $len i32) (local $c i32) (local $res (ref $bytes)) + (local.set $len (array.len (local.get $prefix))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (local.set $c + (array.get $bytes (local.get $prefix) (local.get $i))) + (if (i32.eq (local.get $c) (i32.const 47)) ;; '/' + (then + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop))) + (if (i32.eq (local.get $c) (i32.const 46)) ;; '.' + (then + (if (i32.eq (local.get $i) + (i32.sub (local.get $len) (i32.const 1))) + (then + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)) + (else + (local.set $c + (array.get $bytes (local.get $prefix) + (i32.add (local.get $i) (i32.const 1)))) + (if (i32.eq (local.get $c) (i32.const 47)) ;; '/' + (then + (local.set $i + (i32.add (local.get $i) (i32.const 2))) + (br $loop)))))))))) + (if (i32.eq (local.get $i) (local.get $len)) + (then (return (@string "")))) + (local.set $i (i32.sub (local.get $i) (i32.const 1))) + (if (i32.gt_u (local.get $i) (i32.const 0)) + (then + (local.set $res + (array.new $bytes (i32.const 0) + (i32.sub (local.get $len) (local.get $i)))) + (array.copy $bytes $bytes + (local.get $res) (i32.const 0) + (local.get $prefix) (local.get $i) + (i32.sub (local.get $len) (local.get $i))) + (return (local.get $res)))) + (return (local.get $prefix))) + + (func $get_preopens (result (ref null $preopen)) + (local $fd i32) (local $buffer i32) (local $res i32) (local $len i32) + (if $done (i32.eqz (global.get $preopens_initialized)) + (then + (local.set $buffer (call $get_buffer)) + (local.set $fd (i32.const 3)) + (loop $loop + (local.set $res + (call $fd_prestat_get (local.get $fd) (local.get $buffer))) + (br_if $done (i32.eq (local.get $res) (i32.const 8))) ;; EBADF + (block $skip + (br_if $skip + (i32.eqz + (i32.and (i32.eqz (local.get $res)) + (i32.eqz (i32.load8_u (local.get $buffer)))))) + (local.set $len (i32.load offset=4 (local.get $buffer))) + (local.set $res + (call $fd_prestat_dir_name + (local.get $fd) (local.get $buffer) (local.get $len))) + (br_if $skip (local.get $res)) + (global.set $preopens + (struct.new $preopen + (call $normalize_prefix + (call $blit_memory_to_string + (local.get $buffer) (local.get $len))) + (local.get $fd) + (global.get $preopens)))) + (local.set $fd (i32.add (local.get $fd) (i32.const 1))) + (br $loop)) + (global.set $preopens_initialized (i32.const 1)))) + (global.get $preopens)) + + (global $current_dir (mut (ref $bytes)) (@string "")) + (@string $root_dir "/") + + (func $make_absolute + (param $path (ref $bytes)) (result (ref $bytes)) + (local $need_slash i32) (local $i i32) (local $abs_path (ref $bytes)) + (if (i32.eqz (array.len (local.get $path))) + (then ;; empty path + (return (global.get $current_dir)))) + (if (i32.eq (i32.const 47) ;; '/' + (array.get_u $bytes (local.get $path) (i32.const 0))) + (then ;; absolute path + (return (local.get $path)))) + (if (i32.and + (i32.eq (i32.const 46) ;; '.' + (array.get_u $bytes (local.get $path) (i32.const 0))) + (i32.eq (array.len (local.get $path)) (i32.const 1))) + (then + ;; "." + (return (global.get $current_dir)))) + (if (i32.ge_u (array.len (local.get $path)) (i32.const 2)) + (then + (if (i32.and + (i32.eq (i32.const 46) ;; '.' + (array.get_u $bytes (local.get $path) (i32.const 0))) + (i32.eq (i32.const 47) ;; '/' + (array.get_u $bytes (local.get $path) (i32.const 1)))) + (then ;; starts with "./" + (local.set $i (i32.const 2)))))) + (if (i32.eq (local.get $i) (array.len (local.get $path))) + (then ;; "./" + (return (global.get $current_dir)))) + (local.set $need_slash + (if (result i32) (array.len (global.get $current_dir)) + (then + (i32.ne (i32.const 47) ;; '/' + (array.get_u $bytes (global.get $current_dir) + (i32.sub (array.len (global.get $current_dir)) + (i32.const 1))))) + (else + (i32.const 1)))) + (local.set $abs_path + (array.new $bytes (i32.const 0) + (i32.add (array.len (global.get $current_dir)) + (i32.add (i32.sub (local.get $need_slash) (local.get $i)) + (array.len (local.get $path)))))) + (array.copy $bytes $bytes + (local.get $abs_path) (i32.const 0) + (global.get $current_dir) (i32.const 0) + (array.len (global.get $current_dir))) + (array.set $bytes (local.get $abs_path) + (array.len (global.get $current_dir)) + (i32.const 47)) ;; '/' + (array.copy $bytes $bytes + (local.get $abs_path) + (i32.add (array.len (global.get $current_dir)) + (local.get $need_slash)) + (local.get $path) (local.get $i) + (i32.sub (array.len (local.get $path)) (local.get $i))) + (local.get $abs_path)) + + (func $wasi_chdir (export "wasi_chdir") (param $name (ref eq)) + (local $abs_path (ref $bytes)) (local $path (ref $bytes)) (local $i i32) + (local.set $abs_path + (call $make_absolute (ref.cast (ref $bytes) (local.get $name)))) + (local.set $i (i32.sub (array.len (local.get $abs_path)) (i32.const 1))) + ;; remove trailing slashes + (loop $loop + (if (i32.ge_s (local.get $i) (i32.const 0)) + (then + (if (i32.eq (i32.const 47) ;; '/' + (array.get $bytes (local.get $abs_path) (local.get $i))) + (then + (local.set $i (i32.sub (local.get $i) (i32.const 1))) + (br $loop)))))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (if (i32.lt_u (local.get $i) (array.len (local.get $abs_path))) + (then + (local.set $path (array.new $bytes (i32.const 0) (local.get $i))) + (array.copy $bytes $bytes + (local.get $path) (i32.const 0) + (local.get $abs_path) (i32.const 0) + (local.get $i)) + (local.set $abs_path (local.get $path)))) + (global.set $current_dir (local.get $abs_path))) + + (func $prefix_match + (param $prefix (ref $bytes)) (param $path (ref $bytes)) (result i32) + (local $i i32) (local $len i32) + (local.set $len (array.len (local.get $prefix))) + (if (i32.lt_u (array.len (local.get $path)) (local.get $len)) + (then (return (i32.const 0)))) + (if (i32.gt_u (array.len (local.get $path)) (local.get $len)) + (then + (if (i32.ne (array.get_u $bytes (local.get $path) (local.get $i)) + (i32.const 47)) + (then (return (i32.const 0)))))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (if (i32.ne (array.get_u $bytes (local.get $path) (local.get $i)) + (array.get_u $bytes (local.get $prefix) (local.get $i))) + (then (return (i32.const 0)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (return (i32.const 1))) + + (func $resolve_abs_path + (param $path (ref $bytes)) (result i32 (ref $bytes)) + (local $fd i32) (local $len i32) (local $i i32) + (local $preopens (ref null $preopen)) (local $current (ref $preopen)) + (local $prefix (ref $bytes)) (local $rel_path (ref $bytes)) + (local.set $preopens (call $get_preopens)) + (local.set $i (i32.const -1)) + (block $done + (loop $loop + (local.set $current (br_on_null $done (local.get $preopens))) + (local.set $prefix + (struct.get $preopen $prefix (local.get $current))) + (if (i32.and + (i32.gt_s (array.len (local.get $prefix)) (local.get $i)) + (call $prefix_match (local.get $prefix) (local.get $path))) + (then + (local.set $fd (struct.get $preopen $fd (local.get $current))) + (local.set $i (array.len (local.get $prefix))))) + (local.set $preopens + (struct.get $preopen $next (local.get $current))) + (br $loop))) + (if (i32.eq (local.get $i) (i32.const -1)) + (then ;; not found + (return (tuple.make 2 (i32.const -1) (@string ""))))) + ;; skip leading slashes + (local.set $len (local.get $i)) + (loop $loop + (if (i32.lt_u (local.get $i) (array.len (local.get $path))) + (then + (if (i32.eq (array.get_u $bytes (local.get $path) (local.get $i)) + (i32.const 47)) ;; 47 + (then + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop))) + (local.set $rel_path + (array.new $bytes (i32.const 0) + (i32.sub (array.len (local.get $path)) (local.get $i)))) + (array.copy $bytes $bytes + (local.get $rel_path) (i32.const 0) + (local.get $path) (local.get $i) + (i32.sub (array.len (local.get $path)) (local.get $i))) + (return + (tuple.make 2 (local.get $fd) (local.get $rel_path)))))) + (return (tuple.make 2 (local.get $fd) (@string ".")))) + + (func (export "wasi_resolve_path") + (param $vpath (ref eq)) + (result (;fd;) i32 (;address;) i32 (;length;) i32) + (local $res (tuple i32 (ref $bytes))) + (local $p i32) + (local.set $res + (call $resolve_abs_path + (call $make_absolute + (ref.cast (ref $bytes) (local.get $vpath))))) + (if (i32.ge_u (tuple.extract 2 0 (local.get $res)) (i32.const 0)) + (then + (local.set $p + (call $write_string_to_memory + (i32.const 0) (i32.const 0) + (tuple.extract 2 1 (local.get $res)))))) + (return + (tuple.make 3 + (tuple.extract 2 0 (local.get $res)) + (local.get $p) + (array.len (tuple.extract 2 1 (local.get $res)))))) + + (func $caml_sys_resolve_path (export "caml_sys_resolve_path") + (param $path (ref eq)) (result i32 i32 i32) + (local $res (tuple i32 i32 i32)) + (local.set $res (call $wasi_resolve_path (local.get $path))) + (if (i32.lt_s (tuple.extract 3 0 (local.get $res)) (i32.const 0)) + (then ;; ENOENT + (call $caml_handle_sys_error (local.get $path) (i32.const 44)))) + (local.get $res)) +)) + +(@if wasi +(@then + (func (export "caml_sys_getcwd") + (export "unix_getcwd") (export "caml_unix_getcwd") + (param (ref eq)) (result (ref eq)) + (if (array.len (global.get $current_dir)) + (then (return (global.get $current_dir)))) + (global.get $root_dir)) +) +(@else (func (export "caml_sys_getcwd") (param (ref eq)) (result (ref eq)) (try (result (ref eq)) @@ -57,7 +375,34 @@ (catch $javascript_exception (call $caml_handle_sys_error (pop externref)) (ref.i31 (i32.const 0))))) +)) +(@if wasi +(@then + (func (export "caml_sys_chdir") + (param $name (ref eq)) (result (ref eq)) + (local $p (tuple i32 i32 i32)) + (local $buffer i32) (local $res i32) (local $kind i32) + (local.set $p (call $caml_sys_resolve_path (local.get $name))) + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $path_filestat_get + (tuple.extract 3 0 (local.get $p)) + (i32.const 1) + (tuple.extract 3 1 (local.get $p)) + (tuple.extract 3 2 (local.get $p)) + (local.get $buffer))) + (if (local.get $res) + (then (call $caml_handle_sys_error (local.get $name) (local.get $res)))) + (local.set $kind (i32.load8_u offset=16 (local.get $buffer))) + (if (i32.ne (local.get $kind) (i32.const 3)) + (then + (call $caml_handle_sys_error + (local.get $name) (i32.const 54)))) ;; ENOTDIR + (call $wasi_chdir (local.get $name)) + (ref.i31 (i32.const 0))) +) +(@else (func (export "caml_sys_chdir") (param $name (ref eq)) (result (ref eq)) (try @@ -67,7 +412,26 @@ (catch $javascript_exception (call $caml_handle_sys_error (pop externref)))) (ref.i31 (i32.const 0))) +)) +(@if wasi +(@then + (func (export "caml_sys_mkdir") + (param $name (ref eq)) (param $perm (ref eq)) (result (ref eq)) + (local $p (tuple i32 i32 i32)) + (local $res i32) + (local.set $p (call $caml_sys_resolve_path (local.get $name))) + (local.set $res + (call $path_create_directory + (tuple.extract 3 0 (local.get $p)) + (tuple.extract 3 1 (local.get $p)) + (tuple.extract 3 2 (local.get $p)))) + (call $free (tuple.extract 3 1 (local.get $p))) + (if (local.get $res) + (then (call $caml_handle_sys_error (local.get $name) (local.get $res)))) + (ref.i31 (i32.const 0))) +) +(@else (func (export "caml_sys_mkdir") (param $name (ref eq)) (param $perm (ref eq)) (result (ref eq)) (try @@ -78,7 +442,128 @@ (catch $javascript_exception (call $caml_handle_sys_error (pop externref)))) (ref.i31 (i32.const 0))) +)) +(@if wasi +(@then + (func (export "caml_sys_read_directory") + (param $name (ref eq)) (result (ref eq)) + (local $p (tuple i32 i32 i32)) + (local $buffer i32) (local $res i32) (local $fd i32) + (local $buf i32) (local $new_buf i32) + (local $size i32) (local $pos i32) (local $available i32) + (local $left i32) (local $namelen i32) + (local $entry i32) (local $entry_size i32) + (local $cookie i64) (local $tbl (ref $block)) (local $new_tbl (ref $block)) + (local $i i32) (local $s (ref $bytes)) + (local.set $p (call $caml_sys_resolve_path (local.get $name))) + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $path_open + (tuple.extract 3 0 (local.get $p)) + (i32.const 1) ;; symlink_follow + (tuple.extract 3 1 (local.get $p)) + (tuple.extract 3 2 (local.get $p)) + (i32.const 2) ;; O_DIRECTORY + (i64.const 0x4000) ;; allow fd_readdir + (i64.const 0) + (i32.const 0) + (local.get $buffer))) + (call $free (tuple.extract 3 1 (local.get $p))) + (if (local.get $res) + (then + (call $caml_handle_sys_error (local.get $name) (local.get $res)))) + (local.set $fd (i32.load (local.get $buffer))) + (local.set $buf (call $checked_malloc (i32.const 512))) + (local.set $size (i32.const 512)) + (local.set $tbl (array.new $block (ref.i31 (i32.const 0)) (i32.const 50))) + (local.set $i (i32.const 1)) + (loop $loop + (block $refill + (local.set $left (i32.sub (local.get $available) (local.get $pos))) + (br_if $refill (i32.lt_u (local.get $left) (i32.const 24))) + (local.set $entry (i32.add (local.get $buf) (local.get $pos))) + (local.set $namelen (i32.load offset=16 (local.get $entry))) + (local.set $entry_size (i32.add (local.get $namelen) (i32.const 24))) + (br_if $refill (i32.lt_u (local.get $left) (local.get $entry_size))) + (local.set $pos (i32.add (local.get $pos) (local.get $entry_size))) + (local.set $cookie (i64.load (local.get $entry))) + (if (i32.eq (local.get $i) (array.len (local.get $tbl))) + (then + (local.set $new_tbl + (array.new $block (ref.i31 (i32.const 0)) + (i32.shl (local.get $i) (i32.const 1)))) + (array.copy $block $block + (local.get $new_tbl) (i32.const 0) + (local.get $tbl) (i32.const 0) (local.get $i)) + (local.set $tbl (local.get $new_tbl)))) + (local.set $s + (call $blit_memory_to_string + (i32.add (local.get $entry) (i32.const 24)) + (local.get $namelen))) + ;; skip "." and ".." + (if (i32.eq (local.get $namelen) (i32.const 2)) + (then + (br_if $loop + (i32.and + (i32.eq (i32.const 46) + (array.get_u $bytes (local.get $s) (i32.const 0))) + (i32.eq (i32.const 46) + (array.get_u $bytes (local.get $s) (i32.const 1)))))) + (else + (if (i32.eq (local.get $namelen) (i32.const 2)) + (then + (br_if $loop + (i32.eq + (array.get_u $bytes (local.get $s) (i32.const 0)) + (i32.const 46))))))) + (array.set $block (local.get $tbl) (local.get $i) (local.get $s)) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)) + ;; refill + (if (i32.lt_u (local.get $size) (local.get $entry_size)) + (then + ;; the entry does not fit + (local.set $new_buf + (call $checked_malloc (local.get $entry_size))) + (call $free (local.get $buf)) + (local.set $buf (local.get $new_buf)) + (local.set $size (local.get $entry_size)))) + (block $done + (br_if $done + (i32.and + (i32.ne (i32.const 0) (local.get $available)) + (i32.lt_u (local.get $available) (local.get $size)))) + (local.set $res + (call $fd_readddir + (local.get $fd) + (local.get $buffer) + (local.get $size) + (local.get $cookie) + (local.get $buffer))) + (if (local.get $res) + (then + (call $caml_handle_sys_error + (local.get $name) (local.get $res)))) + (local.set $available (i32.load (local.get $buffer))) + (br_if $done (i32.eqz (local.get $available))) + (local.set $pos (i32.const 0)) + (br $loop))) + ;; done + (call $free (local.get $buf)) + (local.set $res (call $fd_close (local.get $fd))) + (if (local.get $res) + (then (call $caml_handle_sys_error (local.get $name) (local.get $res)))) + (if (i32.eq (local.get $i) (array.len (local.get $tbl))) + (then (return (local.get $tbl)))) + (local.set $new_tbl + (array.new $block (ref.i31 (i32.const 0)) (local.get $i))) + (array.copy $block $block + (local.get $new_tbl) (i32.const 0) + (local.get $tbl) (i32.const 0) (local.get $i)) + (local.get $new_tbl)) +) +(@else (func (export "caml_sys_read_directory") (param $name (ref eq)) (result (ref eq)) (try @@ -91,7 +576,26 @@ (catch $javascript_exception (call $caml_handle_sys_error (pop externref)) (return (ref.i31 (i32.const 0)))))) +)) +(@if wasi +(@then + (func (export "caml_sys_rmdir") + (param $name (ref eq)) (result (ref eq)) + (local $p (tuple i32 i32 i32)) + (local $res i32) + (local.set $p (call $caml_sys_resolve_path (local.get $name))) + (local.set $res + (call $path_remove_directory + (tuple.extract 3 0 (local.get $p)) + (tuple.extract 3 1 (local.get $p)) + (tuple.extract 3 2 (local.get $p)))) + (call $free (tuple.extract 3 1 (local.get $p))) + (if (local.get $res) + (then (call $caml_handle_sys_error (local.get $name) (local.get $res)))) + (ref.i31 (i32.const 0))) +) +(@else (func (export "caml_sys_rmdir") (param $name (ref eq)) (result (ref eq)) (try @@ -101,7 +605,26 @@ (catch $javascript_exception (call $caml_handle_sys_error (pop externref)))) (ref.i31 (i32.const 0))) +)) +(@if wasi +(@then + (func (export "caml_sys_remove") + (param $name (ref eq)) (result (ref eq)) + (local $p (tuple i32 i32 i32)) + (local $res i32) + (local.set $p (call $caml_sys_resolve_path (local.get $name))) + (local.set $res + (call $path_unlink_file + (tuple.extract 3 0 (local.get $p)) + (tuple.extract 3 1 (local.get $p)) + (tuple.extract 3 2 (local.get $p)))) + (call $free (tuple.extract 3 1 (local.get $p))) + (if (local.get $res) + (then (call $caml_handle_sys_error (local.get $name) (local.get $res)))) + (ref.i31 (i32.const 0))) +) +(@else (func (export "caml_sys_remove") (param $name (ref eq)) (result (ref eq)) (try @@ -111,7 +634,32 @@ (catch $javascript_exception (call $caml_handle_sys_error (pop externref)))) (ref.i31 (i32.const 0))) +)) +(@if wasi +(@then + (func (export "caml_sys_rename") + (param $o (ref eq)) (param $n (ref eq)) (result (ref eq)) + (local $op (tuple i32 i32 i32)) + (local $np (tuple i32 i32 i32)) + (local $res i32) + (local.set $op (call $caml_sys_resolve_path (local.get $o))) + (local.set $np (call $caml_sys_resolve_path (local.get $n))) + (local.set $res + (call $path_rename + (tuple.extract 3 0 (local.get $op)) + (tuple.extract 3 1 (local.get $op)) + (tuple.extract 3 2 (local.get $op)) + (tuple.extract 3 0 (local.get $np)) + (tuple.extract 3 1 (local.get $np)) + (tuple.extract 3 2 (local.get $np)))) + (call $free (tuple.extract 3 1 (local.get $op))) + (call $free (tuple.extract 3 1 (local.get $np))) + (if (local.get $res) + (then (call $caml_handle_sys_error (local.get $o) (local.get $res)))) + (ref.i31 (i32.const 0))) +) +(@else (func (export "caml_sys_rename") (param $o (ref eq)) (param $n (ref eq)) (result (ref eq)) (try @@ -122,11 +670,31 @@ (catch $javascript_exception (call $caml_handle_sys_error (pop externref)))) (ref.i31 (i32.const 0))) +)) +(@if wasi +(@then + (func (export "caml_sys_file_exists") + (param $name (ref eq)) (result (ref eq)) + (local $p (tuple i32 i32 i32)) + (local $res i32) (local $buffer i32) + (local.set $p (call $caml_sys_resolve_path (local.get $name))) + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $path_filestat_get + (tuple.extract 3 0 (local.get $p)) + (i32.const 1) + (tuple.extract 3 1 (local.get $p)) + (tuple.extract 3 2 (local.get $p)) + (local.get $buffer))) + (ref.i31 (i32.eqz (local.get $res)))) +) +(@else (func (export "caml_sys_file_exists") (param $name (ref eq)) (result (ref eq)) (return_call $file_exists (call $unwrap (call $caml_jsstring_of_string (local.get $name))))) +)) (@string $no_such_file ": No such file or directory") @@ -143,6 +711,30 @@ (func (export "caml_fs_init") (result (ref eq)) (ref.i31 (i32.const 0))) +(@if wasi +(@then + (func $caml_sys_file_mode (param $name (ref eq)) (result i32) + (local $p (tuple i32 i32 i32)) + (local $res i32) (local $buffer i32) + (local.set $p (call $caml_sys_resolve_path (local.get $name))) + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $path_filestat_get + (tuple.extract 3 0 (local.get $p)) + (i32.const 1) + (tuple.extract 3 1 (local.get $p)) + (tuple.extract 3 2 (local.get $p)) + (local.get $buffer))) + (if (local.get $res) + (then (call $caml_handle_sys_error (local.get $name) (local.get $res)))) + (i32.load8_u offset=16 (local.get $buffer))) + + (func (export "caml_sys_is_directory") + (param $name (ref eq)) (result (ref eq)) + (ref.i31 + (i32.eq (call $caml_sys_file_mode (local.get $name)) (i32.const 3)))) +) +(@else (func (export "caml_sys_is_directory") (param $name (ref eq)) (result (ref eq)) (try @@ -154,7 +746,16 @@ (catch $javascript_exception (call $caml_handle_sys_error (pop externref)) (return (ref.i31 (i32.const 0)))))) +)) +(@if wasi +(@then + (func (export "caml_sys_is_regular_file") + (param $name (ref eq)) (result (ref eq)) + (ref.i31 + (i32.eq (call $caml_sys_file_mode (local.get $name)) (i32.const 4)))) +) +(@else (func (export "caml_sys_is_regular_file") (param $name (ref eq)) (result (ref eq)) (try @@ -164,6 +765,7 @@ (call $unwrap (call $caml_jsstring_of_string (local.get $name)))))) (catch $javascript_exception - (call $caml_handle_sys_error (pop externref)) - (return (ref.i31 (i32.const 0)))))) + (call $caml_handle_sys_error (pop externref)))) + (return (ref.i31 (i32.const 0)))) +)) ) diff --git a/runtime/wasm/hash.wat b/runtime/wasm/hash.wat index a7a78c9e49..ad9fd4d628 100644 --- a/runtime/wasm/hash.wat +++ b/runtime/wasm/hash.wat @@ -304,6 +304,8 @@ (local.get $v)))))))) (local.set $num (i32.sub (local.get $num) (i32.const 1))) (br $loop))) +(@if (not wasi) +(@then (drop (block $not_jsstring (result anyref) (local.set $str (struct.get $js 0 @@ -315,6 +317,7 @@ (local.set $h (call $jsstring_hash (local.get $h) (local.get $str))) (ref.i31 (i32.const 0)))) +)) ;; closures and continuations and other js values are ignored (br $loop))))) ;; clear the queue to avoid a memory leak diff --git a/runtime/wasm/io.wat b/runtime/wasm/io.wat index 44fd1e4dc6..f28c5e2202 100644 --- a/runtime/wasm/io.wat +++ b/runtime/wasm/io.wat @@ -25,6 +25,31 @@ (func $caml_jsstring_of_string (param (ref eq)) (result (ref eq)))) (import "jslib" "caml_list_of_js_array" (func $caml_list_of_js_array (param (ref eq)) (result (ref eq)))) +(@if wasi +(@then + (import "wasi_snapshot_preview1" "fd_close" + (func $fd_close (param i32) (result i32))) + (import "wasi_snapshot_preview1" "fd_write" + (func $fd_write (param i32 i32 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "fd_read" + (func $fd_read (param i32 i32 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "fd_seek" + (func $fd_seek (param i32 i64 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "path_open" + (func $path_open (param i32 i32 i32 i32 i32 i64 i64 i32 i32) (result i32))) + (import "libc" "memory" (memory 2)) + (import "libc" "free" (func $free (param i32))) + (import "wasi_memory" "get_buffer" (func $get_buffer (result i32))) + (import "wasi_memory" "blit_memory_to_substring" + (func $blit_memory_to_substring (param i32 (ref $bytes) i32 i32))) + (import "wasi_memory" "blit_substring_to_memory" + (func $blit_substring_to_memory (param i32 (ref $bytes) i32 i32))) + (import "sys" "caml_handle_sys_error" + (func $caml_handle_sys_error (param (ref eq) i32))) + (import "fs" "caml_sys_resolve_path" + (func $caml_sys_resolve_path (param (ref eq)) (result i32 i32 i32))) +) +(@else (import "bindings" "open" (func $open (param anyref) (param i32) (param i32) (result i32))) (import "bindings" "close" (func $close (param i32))) @@ -65,6 +90,11 @@ (func $ta_blit_to_bytes (param (ref extern)) (param i32) (param (ref $bytes)) (param i32) (param i32))) + (import "sys" "caml_handle_sys_error" + (func $caml_handle_sys_error (param externref))) + (import "fail" "javascript_exception" + (tag $javascript_exception (param externref))) +)) (import "bindings" "ta_subarray" (func $ta_subarray (param (ref extern)) (param i32) (param i32) (result (ref extern)))) @@ -80,13 +110,129 @@ (func $caml_copy_int64 (param i64) (result (ref eq)))) (import "int64" "Int64_val" (func $Int64_val (param (ref eq)) (result i64))) - (import "fail" "javascript_exception" - (tag $javascript_exception (param externref))) - (import "sys" "caml_handle_sys_error" - (func $caml_handle_sys_error (param externref))) (import "bigarray" "caml_ba_get_data" (func $caml_ba_get_data (param (ref eq)) (result (ref extern)))) +(@if wasi +(@then + (func $ta_new (param $sz i32) (result (ref extern)) + (extern.convert_any (array.new $bytes (i32.const 0) (local.get $sz)))) + + (func $ta_copy + (param $buf (ref extern)) + (param $dst i32) (param $src i32) (param $end i32) + (local $b (ref $bytes)) + (local.set $b + (ref.cast (ref $bytes) (any.convert_extern (local.get $buf)))) + (array.copy $bytes $bytes + (local.get $b) (local.get $dst) + (local.get $b) (local.get $src) + (i32.sub (local.get $end) (local.get $src)))) + + (func $ta_set_ui8 (param $buf (ref extern)) (param $i i32) (param $c i32) + (array.set $bytes + (ref.cast (ref $bytes) (any.convert_extern (local.get $buf))) + (local.get $i) (local.get $c))) + + (func $ta_get_ui8 (param $buf (ref extern)) (param $i i32) (result i32) + (array.get_u $bytes + (ref.cast (ref $bytes) (any.convert_extern (local.get $buf))) + (local.get $i))) + + (func $ta_blit_from_bytes + (param $s (ref $bytes)) (param $i i32) (param $buf (ref extern)) + (param $j i32) (param $l i32) + (array.copy $bytes $bytes + (ref.cast (ref $bytes) (any.convert_extern (local.get $buf))) + (local.get $j) + (local.get $s) (local.get $i) + (local.get $l))) + + (func $ta_blit_to_bytes + (param $buf (ref extern)) (param $i i32) (param $s (ref $bytes)) + (param $j i32) (param $l i32) + (array.copy $bytes $bytes + (local.get $s) (local.get $j) + (ref.cast (ref $bytes) (any.convert_extern (local.get $buf))) + (local.get $i) + (local.get $l))) + + (type $data + (struct + (field $array (ref array)) + (field $offset i32) + (field $len i32))) + + (func $ta_blit_from_buffer + (param $buf (ref extern)) (param $i i32) + (param $ta (ref extern)) (param $j i32) + (param $len i32) + (local $data (ref $data)) + (local.set $data + (ref.cast (ref $data) (any.convert_extern (local.get $ta)))) + (call $ta_blit_to_bytes + (local.get $buf) + (local.get $i) + (ref.cast (ref $bytes) (struct.get $data $array (local.get $data))) + (i32.add (struct.get $data $offset (local.get $data)) (local.get $j)) + (local.get $len))) + + (func $ta_blit_to_buffer + (param $ta (ref extern)) (param $i i32) + (param $buf (ref extern)) (param $j i32) + (param $len i32) + (local $data (ref $data)) + (local.set $data + (ref.cast (ref $data) (any.convert_extern (local.get $ta)))) + (call $ta_blit_from_bytes + (ref.cast (ref $bytes) (struct.get $data $array (local.get $data))) + (i32.add (struct.get $data $offset (local.get $data)) (local.get $i)) + (local.get $buf) + (local.get $j) + (local.get $len))) + + (global $caml_stdout + (mut (ref eq)) (ref.i31 (i32.const 0))) + + (func $register_channel (param $ch (ref eq)) + (if (i32.eq + (struct.get $channel $fd (ref.cast (ref $channel) (local.get $ch))) + (i32.const 1)) + (then + (global.set $caml_stdout (local.get $ch))))) + + (func $unregister_channel (param (ref eq))) + (func $map_new (result (ref extern)) + (extern.convert_any (ref.i31 (i32.const 0)))) + (func $map_get (param (ref extern)) (param i32) (result (ref $fd_offset)) + (struct.new $fd_offset (i64.const 0) (i32.const 0))) + (func $map_set (param (ref extern)) (param i32) (param (ref $fd_offset))) + (func $map_delete (param (ref extern)) (param i32)) + + (func $file_size (param $fd i32) (result i64) + (local $cur i64) (local $end i64) (local $buffer i32) (local $res i32) + (local.set $buffer (call $get_buffer)) + (block $error + (local.set $res + (call $fd_seek + (local.get $fd) (i64.const 0) (i32.const 1) (local.get $buffer))) + (br_if $error (local.get $res)) + (local.set $cur (i64.load (local.get $buffer))) + (local.set $res + (call $fd_seek + (local.get $fd) (i64.const 0) (i32.const 2) (local.get $buffer))) + (br_if $error (local.get $res)) + (local.set $end (i64.load (local.get $buffer))) + (local.set $res + (call $fd_seek + (local.get $fd) (local.get $cur) (i32.const 0) + (local.get $buffer))) + (br_if $error (local.get $res)) + (return (local.get $end))) + (call $caml_handle_sys_error (ref.i31 (i32.const 0)) (local.get $res)) + (i64.const 0)) +) +(@else (import "bindings" "map_new" (func $map_new (result (ref extern)))) (import "bindings" "map_get" (func $map_get @@ -97,6 +243,26 @@ (import "bindings" "map_delete" (func $map_delete (param (ref extern)) (param i32))) + (func $ta_blit_from_buffer + (param $buf (ref extern)) (param $i i32) + (param $ta (ref extern)) (param $j i32) + (param $len i32) + (call $ta_set + (local.get $ta) + (call $ta_subarray (local.get $buf) (local.get $i) + (i32.add (local.get $i) (local.get $len))) + (local.get $j))) + + (func $ta_blit_to_buffer + (param $ta (ref extern)) (param $i i32) + (param $buf (ref extern)) (param $j i32) + (param $len i32) + (call $ta_set (local.get $buf) + (call $ta_subarray (local.get $ta) (local.get $i) + (i32.add (local.get $i) (local.get $len))) + (local.get $j))) +)) + (type $block (array (mut (ref eq)))) (type $bytes (array (mut i8))) (type $offset_array (array (mut i64))) @@ -193,7 +359,24 @@ (global $IO_BUFFER_SIZE (export "IO_BUFFER_SIZE") i32 (i32.const 65536)) - (type $open_flags (array i8)) + (type $open_flags (array i16)) + +(@if wasi +(@then + ;; 1 O_RDONLY + ;; 2 O_WRONLY + ;; 0x10 O_CREAT + ;; 0x40 O_EXCL + ;; 0x80 O_TRUNC + ;; 0x100 O_APPEND + ;; 0x400 O_NONBLOCK + (global $sys_open_flags (ref $open_flags) + (array.new_fixed $open_flags 9 + (i32.const 1) (i32.const 2) (i32.const 0x102) (i32.const 0x10) + (i32.const 0x80) (i32.const 0x40) (i32.const 0) (i32.const 0) + (i32.const 0x400))) +) +(@else ;; 1 O_RDONLY ;; 2 O_WRONLY ;; 4 O_RDWR @@ -206,6 +389,7 @@ (array.new_fixed $open_flags 9 (i32.const 1) (i32.const 2) (i32.const 10) (i32.const 16) (i32.const 32) (i32.const 64) (i32.const 0) (i32.const 0) (i32.const 128))) +)) (func $convert_flag_list (export "convert_flag_list") (param $tbl (ref $open_flags)) (param $vflags (ref eq)) (result i32) @@ -227,6 +411,41 @@ (br $loop)))) (local.get $flags)) +(@if wasi +(@then + (func (export "caml_sys_open") + (param $vpath (ref eq)) (param $vflags (ref eq)) (param $perm (ref eq)) + (result (ref eq)) + (local $fd i32) (local $flags i32) (local $offset i64) + (local $path (tuple i32 i32 i32)) + (local $res i32) (local $buffer i32) + (local.set $path (call $caml_sys_resolve_path (local.get $vpath))) + (local.set $buffer (call $get_buffer)) + (local.set $flags + (call $convert_flag_list + (global.get $sys_open_flags) (local.get $vflags))) + (local.set $res + (call $path_open + (tuple.extract 3 0 (local.get $path)) + (i32.const 1) ;; symlink_follow + (tuple.extract 3 1 (local.get $path)) + (tuple.extract 3 2 (local.get $path)) + (i32.and (i32.shr_u (local.get $flags) (i32.const 4)) + (i32.const 0xF)) + (select (i64.const 0x860007c) (i64.const 0x820003e) + (i32.and (local.get $flags) (i32.const 2))) + (i64.const 0) + (i32.shr_u (local.get $flags) (i32.const 8)) + (local.get $buffer))) + (call $free (tuple.extract 3 1 (local.get $path))) + (if (local.get $res) + (then + (call $caml_handle_sys_error (local.get $vpath) (local.get $res)))) + (local.set $fd (i32.load (local.get $buffer))) + (call $initialize_fd_offset (local.get $fd) (local.get $offset)) + (ref.i31 (local.get $fd))) +) +(@else (func (export "caml_sys_open") (param $path (ref eq)) (param $vflags (ref eq)) (param $perm (ref eq)) (result (ref eq)) @@ -243,14 +462,30 @@ (local.get $flags) (i31.get_u (ref.cast (ref i31) (local.get $perm))))) (if (i32.and (local.get $flags) (i32.const 4)) ;; O_APPEND - (then (local.set $offset (call $file_size (local.get $fd)))))) + (then (local.set $offset (call $file_size (local.get $fd))))) + ) (catch $javascript_exception (call $caml_handle_sys_error (pop externref)))) (call $initialize_fd_offset (local.get $fd) (local.get $offset)) (ref.i31 (local.get $fd))) +)) +(@if wasi +(@then (func (export "caml_sys_close") (param (ref eq)) (result (ref eq)) - (local $fd i32) + (local $fd i32) (local $res i32) + (local.set $fd (i31.get_u (ref.cast (ref i31) (local.get 0)))) + (call $release_fd_offset (local.get $fd)) + (local.set $res (call $fd_close (local.get $fd))) + (if (local.get $res) + (then + (call $caml_handle_sys_error + (ref.i31 (i32.const 0)) (local.get $res)))) + (ref.i31 (i32.const 0))) +) +(@else + (func (export "caml_sys_close") (param (ref eq)) (result (ref eq)) + (local $fd i32) (local $res i32) (local.set $fd (i31.get_u (ref.cast (ref i31) (local.get 0)))) (call $release_fd_offset (local.get $fd)) (try @@ -259,14 +494,40 @@ (catch $javascript_exception (call $caml_handle_sys_error (pop externref)))) (ref.i31 (i32.const 0))) +)) (func (export "caml_ml_set_channel_name") (param (ref eq)) (param (ref eq)) (result (ref eq)) (ref.i31 (i32.const 0))) +(@if wasi +(@then + (func $push_channel (param $l (ref eq)) (param $ch (ref eq)) (result (ref eq)) + (local $c (ref $channel)) + (block $continue + (br_if $continue (i32.eqz (ref.test (ref $channel) (local.get $ch)))) + (local.set $c (ref.cast (ref $channel) (local.get $ch))) + (br_if $continue + (i32.eq (struct.get $channel $fd (local.get $c)) (i32.const -1))) + (local.set $l + (array.new_fixed $block 3 + (ref.i31 (i32.const 0)) (local.get $ch) (local.get $l)))) + (local.get $l)) +)) + +(@if wasi +(@then + (func (export "caml_ml_out_channels_list") + (param (ref eq)) (result (ref eq)) + (call $push_channel + (call $push_channel (ref.i31 (i32.const 0)) (global.get $caml_stdout)) + (global.get $caml_stderr))) +) +(@else (func (export "caml_ml_out_channels_list") (param (ref eq)) (result (ref eq)) (return_call $caml_list_of_js_array (call $wrap (call $channel_list)))) +)) (func (export "caml_ml_open_descriptor_in") (param $fd (ref eq)) (result (ref eq)) @@ -316,16 +577,13 @@ (local.set $fd (struct.get $channel $fd (ref.cast (ref $channel) (local.get $ch)))) (if (i32.eq (local.get $fd) (i32.const -1)) - (then - (call $caml_raise_sys_error - (array.new_data $bytes $bad_file_descriptor - (i32.const 0) (i32.const 19))))) + (then (call $caml_raise_sys_error (global.get $bad_file_descriptor)))) (ref.i31 (local.get $fd))) (func (export "caml_ml_close_channel") (param (ref eq)) (result (ref eq)) (local $ch (ref $channel)) - (local $fd i32) + (local $fd i32) (local $res i32) (local.set $ch (ref.cast (ref $channel) (local.get 0))) ;; output channels: any output will trigger a flush since the ;; buffer is non-empty (curr > 0) and full (curr = size) @@ -340,14 +598,56 @@ (struct.set $channel $fd (local.get $ch) (i32.const -1)) (call $unregister_channel (local.get $ch)) (call $release_fd_offset (local.get $fd)) +(@if wasi +(@then + (local.set $res (call $fd_close (local.get $fd))) + (if (local.get $res) + (then + (call $caml_handle_sys_error + (ref.i31 (i32.const 0)) (local.get $res)))) +) +(@else (try (do (call $close (local.get $fd))) (catch $javascript_exception ;; ignore exception - (drop (pop externref)))))) + (drop (pop externref)))) +)) + )) (ref.i31 (i32.const 0))) +(@if wasi +(@then + (func $read + (param $fd i32) (param $buf (ref extern)) (param $pos i32) (param $n i32) + (result i32) + (local $buffer i32) + (local $iovs i32) (local $iovs_len i32) (local $nread i32) + (local $s (ref $bytes)) (local $res i32) + (local.set $buffer (call $get_buffer)) + (local.set $nread (local.get $buffer)) + (local.set $iovs (i32.add (local.get $buffer) (i32.const 4))) + (local.set $buffer (i32.add (local.get $buffer) (i32.const 12))) + (i32.store (local.get $iovs) (local.get $buffer)) + (i32.store offset=4 (local.get $iovs) (local.get $n)) + (local.set $iovs_len (i32.const 1)) + (local.set $res + (call $fd_read + (local.get $fd) (local.get $iovs) (local.get $iovs_len) + (local.get $nread))) + (if (local.get $res) + (then + (call $caml_handle_sys_error + (ref.i31 (i32.const 0)) (local.get $res)))) + (local.set $n (i32.load (local.get $nread))) + (local.set $s + (ref.cast (ref $bytes) (any.convert_extern (local.get $buf)))) + (call $blit_memory_to_substring + (local.get $buffer) (local.get $s) (local.get $pos) (local.get $n)) + (local.get $n)) +)) + (func $caml_do_read (param $ch (ref $channel)) (param $pos i32) (param $len i32) (result i32) (local $fd i32) @@ -355,6 +655,16 @@ (local $offset i64) (local $n i32) (local.set $fd (struct.get $channel $fd (local.get $ch))) +(@if wasi +(@then + (local.set $n + (call $read + (local.get $fd) + (struct.get $channel $buffer (local.get $ch)) + (local.get $pos) + (local.get $len))) +) +(@else (local.set $fd_offset (call $get_fd_offset (local.get $fd))) (local.set $offset (struct.get $fd_offset $offset (local.get $fd_offset))) (try @@ -381,6 +691,7 @@ (struct.set $fd_offset $offset (local.get $fd_offset) (i64.add (local.get $offset) (i64.extend_i32_u (local.get $n)))) +)) (local.get $n)) (func $caml_refill (param $ch (ref $channel)) (result i32) @@ -453,12 +764,12 @@ (then (if (i32.gt_u (local.get $len) (local.get $avail)) (then (local.set $len (local.get $avail)))) - (call $ta_set (local.get $d) - (call $ta_subarray (struct.get $channel $buffer (local.get $ch)) - (struct.get $channel $curr (local.get $ch)) - (i32.add (struct.get $channel $curr (local.get $ch)) - (local.get $len))) - (local.get $pos)) + (call $ta_blit_from_buffer + (struct.get $channel $buffer (local.get $ch)) + (struct.get $channel $curr (local.get $ch)) + (local.get $d) + (local.get $pos) + (local.get $len)) (struct.set $channel $curr (local.get $ch) (i32.add (struct.get $channel $curr (local.get $ch)) (local.get $len))) @@ -469,10 +780,12 @@ (struct.set $channel $max (local.get $ch) (local.get $nread)) (if (i32.gt_u (local.get $len) (local.get $nread)) (then (local.set $len (local.get $nread)))) - (call $ta_set (local.get $d) - (call $ta_subarray (struct.get $channel $buffer (local.get $ch)) - (i32.const 0) (local.get $len)) - (local.get $pos)) + (call $ta_blit_from_buffer + (struct.get $channel $buffer (local.get $ch)) + (i32.const 0) + (local.get $d) + (local.get $pos) + (local.get $len)) (struct.set $channel $curr (local.get $ch) (local.get $len)) (local.get $len)) @@ -568,9 +881,7 @@ (ref.i31 (i32.sub (i32.wrap_i64 - (struct.get $fd_offset $offset - (call $get_fd_offset - (struct.get $channel $fd (local.get $ch))))) + (call $caml_ml_get_channel_offset (local.get $ch))) (i32.sub (struct.get $channel $max (local.get $ch)) (struct.get $channel $curr (local.get $ch)))))) @@ -581,9 +892,7 @@ (local.set $ch (ref.cast (ref $channel) (local.get $vch))) (call $caml_copy_int64 (i64.sub - (struct.get $fd_offset $offset - (call $get_fd_offset - (struct.get $channel $fd (local.get $ch)))) + (call $caml_ml_get_channel_offset (local.get $ch)) (i64.extend_i32_s (i32.sub (struct.get $channel $max (local.get $ch)) @@ -595,10 +904,7 @@ (local.set $ch (ref.cast (ref $channel) (local.get $vch))) (ref.i31 (i32.add - (i32.wrap_i64 - (struct.get $fd_offset $offset - (call $get_fd_offset - (struct.get $channel $fd (local.get $ch))))) + (i32.wrap_i64 (call $caml_ml_get_channel_offset (local.get $ch))) (struct.get $channel $curr (local.get $ch))))) (func (export "caml_ml_pos_out_64") @@ -607,9 +913,7 @@ (local.set $ch (ref.cast (ref $channel) (local.get $vch))) (call $caml_copy_int64 (i64.add - (struct.get $fd_offset $offset - (call $get_fd_offset - (struct.get $channel $fd (local.get $ch)))) + (call $caml_ml_get_channel_offset (local.get $ch)) (i64.extend_i32_s (struct.get $channel $curr (local.get $ch)))))) (;ZZZ @@ -623,6 +927,26 @@ ))) ;) +(@if wasi +(@then + (func $caml_seek_in + (param $ch (ref $channel)) (param $dest i64) (result (ref eq)) + (local $fd i32) (local $buffer i32) (local $res i32) + (local.set $fd (struct.get $channel $fd (local.get $ch))) + (local.set $buffer (call $get_buffer)) + ;; ZZZ store current offset in channel do avoid some syscalls? + (local.set $res + (call $fd_seek + (local.get $fd) (local.get $dest) (i32.const 0) (local.get $buffer))) + (if (local.get $res) + (then + (call $caml_handle_sys_error + (ref.i31 (i32.const 0)) (local.get $res)))) + (struct.set $channel $curr (local.get $ch) (i32.const 0)) + (struct.set $channel $max (local.get $ch) (i32.const 0)) + (ref.i31 (i32.const 0))) +) +(@else (func $caml_seek_in (param $ch (ref $channel)) (param $dest i64) (result (ref eq)) (local $fd i32) (local $offset i64) @@ -654,6 +978,7 @@ (struct.set $channel $curr (local.get $ch) (i32.const 0)) (struct.set $channel $max (local.get $ch) (i32.const 0)))) (ref.i31 (i32.const 0))) +)) (func (export "caml_ml_seek_in") (param $ch (ref eq)) (param $dest (ref eq)) (result (ref eq)) @@ -670,8 +995,25 @@ (param $vch (ref eq)) (param $voffset (ref eq)) (result (ref eq)) (local $ch (ref $channel)) (local $fd_offset (ref $fd_offset)) + (local $buffer i32) (local $res i32) (local.set $ch (ref.cast (ref $channel) (local.get $vch))) (call $caml_flush (local.get $ch)) +(@if wasi +(@then + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $fd_seek + (struct.get $channel $fd (local.get $ch)) + (i64.extend_i32_s + (i31.get_s (ref.cast (ref i31) (local.get $voffset)))) + (i32.const 0) + (local.get $buffer))) + (if (local.get $res) + (then + (call $caml_handle_sys_error + (ref.i31 (i32.const 0)) (local.get $res)))) +) +(@else ;; ZZZ Check for error (local.set $fd_offset (call $get_fd_offset (struct.get $channel $fd (local.get $ch)))) @@ -679,20 +1021,38 @@ (i64.extend_i32_s (i31.get_s (ref.cast (ref i31) (local.get $voffset))))) (struct.set $fd_offset $seeked (local.get $fd_offset) (i32.const 1)) +)) (ref.i31 (i32.const 0))) (func (export "caml_ml_seek_out_64") (param $vch (ref eq)) (param $voffset (ref eq)) (result (ref eq)) (local $ch (ref $channel)) (local $fd_offset (ref $fd_offset)) + (local $buffer i32) (local $res i32) (local.set $ch (ref.cast (ref $channel) (local.get $vch))) (call $caml_flush (local.get $ch)) +(@if wasi +(@then + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $fd_seek + (struct.get $channel $fd (local.get $ch)) + (call $Int64_val (local.get $voffset)) + (i32.const 0) + (local.get $buffer))) + (if (local.get $res) + (then + (call $caml_handle_sys_error + (ref.i31 (i32.const 0)) (local.get $res)))) +) +(@else ;; ZZZ Check for error (local.set $fd_offset (call $get_fd_offset (struct.get $channel $fd (local.get $ch)))) (struct.set $fd_offset $offset (local.get $fd_offset) (call $Int64_val (local.get $voffset))) (struct.set $fd_offset $seeked (local.get $fd_offset) (i32.const 1)) +)) (ref.i31 (i32.const 0))) (func (export "caml_ml_input_scan_line") @@ -769,6 +1129,36 @@ (then (call $caml_flush (local.get $ch)))) (ref.i31 (i32.const 0))) +(@if wasi +(@then + (func $write + (param $fd i32) (param $buf (ref extern)) (param $pos i32) (param $n i32) + (result i32) + (local $buffer i32) + (local $iovs i32) (local $iovs_len i32) (local $nwritten i32) + (local $s (ref $bytes)) (local $res i32) + (local.set $buffer (call $get_buffer)) + (local.set $nwritten (local.get $buffer)) + (local.set $iovs (i32.add (local.get $buffer) (i32.const 4))) + (local.set $buffer (i32.add (local.get $buffer) (i32.const 12))) + (i32.store (local.get $iovs) (local.get $buffer)) + (i32.store offset=4 (local.get $iovs) (local.get $n)) + (local.set $iovs_len (i32.const 1)) + (local.set $s + (ref.cast (ref $bytes) (any.convert_extern (local.get $buf)))) + (call $blit_substring_to_memory + (local.get $buffer) (local.get $s) (local.get $pos) (local.get $n)) + (local.set $res + (call $fd_write + (local.get $fd) (local.get $iovs) (local.get $iovs_len) + (local.get $nwritten))) + (if (local.get $res) + (then + (call $caml_handle_sys_error + (ref.i31 (i32.const 0)) (local.get $res)))) + (i32.load (local.get $nwritten))) +)) + (func $caml_flush_partial (param $ch (ref $channel)) (result i32) (local $towrite i32) (local $written i32) (local $fd i32) (local $fd_offset (ref $fd_offset)) @@ -778,6 +1168,16 @@ (then (local.set $buf (struct.get $channel $buffer (local.get $ch))) (local.set $fd (struct.get $channel $fd (local.get $ch))) +(@if wasi +(@then + (local.set $written + (call $write + (local.get $fd) + (local.get $buf) + (i32.const 0) + (local.get $towrite))) +) +(@else (local.set $fd_offset (call $get_fd_offset (local.get $fd))) (local.set $offset (struct.get $fd_offset $offset (local.get $fd_offset))) @@ -807,6 +1207,7 @@ (i64.add (local.get $offset) (i64.extend_i32_u (local.get $written)))) +)) (if (i32.gt_u (local.get $towrite) (local.get $written)) (then (call $ta_copy (local.get $buf) @@ -847,10 +1248,10 @@ (if (i32.ge_u (local.get $len) (local.get $free)) (then (local.set $len (local.get $free)))) (local.set $buf (struct.get $channel $buffer (local.get $ch))) - (call $ta_set (local.get $buf) - (call $ta_subarray (local.get $d) - (local.get $pos) (i32.add (local.get $pos) (local.get $len))) - (local.get $curr)) + (call $ta_blit_to_buffer + (local.get $d) (local.get $pos) + (local.get $buf) (local.get $curr) + (local.get $len)) (struct.set $channel $curr (local.get $ch) (i32.add (local.get $curr) (local.get $len))) (if (i32.ge_u (local.get $len) (local.get $free)) @@ -977,11 +1378,31 @@ (struct.set $channel $fd (ref.cast (ref $channel) (local.get 0)) (local.get 1))) - (func (export "caml_ml_get_channel_offset") (param $ch (ref eq)) (result i64) +(@if wasi +(@then + (func $caml_ml_get_channel_offset (export "caml_ml_get_channel_offset") + (param $ch (ref eq)) (result i64) + (local $fd i32) (local $buffer i32) (local $res i32) + (local.set $fd + (struct.get $channel $fd (ref.cast (ref $channel) (local.get $ch)))) + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $fd_seek + (local.get $fd) (i64.const 0) (i32.const 1) (local.get $buffer))) + (if (local.get $res) + (then + (call $caml_handle_sys_error + (ref.i31 (i32.const 0)) (local.get $res)))) + (i64.load (local.get $buffer))) +) +(@else + (func $caml_ml_get_channel_offset (export "caml_ml_get_channel_offset") + (param $ch (ref eq)) (result i64) (struct.get $fd_offset $offset (call $get_fd_offset (struct.get $channel $fd (ref.cast (ref $channel) (local.get $ch)))))) +)) (func (export "caml_ml_output_bigarray") (param $ch (ref eq)) (param $a (ref eq)) (param $vpos (ref eq)) diff --git a/runtime/wasm/jslib.wat b/runtime/wasm/jslib.wat index 9ac0c66f7f..1d6038c75d 100644 --- a/runtime/wasm/jslib.wat +++ b/runtime/wasm/jslib.wat @@ -16,6 +16,8 @@ ;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (module +(@if (not wasi) +(@then (import "bindings" "identity" (func $to_float (param anyref) (result f64))) (import "bindings" "identity" (func $from_float (param f64) (result anyref))) (import "bindings" "identity" (func $to_bool (param anyref) (result i32))) @@ -686,4 +688,5 @@ (return (array.get $block (local.get $exn) (i32.const 2))))))) (call $wrap (ref.null any))) +)) ) diff --git a/runtime/wasm/jslib_js_of_ocaml.wat b/runtime/wasm/jslib_js_of_ocaml.wat index 5f3c4c14e0..ec69833df0 100644 --- a/runtime/wasm/jslib_js_of_ocaml.wat +++ b/runtime/wasm/jslib_js_of_ocaml.wat @@ -16,6 +16,8 @@ ;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (module +(@if (not wasi) +(@then (import "jslib" "wrap" (func $wrap (param anyref) (result (ref eq)))) (import "jslib" "unwrap" (func $unwrap (param (ref eq)) (result anyref))) (import "jslib" "caml_js_global" @@ -56,4 +58,5 @@ (call $caml_js_global (ref.i31 (i32.const 0))) (global.get $XMLHttpRequest)) (array.new_fixed $block 1 (ref.i31 (i32.const 0))))) +)) ) diff --git a/runtime/wasm/jsstring.wat b/runtime/wasm/jsstring.wat index de0780d990..c769ea514a 100644 --- a/runtime/wasm/jsstring.wat +++ b/runtime/wasm/jsstring.wat @@ -16,6 +16,8 @@ ;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (module +(@if (not wasi) +(@then (import "wasm:js-string" "compare" (func $compare_strings (param externref externref) (result i32))) (import "wasm:js-string" "test" @@ -257,4 +259,5 @@ (local.set $s (array.new $bytes (i32.const 0) (local.get $len))) (call $read_from_buffer (local.get $s) (i32.const 0) (local.get $len)) (global.set $stack (struct.new $stack (local.get $s) (global.get $stack)))) +)) ) diff --git a/runtime/wasm/libc.c b/runtime/wasm/libc.c new file mode 100644 index 0000000000..3b0c44bd04 --- /dev/null +++ b/runtime/wasm/libc.c @@ -0,0 +1,175 @@ +/* +Primitives implemented by the WASI libc. Use 'dune build @recompile-libc' +to update libc.wasm. + +clang -O2 --target=wasm32-wasi --sysroot=/path/to/wasi-libc/sysroot -nodefaultlibs -lc libc.c -o libc.wasm +*/ + +#include +#include +#include +#include +#include + +__attribute__((export_name("cos"))) +double libc_cos (double x) { + return cos(x); +} + +__attribute__((export_name("sin"))) +double libc_sin (double x) { + return sin(x); +} + +__attribute__((export_name("tan"))) +double libc_tan (double x) { + return tan(x); +} + +__attribute__((export_name("acos"))) +double libc_acos (double x) { + return acos(x); +} + +__attribute__((export_name("asin"))) +double libc_asin (double x) { + return asin(x); +} + +__attribute__((export_name("atan"))) +double libc_atan (double x) { + return atan(x); +} + +__attribute__((export_name("cosh"))) +double libc_cosh (double x) { + return cosh(x); +} + +__attribute__((export_name("sinh"))) +double libc_sinh (double x) { + return sinh(x); +} + +__attribute__((export_name("tanh"))) +double libc_tanh (double x) { + return tanh(x); +} + +__attribute__((export_name("acosh"))) +double libc_acosh (double x) { + return acosh(x); +} + +__attribute__((export_name("asinh"))) +double libc_asinh (double x) { + return asinh(x); +} + +__attribute__((export_name("atanh"))) +double libc_atanh (double x) { + return atanh(x); +} + +__attribute__((export_name("cbrt"))) +double libc_cbrt (double x) { + return cbrt(x); +} + +__attribute__((export_name("exp"))) +double libc_exp (double x) { + return exp(x); +} + +__attribute__((export_name("expm1"))) +double libc_expm1 (double x) { + return expm1(x); +} + +__attribute__((export_name("log"))) +double libc_log (double x) { + return log(x); +} + +__attribute__((export_name("log1p"))) +double libc_log1p (double x) { + return log1p(x); +} + +__attribute__((export_name("log2"))) +double libc_log2 (double x) { + return log2(x); +} + +__attribute__((export_name("log10"))) +double libc_log10 (double x) { + return log10(x); +} + +__attribute__((export_name("atan2"))) +double libc_atan2 (double x, double y) { + return atan2(x, y); +} + +__attribute__((export_name("hypot"))) +double libc_hypot (double x, double y) { + return hypot(x, y); +} + +__attribute__((export_name("pow"))) +double libc_pow (double x, double y) { + return pow(x, y); +} + +__attribute__((export_name("fmod"))) +double libc_fmod (double x, double y) { + return fmod(x, y); +} + +__attribute__((export_name("strtod"))) +double libc_strtod (const char * buf, char ** end) { + return strtod(buf, end); +} + +__attribute__((export_name("format_float"))) +int format_float (char * buf, size_t len, const char * fmt, double f) { + return snprintf(buf, len, fmt, f); +} + +__attribute__((export_name("malloc"))) +void * libc_malloc (size_t len) { + return malloc(len); +} + +__attribute__((export_name("free"))) +void libc_free (void * ptr) { + return free(ptr); +} + +__attribute__((export_name("strlen"))) +size_t libc_strlen (const char * s) { + return strlen(s); +} + + +__attribute__((export_name("gmtime"))) +struct tm * libc_gmtime (const time_t * timep) { + return gmtime(timep); +} + +__attribute__((export_name("localtime"))) +struct tm * libc_localtime (const time_t * timep) { + return localtime(timep); +} + +__attribute__((export_name("mktime"))) +time_t libc_mktime(struct tm *tm) { + return mktime(tm); +} + +__attribute__((import_module("OCaml"), import_name("_initialize"))) +void start(void); + +int main () { + start(); +} diff --git a/runtime/wasm/libc.wasm b/runtime/wasm/libc.wasm new file mode 100644 index 0000000000000000000000000000000000000000..5e3f34061dd970da900036fecb03ad0ee8e5a69f GIT binary patch literal 63480 zcmeF4d4OD1o$t@Rx2mhEt2^DeRCa;x+jJ7b4zfAUJkul%Np~lmUJ`y><45S!9e} zt>e`og;Rs;Z0Qu0Y=uf{t!=|B@~KNhu6{(9@YLH|=;I(_PK?aRCK?^?EE z*}$^)?q%=pFf~&yZ0}$8uKpG6EBlxB47_V)U&rcY9T&bid;XGlE$;5=?=b#rl*mw` zzoVneeT@>eeeElj^elhZ1sww>9~^#IO&$2LKSAXosQ1SOzLI{1 zT))B3WclzK)9Gy5_fq30q|)9>#+D8|CMZT$dSN}kJ z-+)O6i+lRbgrI-f3bSu8(7wXVNwq60lL8AXOg`1F%=#30OU=X-c}vZHDe{(@gVHLw z)MV2ty42LARd%UqOf5c-rpE^zYgU>`Y5p#MvzZcf_grB1PV@K8D@`HA=UYtCCg+;a z)_jX;NH4u;WzT@wGg#Skq1h*O{_>tBW?D`EK;Hll``4Y{)3>~R;9ci;_p}d~nwsV9 z-Q7Kl&6`r^_jPob87kM^vBJ!%xnTLgvgIA7DaY&fZu`7f&GIh$Ff&){naInh<{ozV z5q17mUhT`@^$#oiUN9JyKJLx(O{&G@^%!}F`Q}X~YV0bSnI<$*U1yYPOclJSbRGZS zch{%i9hzBwUFbzScLu#pl%`N)=S&-`Q#o z57gvCqmNrFk9v701@*awPXYe453s8IwBK2*;d8s!SyT&KNM{@0Ot;X@R%s*`_^0u) zjnAVsvcvq)!nuK3z<&e@K4!U(nUrK~C-Kq9Yr3fc7c^P`KbBQev;4VY71uH?ssn1z z@@E!6lK>5)K}I?V^1{>{(-?)lO%~Is$l)eWrR_ef8Ky0VhMD|>=!dmd5v~o*-9^7O zykawqymM!!w-`i2LtA$Sr>0ukO#IU}ZBE;nFBftxq2FrW(G>cd!?;ve-@JNnMx`LY zo8e8M-d{@z+IuB9nRZNhO;qk;dAJ}8Rqk^qGy0PwPE^Qha zW)u~mOLcx;<9>VfK+I_I_-T9dNYPwxM_~u#hV{3PByQ}l97%%ZyGo^DnAT`870@+G zH);#KgIIt6A444qk0Su$-Q7CG&&tcnf*rDWj9^oVKXxqne7@iFVE(&X4-x-1^cGRa z890t1xPk2`+oDv~xJsq#OO3gPJhF97))phLQc@)vy;cd&^^cc+)_e}VdlqaUf2ln94;4Auv9k)S_WINe zb(m1Vm`#GKb#Dej#jj)*Y7{n0DA@M&tuNA6y%$4kjJVQuOV7XGY0lN;Ay|{~G?$9L zAd_hS;7j|UyP`>}K~ERm`boF2yOK$ra%niML2k=KsS^?NO_knU?#9%~O$GFq9c{y9 zHnX`m`qVuecLtrew1$_jFORlVFn8pOYI(cGn-n$@A*LQqZ0YlA3uKWwby=2a&DWTT-zDPes97r@1@+c!6R2M zng5{5z2l?Bt7b0znjSxDRl^HBmZ;^otv>pqLw|AP|2bwPOqEJudbm`|=buOg>9s!A zp(t9Dkns1-7u(_Py#8MA+}&|jJb+S!3M+-)uv9?8M%&9H#Z-xL+0l#?eLFafvhAz$ zo>(>Uj4zZ0&3m`q`uj^SxuY2zwe4KG<+z_*`^EA|+gF}CVAlHHyP8W5R1cK*4x!ikza9mM+kw*wkC_Sa3D1=Py*1rMU7qT7FX zmotVE5`oMB^1CT$bbcMi>WRttVsrJ(<%d366~vXOmz0;)!wWm5`KUs`Ee#JRM#qcH zGDWkIGHL9Nrh-9W^7&1kj5e4lG}i)Li#RH%%zS=yZ5Ep?^s48of+sWBkA~bUU`WIm z5QXT3-eBHR2%IC zz$m36@@g({zikJ1cOKaG`4N=M#y>xM#++wwDKjlC-#BpVueRK-$KEM#dgaT#cj@u| zpIjp)&LfQICoQ0H#(%r`+)=k|0EnN|ubz40dp^@l>C=zdRyx1_Ha)HgPkP|1^X|~& z&dbb4G(+%MpJ@M)f>(uFL5Z$H`wutdqhO%OispGEJ(=WFc$>=^Ms=gR#gVA#Q5q=Jt#t<6_# z?kfa-3%a{%F_NN|>iGP!dhol(`Nj(pLCdu?R35k5CN<-+hVet&(=Lp~^2NfEnQ!?< zU}YAdC<8{1h-m0E;&g6ifh{}~c7~}_HLhLSVvelLiAD?wlTy~#(nbv6ZMqgQC>Q~5 zLHD}G1;+DJyxcenbqieT7DB^!m7qg)GVU?ARp_)ZmMn};9lSeU!NtnJO)!2%9R$&z ztsxvl-$Rlu6G>xv)gq4}u&E>kkyw>G&@hO?(}=6bl-EfhH{b>@J}P_D&sVdE&b#XSA6NkKi+gVD&@A%-~Fkd7mlU$ zEoWRebn3c~dX8DjirGO{ z5*xF4CJK7-?TiaNKQI-g$oQ&;mKrXmM~9Xk4pYM#zkXkLXws*);OmbHtu}%QR);DU z+RR2Fc%j7-)*X!`_=UGgsol1<-+25Vj{4RM$DmuUoBe?wzVHtq$aZ(}E4Q8V+@24D z@^7@?1M&|L%5QwBas2r4mxy~j;V~F44R0K4+x$Np_C_nx|9#`eWVe2${H>nnEZu91 zsPuSE{Llw~-ORdalhNJ8YjoEwhkuqH&1zItW3^7YmJq4Ea+P_7o{pn zv?h8u(-k#qDPB{^s8QvRtU!upu8H2Cm93OY^wkmCn8R6iFFjy(F zquJ?M=_^^&aj_lEi&HF?Dk-h(D1cTfRpmPJ}nK2F5q-719;YL&4Rw&XKZ~Mfk@nZ||;tYuO*G*t9vm_&sDZ z_GdfV^+wp?+9VwCR ze_l(-$Q05tW)f=1O^9m-O`QC;&ABhP;*LLm;7cQIN1pM+%fIsYHcc^ieCM;Dn*P`% zDa!Yr^$I%kAKBpR+Je7>qFWB}>9-E%Z#zCRxF0cujzi!E|U1 zCE2dS@R#OCEr;|A&b?0TEZ@^gfp>B10G>RRWlbdm+E%s*tE9I#my#-GtH|kagJ8wg z0of9HX9iQ`kju+VgX!og`OVVK^jR`2p+a2nOT^PJ5sTPyLB zN+V(T+Tq#hTrL^>sw8s)pobY;Qg5iX z3RS>38yxzDfZP&~7px`^?BuZ0;uI=BPkXpxZUGbsp#bJ$DWIgUthsP^` zb$vPi)4Z3lbC%s^jIv#*N)x5JwDsskYkG^OvycWZw%mFdtjB6g3JdR}EkW_<^LE$M zd5gTxg7HC>-xA$vv%^4JmK3f7Dm?3+mc=lGHY-yL>iy^jHcI(VYZ0r!C|G@AuXf(h z8I+kOE~qq-#dP%91tg2@uWTLbAj(WCdZ|H1HK~)a&GH+I-n@Fi!<=9R0P0eZ-D3qg zsgwD}x8)g#&wH1qf+dnR#f;3owB1jYB^oTCr8H2j1Ey4T^T$2y#W8!i4`Isd1NbZ(0S3~KTw@WB5V4-N@xA!>{! zg*A+e8ci$?)xQr3)MbtK3Eh}2R>4YRXmK9;^tD-OEOp=;syW_Di#=^47H<{aa(v);D{Xm;LYB9r zt^YdSf}9m*3M-=<#Uac$hHdEaRcs^t{bg*E-aXs6;k=q{$Y<2MVVm6mTt#$Kkq)S3 zVmUWZEqe6hC zNWo2eqfO|A3BbD9qJ2qaS6@){x>lp8U>9$oD>}AQGKlGSn7@Zyi-#i}ejn1EKKClvxO;|Mpv0aD#{8r6HTWHZ*^BB6|(n&rUAW$f1Ro+0(;7`>U@kh zKiYG(bPT{q`Gu({)!Pa06jh;^LhIPZJvEM-hbg5pepp(=kFu&5WjhNQikise3+a$q z%qjti2TF%}4mp-U1RI#>e#DCZ^rC4<`}#)FCHeeeNG|4gbk`@m#y!TyIz$GvKK}_X zx=Tf)XFlNxVYX=gTY;Y&4Ax;?)}YNy>m|SY?T(#~Z+pqGt@Zv7TsgG;*?(SlCMw0W z4*kb39|$fk@~|mASj@K$efQnCn%9!i{Jt>1mYmyun;k6Hw?6)X3)d;5PA}@$wr-&L zX;Bc?$=OF4G+kIHPZ7zRKk2Uki(7u1?b7qYreY>~@&^}phXhaf(HHW|d3nnx{VpDP zmxaPOAD%beowS#Y9vO%W{>)dw&*!_MpQ(*p=gn*3qjZ>yJ{q@WiM97Bn(blj+nPEH zwS2<9Y{y_@L6q794N*s@*f}?dawitkw`dI4i4!ljlkG|&0#*uh^RPwe-z?~Z>ThE} z(dYaw`}cTIya$Eyt-;#X%q7LV2A$E6^BS_Wy0}GADUtwV9iW@iDqv!qY}jLkoEuyZ~ zQt9q6xckgvuBnI>D2tDs%$*Hqu%zN$m}`<2)=CYIaeh}yWGPYEx!WApZ0?HgF<_Dk z0Y)loyi8(??D(FMeW*pJe&$ZXH(0Tvlu9hBEnSG*s3}`9`hN7Lv*lDu8rafR-GEX_ z19K(JW#_8_QXpV`I_pv3$ZM+mvD`NC`UF`5Nz0SC2Sxg8(8D1jvkOj zl}QXx;sMUaKD%U1AxCB?63d|%oB{2!n`PqIB+hk!jC&)bfH~}u3#pROz`AHve{~PyJ0RgqB_16ptU|Qfe?u`{0q#bsSR|R;aco9y1 z&m-TVMZbjoEdtkQ(O;=!6f}Tnh}L!$Y8@SL#p^{0s40H`!YBbIwqbFGbxp*eh3U4# zX8&^huU~nG-Re!1+P-ni#;+W4)qfl#|7poB$sD0``Il0b(1e@X-Crj}J3jWAB&6W_ zkF9@oNWmyZd|?DX5bJ#z_MzOw;NtheQP1Qae3liha|is01$8l{AOnk*8Wue&cK*-* zVb;O7Z>8ALM;y5M`S;&TF|to++HvL+>+dJ~6PuUZ)javZvfa$)&0#;ff3MZ;U*XLQ zSFZkU?!m`gh3DV7ip@QuPpbu;pdgZ`BM5qLn~qPVO?p#!Y; zP&7gA4Mh_em?>WOD4w9+pMj1ijvx*u5bMXgOb9YK*(9q!VX9rD2{ICixHUx+WLpm+ zbN~h=av&F7bFAI$%GwYE9Bg#7!DVGa$&3B50R+7GvUP?HQ|6lZk%jXpt%6ZpI9kNy z5=j8>pg&Cg{yygkw|9Ny|IE7G;Z{^S{-hwr?#lS@c6vTqZ}M z;*q3sZy0^t!XruL-aPtvCyykR`}xtwtvr%c?p>pg5AjG+x%ZDgZsU=pa-Zh$QTND4 zlDnP9CtWTdNr4~p_>9ZtBPpJl$| zU@MQGce#8d1s>w@E|<$kQeYd8_q$v^k^+y8=H3N!-FaQQ$im(&w>LQUy6d`h^e^u5 z(Vdy-2)*7)*$>$maZ>n~{XI?II)PK zZfM)$kNhS|Dh`@{1I$yg|!fQkIj3;+h@yZUI_4D>D)q!p-m|DQnR zUD#XHN=Yj?G@OG=jvASV3_OO#HmC@4oPtGZBfafp-o*82i)3Z`jIL>8p9XG6MVNTJ z(yF$mvZ}>*NHt7G_3Ku(tOlJ;&qr3~iBirxk>E(J+7+H%Q40)^lB`nma=zu4CW}}R zfd#u=a%Q?%rlbod0AIqWoE5;!lU>g{5aN>HT-HFauxOg71+7>ivJ~Spdfi^(?*#)@?bM!44VLj@)KA3uAC!A$p&0ofDSm*;zm`(w=xX-!8eLBHrf;j9FInVI!g{fiyBnJGc4ZBZl zk)6VLVTHuvKVI+KzUDW9=2R2iz)b_-TBDYj`0}mO44#QFCx)hVm^_Q?Rfsgz#I`{c za{hr=P?-RQ<8xtwE=5#FPvoJgf?mjDpe?A+TVE$aApcH~xZW~d8WOHi=Mv)~ra4d9 z;#iv3Q`ypxM&(mYD+vh&s(h+AD1a@^N;;;w>v)vrHXYMEScg0{Mvtg|_Woq*o@6lAEO(dRdM1rOq~Hc%5ek%T6|Zf96?V!Z@F z{3369zFC9EDJH8>h3$R_?uw`pHO~BkfcW@ALd-*u*VT(Jp1q+kb25tb6|G=T?5oG+ zLa!BoQ#v{0oeaP=3;XKXA4oMG%s4plM0UZK0HR&HBsfVM@T3Y^H3J(9Qnno6kHPu% z0b2|jbY0$khptK{R%@9~WQzq5b zc<>ByBJI&#-Ws}~6FfxLr6^4wH-VV2+zooQ6ptELw=ky)IAse{&Gy5bstm@41B1!G z^W=K^k(udmL)X?BFC&ybLId0C*)lkaFEQPNDjGVJz}G@bG2JP5C6A7JTElHI*L5I|B#Qce68zIJYlnNTemJQ_f~&oKg&sopNxH5vFVbmEG~0Sr>Ipo5SVXK`k&eI;dB zjXZ}nJFILxEVeTpu(X(t4#(dPraPl%1};=#Td+zo(VKQZ@T|z8f!paAwb>c{bfdSw zFINNVJ-Tif-3x=H6ws=HZFQ)kWfbam*Hr^8IAmFtlF9_ z?WQ``ufJRC7eYX!s!g!UR&>GmkT9{V6=C7UTVNWEP>Rtlb`wNyN}CQwoQdo?6B&qM z7iacqMQDvuW@RQ6?SH{dvUfGEbh7`Y4e(-Gn6%qmd^sH z_Bt#U>`>TNq0lrif$q z{Gx`f4i>;EJ{0$n(vGxv#VHLbXhm^ACKe7(y%ShvgJfzd3d4*l3}lIdV-*I>XcdMP zP>BqyJSQqvhP8PPNZLFH){5fL5lyE!YET@kT6VK+X56o-I1;6Srjyc0#~$^H(qQ(p zP&vt_9o`5O$*|a^hQ;>oH3>u%4-}!C)g?9aHAzaBfK;bT!b_M5)S>pg6>Q?iV`m`Y@nkz-Un5U@9 zZa2;*%|=X_46+iv1*dFCc#&;8{V}#cs`DSvg~H>D5$WTJ;@)R zCfOH&UW46ir9FtM8iH8fWTLs4X=Is0{7E(n6`k2wOht9FVEI^H3?gDiWbbih z3w^L=JYHwk(S_08t2%EEGiwWWThPC_^$NTD%CR&r8v4=thHi@7&xG%<<{{{vM?g|U zC=8(}Lr>lMT&DA8;VaYnywS1b4Z&bB*ScdZL91)oS8RUY<}kOJ*#fIEs|GiKJ+NaV zKIF?~nghqQKmjj$$WwR)bH6W-Pf!qaH~U@MnD=esAy4rW?ocyClrGwW(V7r zd*?d~4N&t1=D1c3g1FIWS~tq;`^3;#o2u((1@x?2+dA~wf4?tSo5w@z+rWicp)XMl zQA?l`(+LDJ^KNaj`vZZ-4hQI35j0NZozQeM+t^y~cuAA0mu=m!$2wjd;-^}VUbl8_ zk>+jq0|P|STFV`JMY9w{GpnxqW$iY{F#S6Ub- z$T-#N#fScP?(8Afqs`c#9nIJ_snbAPygB?*^XYxq%5Z22wRefjT^Wb>R!XfrSIe#$ zqt$lUjqSKmLv3vm2e8VRB4_qD+2tkx?E(%Rnh}{us zFo$WoM;;fZTyY#cq&9|8b!?#Hy%P$03-#eR+K46$6vly_B$j07PIH+oA7PETtI{q2 zfX>XqQJ@_ zs|RYUt{$k5?sSz)MJ*%=<|~Kk;gMn;4G@4)g7>v+mKiREb+}r`G)c@vZPhga_0iV2 zDH>wpu{-x7N=WDF5n4%8|GwsZKRDa$Aa3BrdB=a^oeO{EVlv)+!~PuKd7(VgcFI}r z;HWU?#cgm$jb&3Ec35N&yS<>`j#4oTcs5i)=u0!anDa$+5aP}_)hE#IsNCVv9FA*( zH6CIeMi@rD&N-pRpjwP7Gn70Sl@y0jFwWbtGkF-~r3@-B%ngSOjTIKWS7NA)8rCm` zHE}4*1uY|Sr6V};M2wOB(TOKhb>d0gCnuh2h>H;MY$VVK82ihPJf%?%l_O6LyB>LJ zs2q6;!g05(wa1?Pupa3ls3m4Jd+e#gfvDyk%T#w>0U*Rg>Ca$}T+#7q(VmbStjS2m`-DIJbEAti#uU;u>FMmnGWetMTf ztu4|6RmZVM54B<^5G+!;Xu^gjjR1xH9pP#B2P%2p_BsbDM=B>Z#nUCbtLb{%nH(%0 zcA3b^UvVnv+5`%Ex8!pdwU zmO_(h8uuzgE^QhfasFZ}6IJ=85i5P6Po390q&gCZ6yD(xhVQosPOM8zKDjIA7-P*r z8@BJs=B;|cg2)g&yqnBmcbV2?)@GKh&U9DoKTX?>e*C96(S|Nv&#b7Wl;4HhA{x5n z()Fx6?FTMZyRS{$b5UTCl)^V%`OUL~hQZWYYrOABIqThzwwq3D&j15a3o0y8ec)SB z=D9iv8L|PV#e)4fGsJq<-~;~i%aNhb9{ymFVk51w@99)lvEO(=o;5(OE0VjH*J0PV zafSoF@sAg9eS}7FruvXmN2jz1T!^4@GzSaHzD=?6Rv|gVaI(jpr09h5Qk{(l*ou)? z$m44m{iTt2^+peyu5mRc#gCVgD?%N;szrs=vGi1%=@|41OmdLX&SQpSdanMN?kJTT zu_9dDm@O0z95);pfU5dsy9bcA;Hm|<2ZuI8N-&4V*!n)xRhVC3PNVaMaO~X}9>wKfVQbv;IYmqjED zAHC;9E6S-Ti1TWy@=|dgJ3J|!?M+d`jz4bFvkkH`%F|vx%zy4UV}=H=`j5hR%I*UYR8) zGrWro)PRdv!M!wC82>6v()Ez7>9(iAh! z@>do`gjf?A7WQ}CXlDS8;tU9pJIfx%&)*TI?i`8Vv~Eo4ZV265d_RO&r8egU`Nbgj zc-bGGlG4wu=77-H(#HO9??v1(Pp)(ha_6F~s9sHIxx))6un;SW%d%41&$D~L0c2;M zggQh;INg>bN-(FBi$q^iTJB2d-W3-gy7!w0yBfIFR0B)fZcQi>51pIQ+*cdrPC+il zpVbHNP3Bt36QC>^xzm9QR0wYt8<;MWTeG@AwUQfg8!{f*foO~MO5U-Ff!Si?-@z+~ zaeUAhcXQ!#=jtZfb+{#uNK3$dln}x7lK)Zx(a=>tc?Ql3$5nw{tXp1apa8B> z$y@a*UGKz|lpE?yzJ{ExG3)6ng`kt-s_F7=|FAHC}jhJYmB)`urjg`CxMA{!emq%Z@i$)uW((BnKe zozPSq7uM>WEI?@zvy=$Ot%g_e*$qU4{e^mQYUs=$3u}?P3@omQjupfi%7ZHxa-V<- z9nxrP%e71t6|Uu3&cFIz@v0QC!x~Zgj1(%NXaOb6VX=c!h`=U*4e-q&TZp}b!0IB{ zRQnYU#Q>mv`e?{oNV6Jdq2A%#UK|6S?GB*Bu6BytlWvHppJ&HW!JvENR#o-rfA||K zFsI(@HCfb#Q7 zYBaJ-OLvw~ZADJlPVifzLs6=*K0bV>6>}ZZ&grU0{ z4-6;VSezJ62q%obIn=&roL(G1Tq;a(fX1LH3Z%lGR(FWl;QQe({M<%3q~ooeGt=xMM8Nxnh_8mqkian);K#!B66j zZ8`4zB8JBV1~J$#vuFYH7g#>Nx6(hI_0B_jYIV8xBbk#Fi(Q$=)q73jfgl1lsSE2s zptXxkoxv35)Xy8VzM*MsVzRejtt}J|Hr>UADSt^5Rc59vwowKtOhCp{v91qvVGPKU z@o9}P6pjr3q7KuCeK4GsUg;BwEDvj?j8Hk)uHodu6wx~!ebaOy!9jH73G7AD(BxJf zXhwOn^g(7dMUq!9FIxJJ3NvoOAv$4{>fsstjwS;LagI7C% zvh`of$dnsotgU~LL^Bf`lDk-dFuHRL=)4L>ZR`_BaAss>$gs0x(fC@iXD)8dTvnWV z8ZFuhAvM6{GZivnqUx?8DGa1l>x0(Jnao-70uWqb)Na#CZZ`&P;{a8#RpdYU+8Y;C z!*cELpb?x?SZ?iIO#BJHWE2!Gd!WbLg|FEj@vD(0L2=D74F%g;%GJ+GHEQfa z107-vU5u6iiCs5yw;2tk3H!i6#I8;nSMNn$xgL1Kt-$=TxH-yzbOl6%b1(l2cedF} zvYmCvUygfKP;3{=6vKM3L!RSY+(s^LKbmbX6gJjZ@y65V!qC8`MZ^6=`0@NxgHOHs%HIfmRzmJcfX?RDDP=5*(Q^= zo_u$CVC4ZXbJ_2Un|HjW;m!#vy0r1bGk(ACTs=;{Z2Kz@edioKesukc7oXerQa!#B z-QM)?!~e=72^0TRKbDGK2{PntjF257SKr1Z*%w9}G?tMHfw|#v({M>+EDgJB*KH)3 z+x8Y}xw%}kBn5_DCOp-6WSG{K%os@1pFUQM&k5bO91>^QX6W6l
^(YLfzktP5f=D)uuY1Cx=+xEAUCiI9X@CX>O#1IZ5MXqzs_zsq! zqeKXUYV5OP9@cPglBOf}2@<*4Q6_eZYC+W{AR^;v(uCYpIs!^e!W57d2m)9^rm~#_ zO#YjmukYgWTjCvP-^#(3KR>^tSywH&fZ-M{^ zc*k^{Qrpw^9HiZ$)?rEZq|Ncx35uPOoSBSGFr9jh25r&Cfd-aHpY^=7)#GhNx##3E z(Bw!EZem;%IoYcS{Tj{})qpLWPhriUYK`SYst}{^ToVwAs%+KhG6Cj1$Hsii5$;b_ zgAuB$u^Vn34{=$av!Z1#qw)trNhpi;vWRt-l44$Sa+S!GlLV%78K7iJ8;k7|2PfM6!Kd7qb_CLa)3$}w+h%D zmV9v>k^tw+RZNBYXlScpAYj~8wMUo6fdcH497c!;W@9U8HYKOyIA=K#lPPx{_7nn) zb6Ti(Y;qzhoR$S~LCmYz3{V}nh>^m1l=@n^w(Ot=Rn}3>c4@5`?bZR1>RF0<)_W0} z`fNA@;bu4!>vThdJf|s6(U9di&A~Z=&JZ2g_*T8kx_5r^4$ofYU7dRuB<~0XuDsLr z1hk16FKh=y43EB3_&e{!#`YZ{#+7>0+`F3O-Q22ogz2kZCV6*6)w|HWV-|I7wseiQ zIn%x4D{tI8j+(od3|UyPJY(%!w2Az=k~(|#Fq$R*rY%OqJBrK~Z|hd8gXDM}EYy-| zk33jOsc{_IBB_w+j3*|Mnjqm%>#BGBsZt2Ax+-|EC{8u!PNvmUXco(Hh6TmfdpmY^ zH-N^ziutp~@u%~Y#udS;BRWk2#RSWRst2_4f$~8KNueDAFTxzm#?Y)y?>IB>ICDZL zi|`6(viFEDmD>1n#FaVMzB8QR?X<>Iq%jH3%eb88i(6Hg5wHe}j$-vt&UGRx6u{T6 zEBN!V;%lEp`wmW3)^0(gSR(H)=rF z0BG((+ab<`O7DD6Z*f9c??jd_+Z<27Ha08%+fqsEiC&H)=I8hg*$3J!Y43gBu@!7QAr^(29DS!O<+VMv31seM``v*r9_KUV= z5oW>ax=sFqE?8|`)_8u9nvt&I3u>~n_$JbcT4YbJPH-B|y&(|9)ZtEYskeEiZc371 z2CSQ$B-8>IHC9!cn2)k}$+lPsvfSZK8H7WdOVlvD9&G96E1 z1_8ySAU+#)gjt09Z5F1s)r-hDZ#47n*V=G4e^OTz_JiDNT%q;UPOYNh&O#%{CmJ-T z(NNL}v>nqX?%%m_V;MCTxW=lWbItmUVyd0@;5vv^%Q=!-@r00F+z%56@G+Fb{Vp!< z2O}XD4Wa--Gd>z>#Fb%l?y<+H?#=Rwe5T}vrhGv@kNvEj*LWta>{pm2h*fng23l)} zinCgO=dBC(Tf4aewzT{8-r3Tq@gS28?&mar01O5;9H8{LHzJp?V=fR$d zw%2zGE8;KY=NI?@!Crf9V>InB;?r*bPSF5-e!0#@ia$z**~IdqA@ryV{p6m&39 z<_-d#-1cs3+S!k8sK((zZBi$NwD}D>)jZtkYvW~ig@UR=1X=FB5D`GKR5Q}nY4}O( z%GFRXmhBB;O)Zpxj8e4`mkP%y=DWiD*oaG+bh0TJ5jE7YzG(syF*+NGVq2r5v{UnL zW~VH&RbvaXYYcm1FVr;^^Rm?vvWYcLkzHd^R3j6>5+DOFcrtGUHj0w{t~&Oj#W2U> znd6r!Uv~2mnhppkx0Fi9WEbi*Rls5#cjHv*ox0iCFutts}|DKPF7u`OS}$*y)7V$X>& zhQ#GV{z4)M^mW=fu!%;D?RKHom8Y1s-c?rBc6yGXMh$#hj>UkA(XYLf$XFxX?gfkU z!dx{?eJkmrb}d0BwU!lPx!1>TNNWRb-WWyg(&g_!QP)mPQK7qJ5>V=Vf03zI{>RSQ~3$>39HF`*4C3>LgDZ8Mg(a%%kTv=!s1LuS0REDG(9C{WZ{ z7f!cJr-$R&9>t17NGZ+|v5tp2;tFapoZK4Z1cpkKLD-;y=hP$|%<|D=WD^(}e9PKx z7rtfmWB7Kw9ozW7&)BN?zAVAOQnl>!gaj&IL_% zW5!);d#nAs^j6Jq()?D`?V>XoH8*<2dSlm7|82Y#x9d1udf3?>Tsxql&&G1yhn|^C zy795^Bi|7!X`hXSeJ~%UMPJDlnj-6bL(Roj)wJlVNp7@_TjFEOYFbmFDV)Y(*a_i2 zv0rM(;9{@`rllhZr{bD=-N;i>lPRYr@z?O>Jep9YCjXP+Qa(|WDywR{Rg(yG>X@*rXQgfdW~?`ESHvY||1_9~oOcMnc?oSlltR(Jj zKO6T}w=SHu*2cQYmZJ%7b;PiDh2(j~1i%dx?nfET3rguiU6b*i;NVtZl|WeE!JHC+-ce$AVrh zOyPmJNrEwjQqDr+3&Qu9TV9+3Y{fmJ^^2k#&I{|Cio{)rRXd3qQNy_*#@s+NA`cp3xBtiJYuW)67foRKV@3pgj{2 zfSUn$I2%msjH-xYS)KM34ksvWxGt~NAYq-FxUs_RJ0gEGAePlZUM~QpR+pP1G zPxFj^R5XdI+1{M!?BwC4W>CFXNngDcq->cTib~x0m){6(7$#%oe z$-0(dv%k~x~h*fF`R6{6mL?!kj0v@)3DZ!6kVOC_tQX0Z-!m?R_F&?Ct#Sxvq_3;YxEnZWbV6ToO4A9< zA$5p@SwJ92r)9{v_XWj0g`pbjv~wFLYyklP|Lt@}@C2__X1bF$slUBf71RAT#$CCL zy4t6b-;Ga&@OUdr(@~(2r+I=^Lv+9CBut*inPkH-5!Pf>+rYrkogJRiv8g`eI|>qJBCYSuIg-4(N@##)maEn_kg z7;An=Km8SE&1n7Dq!B9hy&_oA^L`LBFZD2!hd=mW2t9tQs z+G^7pM$O8O5PNO0i54sH7>)6e$y`C6t)nbwiRvho14nGtiS_Hl@$xR?eLucFB~ym2 z8RCe=!a0`cdX0Lc{M@6=xnTj5$)>c?he8QM5fRA*%ruD6qz0#1o~WWoI^2WY#6(Bq z)`tyvNQB`jh+INEMDu4H8%hjB<|pwUR}8Ap+OS@ew@bf9NN4W!Y0_m*d3`mn35Ra0Jdd(#D zOb+#Et0;E@73-`NNj>CH0gZ<;41i`>$6MVkFNmfS)IK`V5xGKOjp+4;!eK&&BAw-k z5|hY&!6T%zbdATA*7fy{LY6!lmMV=In8Uo#CmV9YJb|hh;G|SFeV{1E1X&YQVMh8- z|Bp{FBc)Tf3uau*WN2u7LT5Cg@zA6R`k8E1g+nW%r`T3>RESLt;r6X$jTH6; z^VlI`I$FWzmm(D_)N<+;6k}xc_11s=A}C{4GyF092Y#wXHN3y1%8}|GK&s zXQH$fp*k_y9Om9orck)=aEaBl$Yo8TeTOl+z@}ZHO4yvX+smHC#K}ZpbJK*eWgNXnTT?%!7_H5_2E<1vxQ! zSiy?(tfhf~<-3Xvm?cFNaxLctL0mlTs%Kx0JJ%}BYq%8BDWzID!8jN5dXsX!os?y- z!)8^=;cuOkaqTDbLhg-C%70(4$EcdK*a0K48>7}u7$)|6S^MC>!AOxsE(l=tDm{t+ z>Ayrz#_c*i$<$2Z(d9;fx;TtIB*w8Tr8#k@cU0v*!B1@s(@^nn&nGXV$fQd|^ zsksAyFKpq~3uYY~6C4^+ybFn=p264twKym+;I+ne#~VZUy(I1&ho?(9#I{@&XrU6( zYjtirkpAWyHkdG7QMMN7C~iEo2jwY6SgZ0Fo=jL`Zfppag_^HK#CtF)pD(A3AbIsK z!34RkaT98?x!P<_Tidm{TAosAodr>|MiJ%K1;N1H;_12(q2^Vu-ul|F=9<^6_2#j! z_zFla;iN}(!nG2ut*S`&f`mGy3V(d`psh#mX3qPjT{8 zLrb4m;~&K6g|RFd?}_c`@vKc ze>*9L0XXgpGUFFJjvL|YA`W3-qGHsd!2mAfj9$s$;Doo63xeLqtzC9wpUG-R^ZIf+ zWY}vwPv6ESe{nF=`1BF_(tn(?(j%ARXqBcv3yYqe5F}<}Cj?>%Ok!o|4|UB`xw z#WP|_K%PB~08QC5R^U-ki0>w{+Ca-#RDk+ra5@XNM`t4^R|J5)qQFLR?orI>l&5@> z93|uSN})DY%$~@ajM$u_y>UA-9CRj>(jLpTlFY515%)3U>~*vVvljg3?i7wFz--hwbI zt1@c1FrBY7CDw}(bh#ikaDTcZI!2jj4*xlXh;F?gCEMA^qooQ$t{t{7(=c5RyM1Oqp?xB=cfXZXP z`Q`g&I?ep2&wbFnIN05U!eC+ZmNQ>2{6QBXw!L}rc{AESzwPc)aW?uZHQ>7jM!U|nRMp&V*V|p! z>!`_kJ&69}L%(zg2%@`Q{$}#{r_Vhy#QAD}ENpWJ*M4h)h3zX>eRT7`jC*kx*ebb# zEvQC|t!ZJ4%j^PMC08}M<5Fk|pwjb#!W#>Ph%>zkLpyeX!jX(zwUycxL(?r3ahYA9 zsN|~V+5|&?yzlw2V^!Yjv& z6b~9MY7%5%lU5TePhj{Vd;urdPIg7(kH_yg7|t1M>CdUM^zE%|ENDV6RIA1;5?|7) z87>}3M*qs-pbt#n^tKURA2=ME;o;H##&q=-*)IncW=oX4P*oX)tE#rt_&p0*C|&lR zBS&~WdrVuZGMmQ3gNDJ8nn1ZG=Px{=CmtiuLZShQ6sluv2Pcz4rZOdLxyP(8k6!uc zmN%wq(054c*lVD=l{;g9Rz{3^ET&#nX&TOiu~m)?Lc9iHXMxNA6Zfsuq>pKWTF7=) zo$hGISfkH6P9@j_!9G*M7HutQPJnvR)hxJ!DCml&Ek{M8nB_t(j*pghWBqAgBf9D_ z=|%1ou!}8iWEA-VxIh|Sdj;cILgD=n12#g(vq^%V!{-~`Zc@CvPL8rmL1+Y*>*L+Q zjfN|^tDq(LR?Ra3S8f6x-?AnjFGe&J#bU(&PM3Fx#eDLG__UNX$uKW}j&ch@%&Y`1 zvinR{U%tQv1FFe)7Pu}LB-4&asObVEsC6O=Ip$0apTmc2F35VZ01){QPVAx;oJnzg za7=xTHkI5hXpHVS;2x3^W3;`|x}3k$xST?aLew_V-$EoKt#@8+-5~+)dU4U$)11Rfc2@$*L43CSp7!d^mw#IKvp?&QuEwNyJa_XTIsJIz z^7-g0%#4w_V=#W$J{V4Js$e*NSQLa)lT1!D$M5b+BGK> z_6x_^Yi1liioS4EFiSfNgv8cEEsGtoEJ%`lV83Lnm)KrEEDC8Bcu3+Tnala4 zA!1-w9y?MzaIAVbaEwklFe!M?NNAWZ$Cj;DB{G)~t4`Z~!Y&7Dij6hV-?uBPiVhUx z#nJ}zAJG_;4| z1o*J{%Ki@8!x?Z9Y8C||v541Qe1y|ik(xe$WQ*EpN<{*&=deoplMv79dZ?{v>Z*LP z0dBRoVPS#cNr^$@;6DsZ+$c5q&_*I0Z6g3-V>uubwk0NDyX+%+7|Y=MQ!f=3+}DjN znBf4ri zgYHBpf?tU@i)&6`*wWy@4rS&z-!m*oXaH+kNEszn%Fa!p-%E9N=%qAu5!EhZZ=H60}&nf+Bmm#i9yS@L8wn4WAT0v=YlOrf3)KHHxTk1;GYsdfwAX z?`Ui2V^yK7#6I@>+oP7iH;NVB5)lCiuum7$x1B{Zj?k6*I-jY{ooJe71TampYu0F2 zEE&E#TaCo&DhCv_Ehn>JOaVqfz ztQc7pqe;eq1O)Jr#?WW)fv_X4+QQ=2*2%8s9|TlTcSXX{3|75q95Sd=W8TE7_NC|S z_aMNV1nqNN#~E+%X`Ejh8*?SlQn3m#2UCa`sPS~?6CYi4fTq-q6amLJ;>x;VgE)>| zOv0$dNg4v05FOhXP}TIENgX3j=Qm{=*&I=H%&H)g&}#c zR>~L{RMkcXvV67^ZeIZvC+$efB7!yHlVMe0w=-V_FJoX=O#BvmQ%s&MT?w@2i@j_U z)UXJ1bAc4O)G&-oY-OJFhyk%HBD!6~Bx?r3S?no14VqPAIKC5UtE`kj7TEb8x75KJ ze?#k>FwZ=})XmL42B$aFr~}Ce5{@rLH^T!P#Ser&aAO0H*dsLUW)EJDzT=g`p6r*~ z`1w<;D;q~WlThMHVb5Ww_QYpII&FG;mfd&G=(Oq)XYDPQ7k#dr3e9Eq7Aguwv>*DH zoz|4k=imE5?bJxtCyCx)SMf(b~Y{mKJl;{+*@Ra%HATw*ls_yRn&D&S4 zT-nn%5T4)Dr~k{_2L_g{xFGEA;m?wuRp)hggsa=TS9SD<%lgB`tNQvnRt$7s6fRlT z-_E-w2i2b06Lzf7bGU5az_5MEl5kG<;yEk(maQ1*U);W8j#`=%w=~cb4lL~myO*u# z3K#b*U*5ig22A`j-PD@t)2Azyc3C-ny=w?jBj$v&KdrWGtme0c}`D9AJ69}PgH69Cs$`H@|RZ+P@<9cDA7Q6 zN`FkQ(U#yZuXa*m0!`KB_ZqKk`zJTSmf$b{X7D^?#takPTbCb~B<%Z~iGE#|_a@Ow zU4HUZ<=H>EN%l2=d38&D-kV~gFV^S(_t}$`Z~x?`*dqMp-`qF9<*kPtdf4Gd92vD9 z*EVnd+gB}K+|l1}7It@cT+rSfo_EneN7&!dyQ*Ww;ttc+v%G!Tim;=vucyzP(b2!E zdmvoVGZ6N5tnBOPhpZx^Ifb0|aA4pfb6Q8=@@4(~%X(IXOFC98>sVq=UD?ssKA;TM zBe8thzySHD^o0GZ7B3CYUj`SzM@yFVbu1p}>AR@%W@TTGg>1e`bgWs{KhST^7F&e_ zJw0J}d*1~emIIfx577BVD+Nc`zp{NX%+hiGKxkoDy^K+ux{B2K;qs2oG zd8_&_G7DD>FuGMMfhp|2sDGeidAPW}yL+@0IWT*B-!eFO)r$7j?aR9Dpck%y$Cpv5 zqod0l*VohEKW9mYy0ffG{q`kudR9=$j?gu2+LBRPY|t_|JFaKN3WhEe38w>)06cZ{ zRiSQR*>b?^Sv4@W@cFCy!Q}Bh{R0xTRV(^B+7~aiz(q@z&=&HyBBYFI?d$34SP`yV z29g#Yd}>V3gak3z5CKV4wF(K`80Y+j343=>&q^cWuV`N$(_Dqlg!m|di^86j3`yPE zVa5n%Ocs(Q9sP^@maT-LfVD!i*7ha4zSdY5FJ0EXBuw~Cg%U)l`%!iq?OWQ&qN%%Q zaaVN@73Nw3{q-`uuxAyG_bf&anzs+MBVA5_7Wb@1G9*5y^}#nitNO#93s-bV62^!P z`fzavTGPy5wZd_U>MvWqvb#gLbfUBzsCID7I$D^Jz^#Vdj64Oi%XLm^1vNgI@;EoBM)`Q;(X@1{bAg`YXKUK{55OsW$Vn z_rJ|$!6Ng5mq}ff`d_Kp=3MVc?<3~k^e4RI{Q2JR;`v=u{}TTHIABWM&zREXo@r@q zFhf^gW6bw|o8Egbe%+rv&pPusN*Xit>?||%(8o zZ1IL(yudRLZSc%lcY5XseLL9?o9ABe;78B-^+CsYwuSBGcg{VXYs|jUykXu?@cKMn z9`F5f=Iz%$+>w&T@X113vj4wNTL=k9|tNZT9_>Q-Sn>Ww9fHx16=RVuE zY39Ovn>&tay!00z-;P6m-)uJg@S?#-zggb<#REInOeAgU@BMktH_N3j{4u-eSHEjE+fSeP+{AB| zFaFTPy>EPi^qN^myz|bd%1?a$f&9YTlpfk});~Q}{`b0r-@4#mNSkS^xA{+%-_%;1 zc6~4D4I3{1%1z%We`~K#Uwi5qq)!XZKJL_Sl<%K;d*a^!D*_Vx0!8{YZI zUH?vc<&|xZUH$d)ni=2vRr@DNm+qdrSIgJS?>l?`gtLc856%C@4_^FQ`RiRjdhFwi zNpGKfMAKDYD}Quw^AGk}K>CVrf9Qc@zgE6%UQO%H14wV!Z~yPV_(b`8cYp3X#Rk$Z z9Y1^d$DSyE^VvfdT>0zYkpAMv3!*2=Ewi3|{J5t{U-OHrw*72d`Jqi~wjO&o>BjF& z`}D?bO7CB6tM?x(zx>kV=nJ9hU%3CsqOX>3`^~Z6 zzBEI6!^cwI)`mYv0OnS$jOE0|X;qo5uUjM*5SCO83 z{IcbB50`&%*ewem`zO*{=iM0gK2&ab^5knSny>ehK7Zv?50+;>vh%TjJec&#^Nzmr z=m*OS>xWleIF0n8!#}Zc)0fK|jy(48hdk1yJI;J_{>$a)rH}o`DL?rY^=GcWxc`Cj z6Q7yx*M39kd#`-YGxwJd`12h%{ozZb&DTypaQ^+}e{HIJ_a2{7`m(z|u;sq;+%HU8 z)b~-P7j|9SbYJ7tju`0IPhcmMXv%Rc#b zr4QWap+)zU-oJ=93Qn@DkO3-|}()>kH-YzH7e? zUp$@k_Tgv$@%Yb|Px{(hZWz~0y3~2{x88bt`P+YJ?EBz>q!&H#(naCt%5VO{PiM`Y zK{`C|n)%~yE8lv^`ftCSA#J|a+5N{`%eQx(((v=&?qEC@p77ys-%@_;`UC!{hTG6Xb$o?AFvetFg@2Veglz5mIjTl+p$ zo_^*3t?Nvnsrugk|0v2-hLYxJAY^W!PBx7iM1xET6)F)56>&3W9vh^h(wwN2=x`7! zWK2@%ri^i~F%g~rK9|p0-}PU=tfhP3z3y|LJ)M2_@SJT$*z==|-nFa8_zJabsPi_* zjM3-H53IdNMJ=m*zhw*7@F48Z(irM~N_SC_7Ndt`Jk`Uf`x>XG*)HXA%N4WyDg6^2 z@{4COx-);Gc(b(DV}_c%J)VUs`i2BX)m(5nwZ zD)Hyi#1CT4$}hN87K`4eaEM<^7#=)5FEIhNPK%!Sww;5uMA@gb8|dMal2fe5Sm*Lp zScKe038L3-&OV7X>yxhEzWeBTys%&NYDSxIkIJW@y;rP-*nG_AFE?LyOGB4mc{KAC zcj5Y(@_k_UQ#3K!OQbgjYtRa9P)SE+`~KKH+J|+nNs!s37wB5!{s+tC8Gdwy`)Ay* zFLTgw>g~k!J$J|YhnZ-?>AN=_a~M74)tghVkfY!#N4Zd}Wm+|+tpP^TLVSs zU%=X^@J{W-*Jzmzx3I|;YjI8D_1D)Z^!z(}{Z&}A&N!^hDnMJ+=E-go!n(V1sdj83 z^5*siw0-HodgkKyM~l$SwbttMQn8M*>-??z2HiESMlHS!pFNN(^%jMm5aQ~ZV9olq zN1^>KlHc|)N^u$1y1yr^eDw}h_Qp<2;=>x2&Fu;;MstWSixX?xaev3RZ>L2GihA-! zV98^wbIDSBg;JzicBxk-0BdXgniaoFk=wRpPS!q#Z(5$6_a15Kw_Yn+jy1ddC0|$> zYT0G4YB&Y!DCt}w<8pMZmX6rf(uVu@1(L_6Rv<4ZO)R6Zu85ub(xn1TeVy|;Hy&%} z!0QelD$pP4MGxdpGJKn6(8@|Ac;(q6FvMDak^Pj*mB?7fwrz_d)~r%C{ksxbPw2nE zHwo**2Wzd&s*u7h_Q54ht@wU8T}Umn3Z*=+_js0rwe@;&*O}EQf5|2L2MJiu>~xg# zs75A}q$A}H_SnTUxI=JtE!XBEKSJl1z)zanf_5u6&E{u$ldMaD zQ$f5H?K&;wVn=%tlI`{*v}!9_9F#5B1YyKciF03R!&X$q*W(mD!HJBzYA*)Pt?1;{ zJ?~vc?8y~xy@%<@R^-P&a6K>Q9MO_5^OsI-MYe}Z6{NkLNqC34=<-%HH`G(mmBk|6 zXUnzI+*b5>=$hlw+;F1p)>VEGZ$p~fn|D_E1QU_VVx>W?4V~*#d(r+kguHq}a}pS} zA##PS14RWBMZxQ2z_|^%c}n!zQlTXO>4BegWE(OmS$oq7g2}J^}lr-e3bM=A&Cx^C}CvQm<0q>s0wEG@Z<4}6`;DIpvC>Bx4(y>}>j z4l9V%QMueer?#V2vF0Ic-5}EL&la42ru`=536>#Z=hYq==x#^C7U$(3pb&CW+C~Ww z??8J$o5t(YCyC)-uO@?92b$@q6!I`9j5s~-k~kQ3Ahpw{8jAm(C-hYY=7Dnu`ttD8 zT6euja+jvrT!`vGlJ5Eb6Q~Gsn~tF(q;()GL=*g@N65+K|S!ld}YUt0Ainnx@;IiK$|S)X;GjyC*> z5)}gvi_@pctG3q{gY!?MV;ESmkq#krX9Nw=kw4MU>->uzf4vC968gCAO z2g!~5^s4CcpGdZ24JU&>Mt&7K_?zbbMEgWkE=|-sNA7li{*4yvM6-@v~DCBB;s z_t2`HsH;dVocs3>x%dZFPaAe3x6Pg8VdPH^X71^tk9VR@_U`Um-u^^QWIV3_PSg`K z6h6uC1c9HWk%hEQ#6NZBp@`ALGzcxAl`*s%royrpLHYV4T?~sfh*o8#@nij5_YDzW-)vJJW z7uq0}XYi5bLq71WmxZVAZkN1&Fw9CS!6P~#$Fi4(n#&V>+h%Y6rELoQnXruKs#3LzY}-yflmbCKJr%X9lD93b@yhQ85} zT(qs#qrdX32jTsljq9I_)NgrRnZv*QlSgISIOkjl_1Ek{n#)DzLC$=u z1e{1GYukQWtQ&n6p1UQ*JA^bn6WB+qb|d!Fk=I9jE|JnxMn-AFZe$TxvivV~iSRXe zKM|a}QOVvPxqjeFw3YPY_ScPOyRFLkN;{IapGEl~tsDK6YkBO0qDiglWIm|qMuUm^ zr-#q7h|$r{!!)-W79`x8q(%A#95Lb+4asStYIE~+%hDO5)xjphDbYu@Y;ku??4WbD%Vyz^k^`P^7 z6IrKy;)#sw3cu;{9%LVu_)ufWmV^%>{WP}+{j|7yjq-^lk^@6ULA)0&v>1(cU?mb0 z*9YMKzZYpzi9hq{Si=7oNz;bC$W=wfyOqzKsFPI~ppW+=8&MzkS0g?Iu{w4-MD-#i zy$M9|1Xps}LF4I=){7=A=+*RP#gJ=u{ryRo_oCiLviG~ss?^Y>qFnP+?^eK0tl0LPY3AoKBO*5iLah; zhM1Y2hOfUql(y@MoukiXqCZtb3dH--;(%FJtA5)P3Za{E|KE?+@2q!i;qxO7reA2K z4f~OK@Y9z^=wO2F#*f>7KiboqpYSC20@<2(oJ&XcBUi=My+XPP1pnQfW;(SWZ9F@L z%An)OMtN~*sOU#)kJh^!%8e(Rbh^c$yC2Qn9Uv0ybBU zUCF$wTj^wonO#q`zc}FO6Bmct`~aKi2kTLAKENcOX+W)Xmre@3Xw4#OP{?d zqf~~Zzb!dXjQ;wLeSUD_*yoWKqid-j7TvthH%GcR2;tAKY%Q4YZc~gB?j9nM)EjE+ zobEl9{soB8T6XtGa6VsMDvJ#C%l`(riMY~9rX!xhw%?0{LbreLkss&RE* z1y$?vw0H>{&rhv~Z=MY(qkP{_E9XyV=C5lHzO62$j7q$grJct*Y5MkwawSx=LEOQG z`>|#ls?PO#M?H}WT)THU*1$p&@O)k?Rpr6_1;cl_+zs&sX#pb5%FQ~}X6&^BQu-4^!dI~+G>R4tUTQacD zT{ruzRvHzq>-ksb0`vLjf-%P*P=0F)i{g&~d9PSnmdFL|oJEJGN{{|xeo?q3r8<_c@*tgQT zH;|9Gf8yj)X8sl$He&DywV7XvUu}Z5uE~6j2hUK;+U)L+&3Hb>3av<*nTeih(dS-x zV6Dslx!pAft#3DQeJ+Z%wU1F%eI7dKHnsj~GM;ZGHBNl!UVwI%d~AzA%>1m$WBuee zXuIeHL!|~hU(&rF+8FT;6-!yev9nmStB$^$Qi>uqRh(AJFuE*N*uM;E8!5;+7c%oB z`*h*c6{ta7p5$}HI+yRTz@thO+JngI8CbLbevtTr=MR7Fw^Zii@gb{l$EHai(1due z{vXa*cdr)8QLaI~q_6fL8LTUeWTJL{L_KDML44JCKGNOszRIN*IsVH0*&K*<)Y*Wm z5uZ?8rs<1I1lHEyjQQ@>p@rf_v_L@jWh{O)qFgPkgQ9bw@)8@u_A~VBL!J{1&CVjk=OG7PgX* z)Qa4d7JIb_o+9qFn`r>M6=f{^CHF({09o}ky^CJZhE(6(p1)~=KlyrOSQ)I_(1I(y zH~R-22_uKFK{~Mwjb7Lyw3|PIw3D*e26h|T==mn6k3WRmC`~od3)&GOGgWu_um@S0 zxUZD9YDbnwk_1?^J88c;YYimf@xFIwLBVfl;TEB&<{P1qE+xem{-Qb$#4=>;9g z`|*1NW6`7J1)9H+w(39*Pus)ppA96G!uJ=`i5;kM+VO>2+ zx4G+zoFOfRw%5^LJ5lZPD?^$?=ZW%p_MnqmhYSpM9lCeZGnx)x1W+{%;$3>qc{J;!GavbKEM@HWd#$T?$nxq zH3tn3ikiBKc$1>JUGk8G$B&mc3i^77!KOKR4Hwb6-Oly-0QTm2kUGB{AIhW^S$P7%>1vxkBR`$Y=; zAk&S`ZPKvq^GP5MfBgQPw(3Tn7alhV4hIq@cLRhWsT)QAsb)1cnUJN(YBsRD(e&;@ z0Zrd%av&@9H@%<-B<#M=g}67(g46Zi5%Qa`F94WsrA2a|p4S77^oq_A7MYl*}uQp{&UDZO9-)$j4} z|KxX>IQ}eXl(rf`lb2Sgw+aQ3S%dR>>BIpv!PE6{;$RSQZu!Vh`s)DFX;)K;Vnvg9 z+XeW?e<$HrzoDD3VTTipC`du2i99qcAAkd2a)F4y0D4jD;o#1{@T&14WY`qKYNy3e zWv~vmOk#sjhYHM%sf3^N{({1jxzMI_7Y0`N!iHBWaJAhZ(&d~%&)W(5@4r&wkg6GI4=ziz`GGsZd?7srv@6Ut%HqjtB zrv(DyZSk$x3c_^{<0V2Gj;3rWEwQR5#(#M!DYincy(3-Gr&=TUYnb0FV2WFLhg+z54?B*YZcoQ3V^k*}8`+S0hwi%$&77Q(v zHE;{w!?Be@V2M7!jK*3pUDF7S2{BN$a49SeY=b6K11Kui0KxAwfPJLF z@|_3p%S{K#O$kt7Rse4cH-N#@XdFq?2Orj_fWnq$7_GsvIyoaSKduy<%Q!GiX8<~T zSn#a%HN5$~6k-M9AkReyRD_=4ryBa;yyR7QDB}q#&l6#DOg?yOsDh}mBe>p;0*BTG zpk8tjPS4m1dZ(M9|7$R`#a)7?7JrCWzXa#I9KgzICA=D)3i?;l!9MvIxVWx^a7ztH zlzItdvk-)o&o|u#960n;%5M$<_&w{c$l2p1lK3`mT^Tg9{OH zcOX6b7gX-v3FX4QAahw02DW*_(}RbhLB|SoEhj=iun!pTQh-&5a>4PFIB4i=fW>w< z*x~X4Htul(5urR#95@2g?P@@N@-?vJH-hvvU!cRi5Q2uJ@lMWJm?xhF7mp}FQRyQ{ znZ5_2nvTNxx?ou5Y6SerIp8rl4*Jxb0Y>DZ!{r{>>P(E`Na`#?>iO3Ixx_^O^ZWuVK$AfnIWDu2+f={n4U?8Rdic+@0 zj^f*Jch!4nxxW$~#>7Fxy2CK*U?aGPap7?2E*SZ;3Lf8h2w$bt0lxv!KcC@{fgN-S zWPpOL8kp>*U^BfMjt*slTTUM=jr|G_S!!Sx_6zt+q+odAB&ho_57s_Q29r6Fu=2eS z>{!2hUJ`2$pt*qC30cxKk5we*z?I zHHCuD8Sua^3*5`gp>o1Jc+#T`VextJI>iG5^*_U)WfByz`r%QxDl~Ln0kn^Vibh8~ z66?!ebmDnvRu!38`#Q>QGz zzg8dAzRrL*%Ijf?%?fzuTn1_-FM&EX3dwL21djax^M)jlJ-!(ZNLE4SK7Vkw*#ZuG z*$}^r4~&dg!Tg#G(CjIIX--yPsrCZ`RPMvPr?26L#!3*(NQRClxQ`l?g~%g6K%Vvh z(TObFuPcM$`y`OL9S_fLR)eagFr*Ky1BuTia5kp`629cYL+NZNzIhG=kM08%V`-2F zWAK^Y4c{gQ!gP^Ca8WNDf^r(+^Qa;?EO`N*!OKCQ?=NIh*WvI{L)fZ#4-5;;LHRcc zwdR+h|IG!MVh|28tM5Rvi4{yoPk^O$0ZL`~z@;G&-Zj1e%6b6D(?|f{WCsXKdjwB& zD`2OwKFt3!6)w2GhFg=?K(6izm{jix?2V9wnvQ`tYY33#{cC&)2>;Z6!DS}5TmN0cg7tGaJ2Q~#kpfK7Ftsnbf zp;s{+k6r_VVx!@=oj6Qqq6L9AdNcv+qVhm@!A-su|XxOzg7#8DV5zYhv0zQXf& zS&#ucq3P)qIGME=n$KFp$xk6LMQRzGn<)z3c5%R`Far|LxWnjZ4(#2?g*tri?yQ>z zp;?(waA^e8@5w`t(`$$;TnV4S$* zC|(5#t5O&h*$UtK|3JhVM`#LM2JIjGVI=)Na5@6YTJO8>;{-q_ZH5L2*aPP zM?rP&C)l0t4?E(+V9&x*P&BTG+@g;lGV3DDc76#*E*t_mb8A4mIN&282K~<^V5DRK zmXpf(mji8e78tfwyAV!l5@1$RXjcEdWGa+H8UlDxL5r+mBeNdj;0I4%?fb6nO zVAfX)b!RTa^*y;@7&r`jCyhY!>BkVfa3yG^ECl=5dN6K#0KRfsP~4gTJEtT=yyg?Q zUpp0!20`h0Eo#pqp3^^_z|1+sV~n|8pJuz4jIM zf3N~i`((&^bOwxn-2|oc_!;3WV=!|P1X;yE(BA9^!QWe;`T7Ug@<$iwz3nhptQZQ- zLLhEf399o7L9DPGzL-CT&4qywu>JtZ2Cji+r{h4}CI}R_djf0OY*VM^A}GjSe*}Y{T(o9kJ~^D1-7@8U~TLZ$o3L}m>!P{#Qh-GTP-GK<0zPA-*dj#P*9@8B6Hh|l+cEa$cK8|aeR&@oH1@$Jc?%o^)CE=G0VDm!z-MLvY!?=e zuKf-oU3|LuAO*a(0HD0#qz-;zUEcJYz^~RjOHZv~wBMX=ZTzY$v*e5xqZj&qUx{B~ zUf+=whOcY{>>oA!7ln-yex0ilIl&#*L#WACb)k>a8REY`qnKUNedhdR=W!iPjIGt# z>oVVm_mgq(5)+H$POV;ZoxCzAnw`yyDf)_tJxq{MA&OR#E;ly5jif7*?Ik46@zM?O zb{$uHEQV=ufiIm+m7(YTqP2n!k5H-6rmBZe{gD6a9SQ7OWBj+>IL#oEk5^ZmsPnT8 z*CY@tH2>UR`-_V#>pxwcX6-`Susn3GbaGLpU6A;h{ZV9qk5ik}cP^Ut%YMbKsxabY zfK+u_9TyEp3@u`ng_4cG8WbGxYQD|e7MmS|*2LQcx0xH?a8Z1CyFi4Y4OI%fKui$=JkF|(gX5QCdtm0})Ye^*tV*XHODH!G_(I&X22h*MPX z@`*>uIn{qt?Gm_XYPPE4uDut?ofeW6e6e^pqGLxGmt{njsvpbE4&kC1{WY13-bIsa z<@=AX_;OLI@xJ!&)huFX#O=42&v21`?ClPzIV{q1=UL*VD;KTRXf*C#5J`4~hiMHR z%ExL>WiNPgJI@6Wd2B5T#vI)j~8hzFU6)r0nM(KW5W z65rNHa$eoYLL&n%3V(fPgWmBF;$zr>^J_M7(OLc@E`>5LZU`X_s5?hhi+ou`In>Ri;@y5O?XW){)l)nvO-iHr6Nx**S&7s+!62flq> zjCW5S3ORlo^d-JEE*Q8rAD2IMe0GBDS~9BcbA``LE=m^`b@g2pN{CGSaVJ0$&$dg- zf@7vT5qnj2?x%`!(Tj&^25ts^gj9yQ@ZU*XwEg6xCcbrng!-rLBhGwWwDotjrFKIk zLC-k!RB(iY_$?yVux7G&DKqX#Xc$9D5 zb#OhQ9BgAPSjIuzLzC7B*ENmtAvzn#n<1 zZpGG@HU^RF?8D4iefkx9Qu#C_-V6e#7L49Mn-X%P8Q@aw21s zS%}(w8JYQp0AouZBmpPAn;PhzEqRQzLHpMGoS-(4USOBT`5A{My573LoceR@h7O! z)5Z??`bxhRaq0b6U-C>}HRXV>zaY($7?0UuL`t=Jd}143y{oI-8tEBD+Pw%@n9Sjz ztjG0x>s}j^f20gw-t6Nb-CuXsPEC#?SDQ75yAI*4sXG02jS)uoAAt(F#?0+oI;<{^rr;nBhO!(WKD)T8n(#A3YOIReS7og1EXX zpdn!v?hi*3_i22OAkI|KRuA#&;3G4k%1E|9v8~cXrAMBN>}T)LN_~Hjc-}fG&QX<% z4$q1?w#>nvI1zL}bg`~Q=R znl3*MCwuH8l=boMxS-4fJ@Rz~A#ZNOnUlpu8b9y9j#Kg{E@e5aQYz#kPC%vl{X;mq zVxyCVJHFp`eP8na#%4HrxgDKJR=}j0YTu}zV6ml_dX3~lm4Mlm z!9PiOH%~9~7l=r|&FuAE_K{-kUA1&^`YS zh7K{*bfdI~dky7i^r9yDz@jm#%h32iOn)l}rOd9OYV6al|L||YyQ26@;4+I*l&{kQ9@ewwzHXUoPrhI&H`y%!j$#{Yp@E#lkN zx2}FH&AAMX|Bb2s5##N5swwNZoq);zxqJ>NLZJh+NNY2`1b7fbyQjUW04)#dqR=&ABQdJ0vP z`{&(D7n{$>9xDx=Uxr>jl6U!SCB?s|^)Q*bV2lFKFGKG=e7MiPlIp(at68*Q!I)pX zK8*7_jH&+Pp-_QJ%FbM1wBVlHm~AdYGZ`9nqG|E13To=aes7M0=orOo%{addtw@hs zqFX`vDED7~xw3n#j(BwFUzEl3`v=?V?suG-SxyBJ@edVEri`V^n&+3H*7YSR-DT9` z)WEA5a!O-Vm*8tpMu#Zz_WM~0z849zukklpv5nsd1LRdkl@m@V-9 zj$oQ}<;`GZDUSM1JZyMc{(orZzbIad$N6Pwl=8{I{1PfMBUC+Y$E-2iT!s!YG?%sG zU0*R}7xf+;+>tfbu96rUKZm|tt2Uxr$%)+lD=Q5SDX%uHsf z{0|-a7uDtYJ;(U1@ba$BrTQ(}&R;wtJeFo2&HNXY;rV4K`-^&XCq?yY-rBdvZM;u`)Fgoi~=BT!z*$ zl)ZJeV@wwH_JKv)3hnW}j7Nw5MUxoYct32Lr2cW^>zCBwy{ZNZUgJG1k7oXhvUq+O zYTX=C)s5rkPiVedb!oiEv1aHHLuDqR$#b4lCi{zQEGCTiRy-Q-{|~Cm*k&@6J?CPr z-ZSd!w4u_^`tD{Y@pLboE__j^qrFJ^|u2QXA3S4}vTijG+6 zcil|+e`w~vDBgj@<;Vcg&VYhyF!#8Qb_k>^E2Am+8s76z4|o z@=YVlvd69jhGzbYCh`38=-$j)}f8_=;CJc=CM+_bM7iBT@N)T>Vr=}+OCQ?6y zyuIXD3S(}0FzX-Cn&%ZmX;#hTIhmIz?K{JtUOE4NLm9?0i-F<}ifkY1hwkSosA<;N*Ye=!e?VX?BZBcsxy+js{AOY<9tP=U z;de8F-K4}>s7>iwyu+LEevQSzIt-;*v8H=vqEOXf(Yc~UKXY^R6abmOGZmav)xY27_Unf z1M3*m+{Eb*;_jida^@8mPLF3$m!U&E+VK8F$s@dH`)PCU;o0NaXJ~vVV>>BVz2hD88n5`~DGa1VMq8;5vp;6%*h98&z*PHVE@~FITgmfP2 zovd7TiYq&oDjaQr{W7$Bk+;%=JhVJsYeU4{@zO|QXnX{wtUytl%6xPq{anehYZJ$8 zSq#l&Xp~gii0x|>?7D5yJ=LPI($HmS9YfPJ{nkbopi?hK_nh_{?`>sxetGo9k7oHo z^yci5<~Ggo{IYROkY0QwwiOS{*({fEm&_ll0~v-6V>+YZN6J7Ml8AU^D_oa+PRq_w9pIWydcfYlgz{ULCWy_GW6wC$BomgP)F9Ltj3`6K?e?lmu0>9H%n8tu!T^kUDNnPb$N=a->vHH*?`eL&aPQJpJ)2#!%*p5F_Y zzIDkDclm(aKH3YF$*X4b`bZg`UxunlUuVDjfRaB6&k2@M8Kc1S%g`jP$&VM-AhS1z z&N=6(jD0f>HN*L3XvN#zgPt{rt82;WN*NzIV-4_y*B(Gq7%kG2h2mh5Wy#epV2<#cF@-K z#00@(Hcs|#_+fm$iR;zXK@=0_7z^7&$_GyK2^?gomAbZyy2=V=51SK5lusOTkXd^8 zGByX6A6Q|dap=GbEe-7zS~hm- zwzisTS~jb+)ehPnIhz#)z0t2ERUV6WIo=6H;gR(7^FC*AO~;{r-zj&8ieI+X2? z9Y0`m?1YlY0k>lg%426@C<&f8V(+Ak&v8%^bG5}!urr5$C^Jv%pHLEZWF8;qo#*oZ E0MJPC_5c6? literal 0 HcmV?d00001 diff --git a/runtime/wasm/marshal.wat b/runtime/wasm/marshal.wat index 3840b22434..eae45781cc 100644 --- a/runtime/wasm/marshal.wat +++ b/runtime/wasm/marshal.wat @@ -30,11 +30,6 @@ (func $caml_is_closure (param (ref eq)) (result i32))) (import "effect" "caml_is_continuation" (func $caml_is_continuation (param (ref eq)) (result i32))) - (import "bindings" "map_new" (func $map_new (result (ref any)))) - (import "bindings" "map_get" - (func $map_get (param (ref any)) (param (ref eq)) (result i31ref))) - (import "bindings" "map_set" - (func $map_set (param (ref any)) (param (ref eq)) (param (ref i31)))) (import "io" "caml_really_putblock" (func $caml_really_putblock (param (ref eq)) (param (ref $bytes)) (param i32) (param i32))) @@ -49,6 +44,76 @@ (import "custom" "caml_find_custom_operations" (func $caml_find_custom_operations (param (ref $bytes)) (result (ref null $custom_operations)))) + (type $block (array (mut (ref eq)))) +(@if wasi +(@then + (type $map + (struct + (field $size (mut i32)) + (field $keys (mut (ref $block))) + (field $values (mut (ref $block))))) + (func $map_new (result (ref any)) + (struct.new $map + (i32.const 0) + (array.new $block (ref.i31 (i32.const 0)) (i32.const 2)) + (array.new $block (ref.i31 (i32.const 0)) (i32.const 2)))) + (func $map_get (param $map (ref any)) (param $k (ref eq)) (result i31ref) + (local $m (ref $map)) (local $keys (ref $block)) + (local $i i32) (local $size i32) + (local.set $m (ref.cast (ref $map) (local.get $map))) + (local.set $size (struct.get $map $size (local.get $m))) + (local.set $keys (struct.get $map $keys (local.get $m))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $size)) + (then + (if (ref.eq (array.get $block (local.get $keys) (local.get $i)) + (local.get $k)) + (then + (return + (ref.cast (ref i31) + (array.get $block + (struct.get $map $values (local.get $m)) + (local.get $i)))))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (ref.null i31)) + (func $map_set (param $map (ref any)) (param $k (ref eq)) (param $v (ref i31)) + (local $m (ref $map)) (local $i i32) (local $size i32) + (local $keys (ref $block)) (local $a (ref $block)) + (local.set $m (ref.cast (ref $map) (local.get $map))) + (local.set $i (struct.get $map $size (local.get $m))) + (local.set $keys (struct.get $map $keys (local.get $m))) + (if (i32.eq (local.get $i) (array.len (local.get $keys))) + (then + (local.set $size (i32.shl (local.get $i) (i32.const 1))) + (local.set $a + (array.new $block (ref.i31 (i32.const 0)) (local.get $size))) + (array.copy $block $block + (local.get $a) (i32.const 0) + (local.get $keys) (i32.const 0) + (local.get $i)) + (struct.set $map $keys (local.get $m) (local.get $a)) + (local.set $keys (local.get $a)) + (local.set $a + (array.new $block (ref.i31 (i32.const 0)) (local.get $size))) + (array.copy $block $block + (local.get $a) (i32.const 0) + (struct.get $map $values (local.get $m)) (i32.const 0) + (local.get $i)) + (struct.set $map $values (local.get $m) (local.get $a)))) + (array.set $block (local.get $keys) (local.get $i) (local.get $k)) + (array.set $block (struct.get $map $values (local.get $m)) + (local.get $i) (local.get $v)) + (struct.set $map $size (local.get $m) + (i32.add (local.get $i) (i32.const 1)))) +) +(@else + (import "bindings" "map_new" (func $map_new (result (ref any)))) + (import "bindings" "map_get" + (func $map_get (param (ref any)) (param (ref eq)) (result i31ref))) + (import "bindings" "map_set" + (func $map_set (param (ref any)) (param (ref eq)) (param (ref i31)))) +)) (@string $input_val_from_string "input_value_from_string") @@ -105,7 +170,6 @@ (local.set $s (call $get_intern_state (local.get $buf) (i32.const 0))) (return_call $intern_rec (local.get $s) (local.get $h))) - (type $block (array (mut (ref eq)))) (type $bytes (array (mut i8))) (type $float (struct (field f64))) (type $float_array (array (mut f64))) diff --git a/runtime/wasm/prng.wat b/runtime/wasm/prng.wat index 4918eaa0bf..08e242056e 100644 --- a/runtime/wasm/prng.wat +++ b/runtime/wasm/prng.wat @@ -16,10 +16,20 @@ ;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (module + +(@if wasi +(@then + (import "bigarray" "ta_get_i32" + (func $ta_get_i32 (param (ref extern)) (param i32) (result i32))) + (import "bigarray" "ta_set_i32" + (func $ta_set_i32 (param (ref extern)) (param i32) (param i32))) +) +(@else (import "bindings" "ta_get_i32" (func $ta_get_i32 (param (ref extern)) (param i32) (result i32))) (import "bindings" "ta_set_i32" (func $ta_set_i32 (param (ref extern)) (param i32) (param i32))) +)) (import "bigarray" "caml_ba_get_data" (func $caml_ba_get_data (param (ref eq)) (result (ref extern)))) diff --git a/runtime/wasm/runtime-wasi.js b/runtime/wasm/runtime-wasi.js new file mode 100644 index 0000000000..b5f4d38d6a --- /dev/null +++ b/runtime/wasm/runtime-wasi.js @@ -0,0 +1,84 @@ +// Wasm_of_ocaml runtime support +// http://www.ocsigen.org/js_of_ocaml/ +// +// This program is free software; you can redistribute it and/or modify +// it under the terms of the GNU Lesser General Public License as published by +// the Free Software Foundation, with linking exception; +// either version 2.1 of the License, or (at your option) any later version. +// +// This program is distributed in the hope that it will be useful, +// but WITHOUT ANY WARRANTY; without even the implied warranty of +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +// GNU Lesser General Public License for more details. +// +// You should have received a copy of the GNU Lesser General Public License +// along with this program; if not, write to the Free Software +// Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +(js) => async (args) => { + // biome-ignore lint/suspicious/noRedundantUseStrict: + "use strict"; + + const emitWarning = process.emitWarning; + process.emitWarning = function (...args) { + if (args[1] !== "ExperimentalWarning") emitWarning(...args); + }; + + const { link, src, generated } = args; + + const { argv, env } = require("node:process"); + const { WASI } = require("node:wasi"); + const wasi = new WASI({ + version: "preview1", + args: argv.slice(1), + env, + preopens: { ".": ".", "/tmp": "/tmp" }, + returnOnExit: false, + }); + const imports = wasi.getImportObject(); + function loadRelative(src) { + const path = require("node:path"); + const f = path.join(path.dirname(require.main.filename), src); + return require("node:fs/promises").readFile(f); + } + async function instantiateModule(code) { + return WebAssembly.instantiate(await code, imports); + } + async function instantiateFromDir() { + imports.env = {}; + imports.OCaml = {}; + const deps = []; + async function loadModule(module, isRuntime) { + const sync = module[1].constructor !== Array; + async function instantiate() { + const code = loadRelative(src + "/" + module[0] + ".wasm"); + await Promise.all(sync ? deps : module[1].map((i) => deps[i])); + const wasmModule = await instantiateModule(code); + Object.assign( + isRuntime ? imports.env : imports.OCaml, + wasmModule.instance.exports, + ); + } + const promise = instantiate(); + deps.push(promise); + return promise; + } + async function loadModules(lst) { + for (const module of lst) { + await loadModule(module); + } + } + await loadModule(link[0], 1); + if (link.length > 1) { + await loadModule(link[1]); + const workers = new Array(20) + .fill(link.slice(2).values()) + .map(loadModules); + await Promise.all(workers); + } + return { instance: { exports: Object.assign(imports.env, imports.OCaml) } }; + } + const wasmModule = await instantiateFromDir(); + + wasi.start(wasmModule.instance); +}; diff --git a/runtime/wasm/stdlib.wat b/runtime/wasm/stdlib.wat index 62ff000f26..12c21652d5 100644 --- a/runtime/wasm/stdlib.wat +++ b/runtime/wasm/stdlib.wat @@ -31,7 +31,6 @@ (import "obj" "caml_callback_2" (func $caml_callback_2 (param (ref eq)) (param (ref eq)) (param (ref eq)) (result (ref eq)))) - (import "bindings" "write" (func $write (param i32) (param anyref))) (import "string" "caml_string_concat" (func $caml_string_concat (param (ref eq)) (param (ref eq)) (result (ref eq)))) @@ -39,9 +38,26 @@ (func $caml_format_exception (param (ref eq)) (result (ref eq)))) (import "sys" "ocaml_exit" (tag $ocaml_exit)) (import "fail" "ocaml_exception" (tag $ocaml_exception (param (ref eq)))) +(@if wasi +(@then + (import "wasi_snapshot_preview1" "proc_exit" (func $exit (param i32))) + (import "wasi_snapshot_preview1" "fd_write" + (func $fd_write (param i32 i32 i32 i32) (result i32))) + (import "wasi_memory" "get_buffer" (func $get_buffer (result i32))) + (import "wasi_memory" "write_string_to_memory" + (func $write_string_to_memory (param i32 i32 (ref eq)) (result i32))) + (import "wasi_memory" "release_memory" + (func $release_memory (param i32 i32))) + (import "io" "IO_BUFFER_SIZE" (global $IO_BUFFER_SIZE i32)) + (import "libc" "memory" (memory 2)) +) +(@else + (import "bindings" "write" (func $write (param i32) (param anyref))) + (import "bindings" "exit" (func $exit (param i32))) + (import "bindings" "throw" (func $throw (param externref))) (import "fail" "javascript_exception" (tag $javascript_exception (param externref))) - (import "bindings" "exit" (func $exit (param i32))) +)) (type $block (array (mut (ref eq)))) (type $bytes (array (mut i8))) @@ -187,6 +203,8 @@ (global $uncaught_exception (mut externref) (ref.null extern)) +(@if (not wasi) +(@then (func $reraise_exception (result (ref eq)) (throw $javascript_exception (global.get $uncaught_exception)) (ref.i31 (i32.const 0))) @@ -194,9 +212,18 @@ (func (export "caml_handle_uncaught_exception") (param $exn externref) (global.set $uncaught_exception (local.get $exn)) (call $caml_main (ref.func $reraise_exception))) +)) (func $caml_main (export "caml_main") (param $start (ref func)) (local $exn (ref eq)) + (local $msg (ref eq)) +(@if wasi +(@then + (local $buffer i32) (local $i i32) (local $len i32) + (local $buf i32) (local $remaining i32) + (local $iovs i32) (local $iovs_len i32) (local $nwritten i32) + (local $res i32) +)) (try (do (drop (call_ref $func (ref.cast (ref $func) (local.get $start))))) @@ -223,13 +250,48 @@ (br_on_null $null (call $caml_named_value (global.get $do_at_exit))) (ref.i31 (i32.const 0))))) + (local.set $msg + (call $caml_string_concat + (global.get $fatal_error) + (call $caml_string_concat + (call $caml_format_exception (local.get $exn)) + (@string "\n")))) +(@if wasi +(@then + (local.set $len + (array.len (ref.cast (ref $bytes) (local.get $msg)))) + (local.set $buffer (call $get_buffer)) + (local.set $nwritten (local.get $buffer)) + (local.set $iovs (i32.add (local.get $buffer) (i32.const 4))) + (local.set $iovs_len (i32.const 1)) + (local.set $buffer (i32.add (local.get $buffer) (i32.const 12))) + (local.set $buf + (call $write_string_to_memory + (local.get $buf) (global.get $IO_BUFFER_SIZE) + (local.get $msg))) + (local.set $remaining (local.get $buf)) + (loop $write + (i32.store (local.get $iovs) (local.get $remaining)) + (i32.store offset=4 (local.get $iovs) (local.get $len)) + (local.set $res + (call $fd_write + (i32.const 2) (local.get $iovs) (local.get $iovs_len) + (local.get $nwritten))) + (if (i32.eqz (local.get $res)) + (then + (local.set $len + (i32.sub (local.get $len) + (i32.load (local.get $nwritten)))) + (local.set $remaining + (i32.add (local.get $remaining) + (i32.load (local.get $nwritten)))) + (br_if $write (local.get $len))))) + (call $release_memory (local.get $buffer) (local.get $buf)) +) +(@else (call $write (i32.const 2) (call $unwrap - (call $caml_jsstring_of_string - (call $caml_string_concat - (global.get $fatal_error) - (call $caml_string_concat - (call $caml_format_exception (local.get $exn)) - (@string "\n"))))))) - (call $exit (i32.const 2))))) -) + (call $caml_jsstring_of_string (local.get $msg)))) +)) + ) + (call $exit (i32.const 2)))))) diff --git a/runtime/wasm/sys.wat b/runtime/wasm/sys.wat index 788e0ee478..89e3e3e83e 100644 --- a/runtime/wasm/sys.wat +++ b/runtime/wasm/sys.wat @@ -16,11 +16,40 @@ ;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (module - (import "bindings" "ta_length" - (func $ta_length (param (ref extern)) (result i32))) - (import "bindings" "ta_get_i32" - (func $ta_get_i32 (param (ref extern)) (param i32) (result i32))) - (import "bindings" "random_seed" (func $random_seed (result (ref extern)))) + (import "fail" "caml_invalid_argument" + (func $caml_invalid_argument (param (ref eq)))) + (import "fail" "caml_raise_sys_error" + (func $caml_raise_sys_error (param (ref eq)))) + (import "fail" "caml_raise_not_found" (func $caml_raise_not_found)) +(@if wasi +(@then + (import "wasi_snapshot_preview1" "random_get" + (func $random_get (param i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "clock_time_get" + (func $clock_time_get (param i32 i64 i32) (result i32))) + (import "wasi_snapshot_preview1" "args_get" + (func $args_get (param i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "args_sizes_get" + (func $args_sizes_get (param i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "environ_get" + (func $environ_get (param i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "environ_sizes_get" + (func $environ_sizes_get (param i32 i32) (result i32))) + (import "libc" "memory" (memory 2)) + (import "libc" "free" (func $free (param i32))) + (import "libc" "strlen" (func $strlen (param i32) (result i32))) + (import "wasi_memory" "checked_malloc" + (func $checked_malloc (param i32) (result i32))) + (import "wasi_memory" "get_buffer" (func $get_buffer (result i32))) + (import "wasi_memory" "blit_memory_to_string" + (func $blit_memory_to_string (param i32 i32) (result (ref $bytes)))) + (import "wasi_errors" "error_messages" (global $error_messages (ref $block))) + (import "string" "caml_string_concat" + (func $caml_string_concat + (param (ref eq)) (param (ref eq)) (result (ref eq)))) + (import "wasi_snapshot_preview1" "proc_exit" (func $exit (param i32))) +) +(@else (import "jslib" "unwrap" (func $unwrap (param (ref eq)) (result anyref))) (import "jslib" "wrap" (func $wrap (param anyref) (result (ref eq)))) (import "jslib" "caml_jsstring_of_string" @@ -32,9 +61,11 @@ (import "jslib" "caml_js_meth_call" (func $caml_js_meth_call (param (ref eq)) (param (ref eq)) (param (ref eq)) (result (ref eq)))) - (import "fail" "caml_raise_sys_error" - (func $caml_raise_sys_error (param (ref eq)))) - (import "fail" "caml_raise_not_found" (func $caml_raise_not_found)) + (import "bindings" "ta_length" + (func $ta_length (param (ref extern)) (result i32))) + (import "bindings" "ta_get_i32" + (func $ta_get_i32 (param (ref extern)) (param i32) (result i32))) + (import "bindings" "random_seed" (func $random_seed (result (ref extern)))) (import "bindings" "argv" (func $argv (result (ref extern)))) (import "bindings" "on_windows" (global $on_windows i32)) (import "bindings" "isatty" @@ -42,15 +73,12 @@ (import "bindings" "system" (func $system (param anyref) (result (ref eq)))) (import "bindings" "getenv" (func $getenv (param anyref) (result anyref))) (import "bindings" "time" (func $time (result f64))) - (import "bindings" "array_length" - (func $array_length (param (ref extern)) (result i32))) - (import "bindings" "array_get" - (func $array_get (param (ref extern)) (param i32) (result anyref))) (import "fail" "javascript_exception" (tag $javascript_exception (param externref))) (import "jsstring" "jsstring_test" (func $jsstring_test (param anyref) (result i32))) - (import "bindings" "exit" (func $exit (param (ref eq)))) + (import "bindings" "exit" (func $exit (param i32))) +)) (import "io" "caml_channel_descriptor" (func $caml_channel_descriptor (param (ref eq)) (result (ref eq)))) @@ -62,12 +90,100 @@ (func (export "caml_sys_exit") (export "unix_exit") (export "caml_unix_exit") (param $code (ref eq)) (result (ref eq)) - (call $exit (local.get $code)) + (call $exit (i31.get_s (ref.cast (ref i31) (local.get $code)))) ;; Fallback: try to exit through an exception (throw $ocaml_exit)) - (export "caml_sys_unsafe_getenv" (func $caml_sys_getenv)) - (func $caml_sys_getenv (export "caml_sys_getenv") +(@if wasi +(@then + (global $environment (mut i32) (i32.const 0)) + (global $environment_count (mut i32) (i32.const 0)) + (global $environment_data (mut i32) (i32.const 0)) + + (func $initialize_env + (local $buffer i32) (local $res i32) (local $env i32) (local $data i32) + (if (i32.eqz (global.get $environment)) + (then + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $environ_sizes_get + (local.get $buffer) + (i32.add (local.get $buffer) (i32.const 4)))) + (if (local.get $res) + (then + (call $caml_handle_sys_error + (ref.i31 (i32.const 0)) (local.get $res)))) + (local.set $env + (call $checked_malloc + (i32.shl (i32.load (local.get $buffer)) (i32.const 2)))) + (local.set $data + (call $checked_malloc (i32.load offset=4 (local.get $buffer)))) + (local.set $res + (call $environ_get (local.get $env) (local.get $data))) + (if (local.get $res) + (then + (call $caml_handle_sys_error + (ref.i31 (i32.const 0)) (local.get $res)))) + (global.set $environment (local.get $env)) + (global.set $environment_data (local.get $data)) + (global.set $environment_count (i32.load (local.get $buffer)))))) + + (func (export "caml_sys_getenv") (export "caml_sys_unsafe_getenv") + (param $name (ref eq)) (result (ref eq)) + (local $var (ref $bytes)) (local $i i32) (local $j i32) + (local $len i32) (local $s i32) (local $c i32) + (call $initialize_env) + (local.set $var (ref.cast (ref $bytes) (local.get $name))) + (local.set $len (array.len (local.get $var))) + (block $not_found + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (br_if $not_found + (i32.eq (i32.const 61) ;; '=' + (array.get_u $bytes (local.get $var) (local.get $i)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (local.set $i (i32.const 0)) + (loop $loop + (if (i32.lt_u (local.get $i) (global.get $environment_count)) + (then + (local.set $s + (i32.load + (i32.add (global.get $environment) + (i32.shl (local.get $i) (i32.const 2))))) + (local.set $j (i32.const 0)) + (block $next + (loop $scan + (if (i32.lt_u (local.get $j) (local.get $len)) + (then + (local.set $c + (i32.load8_u + (i32.add (local.get $s) (local.get $j)))) + (br_if $next (i32.eqz (local.get $c))) + (br_if $next + (i32.ne (local.get $c) + (array.get $bytes + (local.get $var) (local.get $j)))) + (local.set $j + (i32.add (local.get $j) (i32.const 1))) + (br $scan)))) + (br_if $next + (i32.ne (i32.const 61) ;; '=' + (i32.load8_u + (i32.add (local.get $s) (local.get $j))))) + (local.set $s + (i32.add (local.get $s) + (i32.add (local.get $j) (i32.const 1)))) + (return_call $blit_memory_to_string + (local.get $s) (call $strlen (local.get $s)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop))))) + (call $caml_raise_not_found) + (ref.i31 (i32.const 0))) +) +(@else + (func (export "caml_sys_getenv") (export "caml_sys_unsafe_getenv") (param (ref eq)) (result (ref eq)) (local $res anyref) (local.set $res @@ -77,7 +193,65 @@ (then (call $caml_raise_not_found))) (return_call $caml_string_of_jsstring (call $wrap (local.get $res)))) +)) + +(@if wasi +(@then + (global $argv (mut (ref null $block)) (ref.null $block)) + + (func $caml_sys_argv (export "caml_sys_argv") + (param (ref eq)) (result (ref eq)) + (local $buffer i32) (local $res i32) + (local $argc i32) (local $argv i32) (local $argv_buf i32) + (local $args (ref $block)) (local $arg i32) (local $i i32) + (block $init + (return (br_on_null $init (global.get $argv)))) + (block $error + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $args_sizes_get + (local.get $buffer) + (i32.add (local.get $buffer) (i32.const 4)))) + (br_if $error (local.get $res)) + (local.set $argc (i32.load (local.get $buffer))) + (local.set $argv + (call $checked_malloc (i32.shl (local.get $argc) (i32.const 2)))) + (local.set $argv_buf + (call $checked_malloc (i32.load offset=4 (local.get $buffer)))) + (local.set $res + (call $args_get (local.get $argv) (local.get $argv_buf))) + (br_if $error (local.get $res)) + (local.set $args + (array.new $block (ref.i31 (i32.const 0)) + (i32.add (local.get $argc) (i32.const 1)))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $argc)) + (then + (local.set $arg + (i32.load + (i32.add (local.get $argv) + (i32.shl (local.get $i) (i32.const 2))))) + (array.set $block (local.get $args) + (i32.add (local.get $i) (i32.const 1)) + (call $blit_memory_to_string + (local.get $arg) (call $strlen (local.get $arg)))) + (local.set $i + (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (global.set $argv (local.get $args)) + (call $free (local.get $argv)) + (call $free (local.get $argv_buf)) + (return (local.get $args))) + (call $caml_handle_sys_error (ref.i31 (i32.const 0)) (local.get $res)) + (array.new_fixed $block 0)) + (func (export "caml_sys_executable_name") + (param (ref eq)) (result (ref eq)) + (array.get $block + (ref.cast (ref $block) (call $caml_sys_argv (ref.i31 (i32.const 0)))) + (i32.const 1))) +) +(@else (func (export "caml_sys_argv") (param (ref eq)) (result (ref eq)) ;; ZZZ (call $caml_js_to_string_array (call $argv))) @@ -87,24 +261,83 @@ (array.get $block (ref.cast (ref $block) (call $caml_js_to_string_array (call $argv))) (i32.const 1))) +)) - (export "caml_sys_time_include_children" (func $caml_sys_time)) - (func $caml_sys_time (export "caml_sys_time") +(@if wasi +(@then + (func (export "caml_sys_time") (export "caml_sys_time_include_children") + (param (ref eq)) (result (ref eq)) + (local $buffer i32) (local $res i32) + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $clock_time_get (i32.const 2) (i64.const 1) (local.get $buffer))) + (if (local.get $res) + (then + (call $caml_handle_sys_error + (ref.i31 (i32.const 0)) (local.get $res)))) + (struct.new $float + (f64.mul (f64.convert_i64_u (i64.load (local.get $buffer))) + (f64.const 1e-9)))) +) +(@else + (func (export "caml_sys_time") (export "caml_sys_time_include_children") (param (ref eq)) (result (ref eq)) (struct.new $float (f64.mul (call $time) (f64.const 0.001)))) +)) +(@if wasi +(@then + (func (export "caml_sys_system_command") + (param (ref eq)) (result (ref eq)) + (call $caml_invalid_argument (@string "Sys.command not implemented")) + (return (ref.i31 (i32.const 0)))) +) +(@else (func (export "caml_sys_system_command") (param (ref eq)) (result (ref eq)) - ;; ZZZ (try (do (return (call $system (call $unwrap (call $caml_jsstring_of_string (local.get 0)))))) (catch $javascript_exception - (call $caml_handle_sys_error (pop externref)) - (return (ref.i31 (i32.const 0)))))) + (call $caml_handle_sys_error (pop externref)))) + (return (ref.i31 (i32.const 0)))) +)) +(@if wasi +(@then + (func (export "caml_sys_random_seed") + (param (ref eq)) (result (ref eq)) + (local $r (ref extern)) + (local $a (ref $block)) + (local $i i32) (local $n i32) + (local $buffer i32) (local $res i32) + (local.set $n (i32.const 12)) + (local.set $buffer (call $get_buffer)) + (local.set $res (call $random_get (local.get $buffer) (i32.const 96))) + (if (local.get $res) + (then + (call $caml_handle_sys_error + (ref.i31 (i32.const 0)) (local.get $res)))) + (local.set $a + (array.new $block (ref.i31 (i32.const 0)) + (i32.add (local.get $n) (i32.const 1)))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $n)) + (then + (array.set $block + (local.get $a) (i32.add (local.get $i) (i32.const 1)) + (ref.i31 + (i32.load + (i32.add + (local.get $buffer + (i32.shl (local.get $i) (i32.const 2))))))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (local.get $a)) +) +(@else (func (export "caml_sys_random_seed") (param (ref eq)) (result (ref eq)) (local $r (ref extern)) @@ -115,7 +348,6 @@ (local.set $a (array.new $block (ref.i31 (i32.const 0)) (i32.add (local.get $n) (i32.const 1)))) - (local.set $i (i32.const 0)) (loop $loop (if (i32.lt_u (local.get $i) (local.get $n)) (then @@ -125,6 +357,7 @@ (local.set $i (i32.add (local.get $i) (i32.const 1))) (br $loop)))) (local.get $a)) +)) (func (export "caml_sys_const_bigendian") (param (ref eq)) (result (ref eq)) @@ -142,6 +375,11 @@ (param (ref eq)) (result (ref eq)) (ref.i31 (i32.const 0xfffffff))) +(@if wasi +(@then + (global $on_windows i32 (i32.const 0)) +)) + (func (export "caml_sys_const_ostype_unix") (param (ref eq)) (result (ref eq)) (ref.i31 (i32.eqz (global.get $on_windows)))) @@ -165,9 +403,17 @@ (ref.i31 (i32.const 32)) (ref.i31 (i32.const 0)))) +(@if wasi +(@then + (func (export "caml_sys_isatty") + (param $ch (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) +) +(@else (func (export "caml_sys_isatty") (param $ch (ref eq)) (result (ref eq)) (return_call $isatty (call $caml_channel_descriptor (local.get $ch)))) +)) (func (export "caml_runtime_variant") (param (ref eq)) (result (ref eq)) (@string "")) @@ -193,6 +439,28 @@ (@string $toString "toString") +(@if wasi +(@then + (func $caml_handle_sys_error (export "caml_handle_sys_error") + (param $arg (ref eq)) (param $errno i32) + (local $msg (ref eq)) + (local.set $msg + (if (result (ref eq)) (i32.gt_u (local.get $errno) + (array.len (global.get $error_messages))) + (then + (@string "unknown system error")) + (else + (array.get $block (global.get $error_messages) + (local.get $errno))))) + (if (ref.test (ref $bytes) (local.get $arg)) + (then + (local.set $msg + (call $caml_string_concat (local.get $arg) + (call $caml_string_concat (@string ": ") (local.get $msg)))))) + (call $caml_raise_sys_error (local.get $msg)) + ) +) +(@else (func $caml_handle_sys_error (export "caml_handle_sys_error") (param $exn externref) (call $caml_raise_sys_error @@ -201,4 +469,5 @@ (call $wrap (any.convert_extern (local.get $exn))) (global.get $toString) (array.new_fixed $block 1 (ref.i31 (i32.const 0))))))) +)) ) diff --git a/runtime/wasm/unix.wat b/runtime/wasm/unix.wat index 8bb79b9c9a..65878ed423 100644 --- a/runtime/wasm/unix.wat +++ b/runtime/wasm/unix.wat @@ -16,6 +16,73 @@ ;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (module +(@if wasi +(@then + (import "wasi_snapshot_preview1" "clock_time_get" + (func $clock_time_get (param i32 i64 i32) (result i32))) + (import "wasi_snapshot_preview1" "path_filestat_get" + (func $path_filestat_get (param i32 i32 i32 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "path_rename" + (func $path_rename (param i32 i32 i32 i32 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "path_link" + (func $path_link (param i32 i32 i32 i32 i32 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "path_symlink" + (func $path_symlink (param i32 i32 i32 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "path_readlink" + (func $path_readlink (param i32 i32 i32 i32 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "path_create_directory" + (func $path_create_directory (param i32 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "path_unlink_file" + (func $path_unlink_file (param i32 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "path_remove_directory" + (func $path_remove_directory (param i32 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "path_open" + (func $path_open (param i32 i32 i32 i32 i32 i64 i64 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "path_filestat_set_times" + (func $path_filestat_set_times + (param i32 i32 i32 i32 i64 i64 i32) (result i32))) + (import "wasi_snapshot_preview1" "fd_filestat_get" + (func $fd_filestat_get (param i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "fd_filestat_set_size" + (func $fd_filestat_set_size (param i32 i64) (result i32))) + (import "wasi_snapshot_preview1" "fd_write" + (func $fd_write (param i32 i32 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "fd_read" + (func $fd_read (param i32 i32 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "fd_seek" + (func $fd_seek (param i32 i64 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "fd_sync" + (func $fd_sync (param i32) (result i32))) + (import "wasi_snapshot_preview1" "fd_close" + (func $fd_close (param i32) (result i32))) + (import "wasi_snapshot_preview1" "fd_readdir" + (func $fd_readddir (param i32 i32 i32 i64 i32) (result i32))) + (import "libc" "memory" (memory 2)) + (import "libc" "free" (func $free (param i32))) + (import "libc" "gmtime" (func $gmtime (param i32) (result i32))) + (import "libc" "localtime" (func $localtime (param i32) (result i32))) + (import "libc" "mktime" (func $mktime (param i32) (result i64))) + (import "wasi_memory" "checked_malloc" + (func $checked_malloc (param i32) (result i32))) + (import "wasi_memory" "get_buffer" (func $get_buffer (result i32))) + (import "wasi_memory" "write_string_to_memory" + (func $write_string_to_memory (param i32 i32 (ref eq)) (result i32))) + (import "wasi_memory" "blit_memory_to_string" + (func $blit_memory_to_string (param i32 i32) (result (ref $bytes)))) + (import "wasi_memory" "blit_memory_to_substring" + (func $blit_memory_to_substring (param i32 (ref $bytes) i32 i32))) + (import "wasi_memory" "blit_substring_to_memory" + (func $blit_substring_to_memory (param i32 (ref $bytes) i32 i32))) + (import "fs" "wasi_resolve_path" + (func $wasi_resolve_path (param (ref eq)) (result i32 i32 i32))) + (import "fs" "wasi_chdir" (func $wasi_chdir (param (ref eq)))) + (import "wasi_errors" "error_messages" (global $error_messages (ref $block))) + (import "ints" "caml_format_int" + (func $caml_format_int (param (ref eq) (ref eq)) (result (ref eq)))) + (import "string" "caml_string_concat" + (func $caml_string_concat (param (ref eq) (ref eq)) (result (ref eq)))) +) +(@else (import "bindings" "gettimeofday" (func $gettimeofday (result f64))) (import "bindings" "times" (func $times (result (ref eq)))) (import "bindings" "gmtime" (func $gmtime (param f64) (result (ref eq)))) @@ -80,6 +147,7 @@ (func $caml_jsstring_of_string (param (ref eq)) (result (ref eq)))) (import "jsstring" "jsstring_test" (func $jsstring_test (param anyref) (result i32))) +)) (import "stdlib" "caml_named_value" (func $caml_named_value (param (ref eq)) (result (ref null eq)))) (import "fail" "ocaml_exception" (tag $ocaml_exception (param (ref eq)))) @@ -149,6 +217,102 @@ (@string $no_arg "") +(@if wasi +(@then + (func $unix_resolve_path (export "unix_resolve_path") + (param $cmd (ref eq)) (param $path (ref eq)) (result i32 i32 i32) + (local $res (tuple i32 i32 i32)) + (local.set $res (call $wasi_resolve_path (local.get $path))) + (if (i32.lt_s (tuple.extract 3 0 (local.get $res)) (i32.const 0)) + (then + (call $caml_unix_error + (i32.const 44) ;; ENOENT + (local.get $cmd) (local.get $path)))) + (local.get $res)) + + (type $constr_table (array i8)) + (global $error_codes (ref $constr_table) + (array.new_fixed $constr_table 77 + (i32.const -1) + (i32.const 0) (i32.const 1) (i32.const 50) (i32.const 51) + (i32.const 49) (i32.const 2) (i32.const 39) (i32.const 3) + (i32.const -1) (i32.const 4) (i32.const -1) (i32.const 5) + (i32.const 55) (i32.const 63) (i32.const 56) (i32.const 6) + (i32.const 41) (i32.const 7) (i32.const -1) (i32.const 8) + (i32.const 9) (i32.const 10) (i32.const 65) (i32.const -1) + (i32.const -1) (i32.const 38) (i32.const 11) (i32.const 12) + (i32.const 13) (i32.const 58) (i32.const 14) (i32.const 66) + (i32.const 15) (i32.const 16) (i32.const 42) (i32.const -1) + (i32.const 17) (i32.const 52) (i32.const 54) (i32.const 53) + (i32.const 18) (i32.const 57) (i32.const 19) (i32.const 20) + (i32.const 21) (i32.const 22) (i32.const -1) (i32.const 23) + (i32.const -1) (i32.const 44) (i32.const 24) (i32.const 25) + (i32.const 59) (i32.const 26) (i32.const 27) (i32.const -1) + (i32.const 40) (i32.const 47) (i32.const 28) (i32.const 29) + (i32.const 67) (i32.const -1) (i32.const 30) (i32.const 31) + (i32.const -1) (i32.const 45) (i32.const 43) (i32.const 32) + (i32.const 33) (i32.const 34) (i32.const 35) (i32.const -1) + (i32.const 62) (i32.const -1) (i32.const 36) (i32.const -1))) + + (func $caml_unix_error_of_code (param $errcode i32) (result (ref eq)) + (local $err i32) + (if (i32.le_u (local.get $errcode) (i32.const 76)) + (then + (local.set $err + (array.get_s $constr_table (global.get $error_codes) + (local.get $errcode))) + (if (i32.ne (local.get $err) (i32.const -1)) + (then + (return (ref.i31 (local.get $err))))))) + (array.new_fixed $block 2 + (ref.i31 (i32.const 0)) (ref.i31 (local.get $errcode)))) + + (func $caml_unix_error + (param $errcode i32) (param $cmd_name (ref eq)) (param $cmd_arg (ref eq)) + (throw $ocaml_exception + (array.new_fixed $block 5 + (ref.i31 (i32.const 0)) + (call $get_unix_error_exn) + (call $caml_unix_error_of_code (local.get $errcode)) + (local.get $cmd_name) + (local.get $cmd_arg)))) + + (func (export "unix_error_message") (export "caml_unix_error_message") + (param $err (ref eq)) (result (ref eq)) + (local $errcode i32) (local $i i32) (local $n i32) + (if (ref.test (ref i31) (local.get $err)) + (then + (local.set $n (i31.get_u (ref.cast (ref i31) (local.get $err)))) + (loop $loop + (if (i32.lt_u (local.get $errcode) + (array.len (global.get $error_codes))) + (then + (if (i32.ne (local.get $n) + (array.get $constr_table (global.get $error_codes) + (local.get $errcode))) + (then + (local.set $errcode + (i32.add (local.get $errcode) (i32.const 1))) + (br $loop)))) + (else + (local.set $errcode (i32.const -1)))))) + (else + (local.set $errcode + (i31.get_u + (ref.cast (ref i31) + (array.get $block + (ref.cast (ref $block) (local.get $err)) + (i32.const 1))))))) + (if (i32.gt_u (local.get $errcode) + (array.len (global.get $error_messages))) + (then + (return_call $caml_string_concat + (@string "Unknown error ") + (call $caml_format_int (@string "%d") + (ref.i31 (local.get $errcode)))))) + (array.get $block (global.get $error_messages) (local.get $errcode))) +) +(@else (global $unix_error (ref eq) (struct.new $js (global.get $unix_error_js))) (func $ensure_string (param $s (ref eq)) (result (ref eq)) @@ -228,11 +392,52 @@ (i32.const 1)))))))) (return_call $caml_string_of_jsstring (call $wrap (call $caml_strerror (local.get $errno))))) +)) +(@if wasi +(@then + (func (export "unix_gettimeofday") (export "caml_unix_gettimeofday") + (param (ref eq)) (result (ref eq)) + (local $buffer i32) (local $res i32) + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $clock_time_get + (i32.const 0) (i64.const 1000) (local.get $buffer))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (@string "gettimeofday") (global.get $no_arg)))) + (struct.new $float + (f64.mul (f64.convert_i64_u (i64.load (local.get $buffer))) + (f64.const 1e-9)))) +) +(@else (func (export "unix_gettimeofday") (export "caml_unix_gettimeofday") (param (ref eq)) (result (ref eq)) (struct.new $float (call $gettimeofday))) +)) +(@if wasi +(@then + (func (export "unix_times") (export "caml_unix_times") + (param (ref eq)) (result (ref eq)) + (local $buffer i32) (local $res i32) + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $clock_time_get + (i32.const 2) (i64.const 1) (local.get $buffer))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) + (@string "time") + (global.get $no_arg)))) + (array.new_fixed $float_array 4 + (f64.mul (f64.convert_i64_u (i64.load (local.get $buffer))) + (f64.const 1e-9)) + (f64.const 0) (f64.const 0) (f64.const 0))) +) +(@else (func (export "caml_alloc_times") (param $u f64) (param $s f64) (result (ref eq)) (array.new_fixed $float_array 4 @@ -241,7 +446,24 @@ (func (export "unix_times") (export "caml_unix_times") (param (ref eq)) (result (ref eq)) (return_call $times)) +)) +(@if wasi +(@then + (func $alloc_tm (param $tm i32) (result (ref eq)) + (array.new_fixed $block 10 (ref.i31 (i32.const 0)) + (ref.i31 (i32.load (local.get $tm))) + (ref.i31 (i32.load offset=4 (local.get $tm))) + (ref.i31 (i32.load offset=8 (local.get $tm))) + (ref.i31 (i32.load offset=12 (local.get $tm))) + (ref.i31 (i32.load offset=16 (local.get $tm))) + (ref.i31 (i32.load offset=20 (local.get $tm))) + (ref.i31 (i32.load offset=24 (local.get $tm))) + (ref.i31 (i32.load offset=28 (local.get $tm))) + (ref.i31 (select (i32.const 1) (i32.const 0) + (i32.load offset=32 (local.get $tm)))))) +) +(@else (func (export "caml_alloc_tm") (param $sec i32) (param $min i32) (param $hour i32) (param $mday i32) (param $mon i32) (param $year i32) (param $wday i32) (param $yday i32) @@ -256,22 +478,132 @@ (ref.i31 (local.get $wday)) (ref.i31 (local.get $yday)) (ref.i31 (local.get $isdst)))) - - (func $unix_gmtime (export "unix_gmtime") (export "caml_unix_gmtime") +)) + +(@if wasi +(@then + (func (export "caml_unix_gmtime") (export "unix_gmtime") + (param $t (ref eq)) (result (ref eq)) + (local $buffer i32) (local $tm i32) + (local.set $buffer (call $get_buffer)) + (i64.store (local.get $buffer) + (i64.trunc_sat_f64_s + (struct.get $float 0 (ref.cast (ref $float) (local.get $t))))) + (local.set $tm (call $gmtime (local.get $buffer))) + (if (i32.eqz (local.get $tm)) + (then + (call $caml_unix_error (i32.const 28) (; EINVAL ;) + (@string "gmtime") (global.get $no_arg)))) + (return_call $alloc_tm (local.get $tm))) +) +(@else + (func (export "caml_unix_gmtime") (export "unix_gmtime") (param (ref eq)) (result (ref eq)) (call $gmtime (struct.get $float 0 (ref.cast (ref $float) (local.get 0))))) - - (func $unix_localtime (export "unix_localtime") (export "caml_unix_localtime") +)) + +(@if wasi +(@then + (func (export "caml_unix_localtime") (export "unix_localtime") + (param $t (ref eq)) (result (ref eq)) + (local $buffer i32) (local $tm i32) + (local.set $buffer (call $get_buffer)) + (i64.store (local.get $buffer) + (i64.trunc_sat_f64_s + (struct.get $float 0 (ref.cast (ref $float) (local.get $t))))) + (local.set $tm (call $localtime (local.get $buffer))) + (if (i32.eqz (local.get $tm)) + (then + (call $caml_unix_error (i32.const 28) (; EINVAL ;) + (@string "localtime") (global.get $no_arg)))) + (return_call $alloc_tm (local.get $tm))) +) +(@else + (func (export "caml_unix_localtime") (export "unix_localtime") (param (ref eq)) (result (ref eq)) (call $localtime (struct.get $float 0 (ref.cast (ref $float) (local.get 0))))) +)) - (func $unix_time (export "unix_time") (export "caml_unix_time") - (param (ref eq)) (result (ref eq)) +(@if wasi +(@then + (func (export "caml_unix_time") (export "unix_time") (param (ref eq)) + (result (ref eq)) + (local $buffer i32) (local $res i32) + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $clock_time_get + (i32.const 0) (i64.const 1000) (local.get $buffer))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (@string "time") (global.get $no_arg)))) + (struct.new $float + (f64.floor + (f64.mul (f64.convert_i64_u (i64.load (local.get $buffer))) + (f64.const 1e-9))))) +) +(@else + (func (export "caml_unix_time") (export "unix_time") (param (ref eq)) + (result (ref eq)) (struct.new $float (f64.floor (call $gettimeofday)))) - - (func $unix_mktime (export "unix_mktime") (export "caml_unix_mktime") +)) + +(@if wasi +(@then + (func (export "caml_unix_mktime") (export "unix_mktime") + (param $v (ref eq)) (result (ref eq)) + (local $t (ref $block)) (local $tm i32) (local $time i64) + (local.set $t (ref.cast (ref $block) (local.get $v))) + (local.set $tm (call $get_buffer)) + (i32.store (local.get $tm) + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $t) (i32.const 1))))) + (i32.store offset=4 (local.get $tm) + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $t) (i32.const 2))))) + (i32.store offset=8 (local.get $tm) + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $t) (i32.const 3))))) + (i32.store offset=12 (local.get $tm) + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $t) (i32.const 4))))) + (i32.store offset=16 (local.get $tm) + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $t) (i32.const 5))))) + (i32.store offset=20 (local.get $tm) + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $t) (i32.const 6))))) + (i32.store offset=24 (local.get $tm) + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $t) (i32.const 7))))) + (i32.store offset=28 (local.get $tm) + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $t) (i32.const 8))))) + (i32.store offset=32 (local.get $tm) + (i32.const -1)) + (local.set $time (call $mktime (local.get $tm))) + (if (i64.eq (local.get $time) (i64.const -1)) + (then + (call $caml_unix_error + (i32.const 68) (; ERANGE ;) + (@string "mktime") (global.get $no_arg)))) + (array.new_fixed $block 3 + (ref.i31 (i32.const 0)) + (struct.new $float (f64.convert_i64_s (local.get $time))) + (call $alloc_tm (local.get $tm)))) +) +(@else + (func (export "caml_unix_mktime") (export "unix_mktime") (param (ref eq)) (result (ref eq)) (local $tm (ref $block)) (local $t f64) (local.set $tm (ref.cast (ref $block) (local.get 0))) @@ -302,7 +634,53 @@ (array.new_fixed $block 3 (ref.i31 (i32.const 0)) (struct.new $float (local.get $t)) (call $localtime (local.get $t)))) +)) +(@if wasi +(@then + (@string $utimes "utimes") + + (func (export "unix_utimes") (export "caml_unix_utimes") + (param $path (ref eq)) (param $atime (ref eq)) (param $mtime (ref eq)) + (result (ref eq)) + (local $p (tuple i32 i32 i32)) + (local $atim i64) (local $mtim i64) + (local $set_to_now i32) (local $res i32) + (local $at f64) (local $mt f64) + (local.set $p + (call $unix_resolve_path (global.get $utimes) (local.get $path))) + (local.set $at + (struct.get $float 0 (ref.cast (ref $float) (local.get $atime)))) + (local.set $mt + (struct.get $float 0 (ref.cast (ref $float) (local.get $mtime)))) + (local.set $set_to_now + (i32.and (f64.eq (local.get $at) (f64.const 0)) + (f64.eq (local.get $mt) (f64.const 0)))) + (if (i32.eqz (local.get $set_to_now)) + (then + (local.set $atim + (i64.trunc_sat_f64_s + (f64.mul (local.get $at) (f64.const 1e9)))) + (local.set $mtim + (i64.trunc_sat_f64_s + (f64.mul (local.get $mt) (f64.const 1e9)))))) + (local.set $res + (call $path_filestat_set_times + (tuple.extract 3 0 (local.get $p)) + (i32.const 0) + (tuple.extract 3 1 (local.get $p)) + (tuple.extract 3 2 (local.get $p)) + (local.get $atim) + (local.get $mtim) + (i32.shl (i32.const 5) (local.get $set_to_now)))) + (call $free (tuple.extract 3 1 (local.get $p))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (global.get $utimes) (local.get $path)))) + (ref.i31 (i32.const 0))) +) +(@else (func (export "unix_utimes") (export "caml_unix_utimes") (param $path (ref eq)) (param $atime (ref eq)) (param $mtime (ref eq)) (result (ref eq)) @@ -324,6 +702,48 @@ (catch $javascript_exception (call $caml_unix_error (pop externref) (ref.null eq)))) (ref.i31 (i32.const 0))) +)) + +(@if wasi +(@then + (global $file_kinds (ref $constr_table) + (array.new_fixed $constr_table 8 + (i32.const 3) + (i32.const 3) + (i32.const 2) + (i32.const 1) + (i32.const 0) + (i32.const 6) + (i32.const 6) + (i32.const 4))) + + (func $alloc_stat (param $large i32) (param $p i32) (result (ref eq)) + (array.new_fixed $block 13 (ref.i31 (i32.const 0)) + (ref.i31 (i32.wrap_i64 (i64.load (local.get $p)))) + (ref.i31 (i32.wrap_i64 (i64.load offset=8 (local.get $p)))) + (ref.i31 + (array.get $constr_table + (global.get $file_kinds) (i32.load8_u offset=16 (local.get $p)))) + (ref.i31 (i32.const 384 (;0600;))) + (ref.i31 (i32.wrap_i64 (i64.load offset=24 (local.get $p)))) + (ref.i31 (i32.const 1)) + (ref.i31 (i32.const 1)) + (ref.i31 (i32.wrap_i64 (i64.load (local.get $p)))) + (if (result (ref eq)) (local.get $large) + (then + (call $caml_copy_int64 (i64.load offset=32 (local.get $p)))) + (else + (ref.i31 (i32.wrap_i64 (i64.load offset=32 (local.get $p)))))) + (struct.new $float + (f64.mul (f64.const 1e-9) + (f64.convert_i64_s (i64.load offset=40 (local.get $p))))) + (struct.new $float + (f64.mul (f64.const 1e-9) + (f64.convert_i64_s (i64.load offset=48 (local.get $p))))) + (struct.new $float + (f64.mul (f64.const 1e-9) + (f64.convert_i64_s (i64.load offset=56 (local.get $p))))))) +)) (func (export "caml_alloc_stat") (param $large i32) @@ -349,6 +769,76 @@ (struct.new $float (local.get $mtime)) (struct.new $float (local.get $ctime)))) +(@if wasi +(@then + (func $stat + (param $path (ref eq)) (param $large i32) (param $follow i32) + (param $name (ref eq)) (result (ref eq)) + (local $p (tuple i32 i32 i32)) + (local $buffer i32) (local $res i32) + (local.set $p + (call $unix_resolve_path (local.get $name) (local.get $path))) + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $path_filestat_get + (tuple.extract 3 0 (local.get $p)) + (local.get $follow) ;; symlink_follow + (tuple.extract 3 1 (local.get $p)) + (tuple.extract 3 2 (local.get $p)) + (local.get $buffer))) + (call $free (tuple.extract 3 1 (local.get $p))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (local.get $name) (local.get $path)))) + (return_call $alloc_stat (local.get $large) (local.get $buffer))) + + (@string $stat "stat") + + (func (export "unix_stat") (export "caml_unix_stat") + (param $path (ref eq)) (result (ref eq)) + (return_call $stat + (local.get $path) (i32.const 0) (i32.const 1) (global.get $stat))) + + (func (export "unix_stat_64") (export "caml_unix_stat_64") + (param $path (ref eq)) (result (ref eq)) + (return_call $stat + (local.get $path) (i32.const 1) (i32.const 1) (global.get $stat))) + + (@string $lstat "lstat") + + (func (export "unix_lstat") (export "caml_unix_lstat") + (param $path (ref eq)) (result (ref eq)) + (return_call $stat + (local.get $path) (i32.const 0) (i32.const 0) (global.get $lstat))) + + (func (export "unix_lstat_64") (export "caml_unix_lstat_64") + (param $path (ref eq)) (result (ref eq)) + (return_call $stat + (local.get $path) (i32.const 1) (i32.const 0) (global.get $lstat))) + + (func $fstat (param $fd (ref eq)) (param $large i32) (result (ref eq)) + (local $buffer i32) (local $res i32) + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $fd_filestat_get + (i31.get_u (ref.cast (ref i31) (local.get $fd))) + (local.get $buffer))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (@string "fstat") (global.get $no_arg)))) + (return_call $alloc_stat (local.get $large) (local.get $buffer))) + + (func (export "unix_fstat") (export "caml_unix_fstat") + (param $fd (ref eq)) (result (ref eq)) + (return_call $fstat (local.get $fd) (i32.const 0))) + + (func (export "unix_fstat_64") (export "caml_unix_fstat_64") + (param $fd (ref eq)) (result (ref eq)) + (return_call $fstat (local.get $fd) (i32.const 1))) +) +(@else (func (export "unix_stat") (export "caml_unix_stat") (param $path (ref eq)) (result (ref eq)) (try (result (ref eq)) @@ -410,7 +900,16 @@ (catch $javascript_exception (call $caml_unix_error (pop externref) (ref.null eq)) (ref.i31 (i32.const 0))))) +)) +(@if wasi +(@then + (func (export "unix_chmod") (export "caml_unix_chmod") + (param (ref eq) (ref eq)) (result (ref eq)) + ;; no notion of permissions in WASI + (ref.i31 (i32.const 0))) +) +(@else (func (export "unix_chmod") (export "caml_unix_chmod") (param $path (ref eq)) (param $perms (ref eq)) (result (ref eq)) (try @@ -421,7 +920,16 @@ (catch $javascript_exception (call $caml_unix_error (pop externref) (ref.null eq)))) (ref.i31 (i32.const 0))) +)) +(@if wasi +(@then + (func (export "unix_fchmod") (export "caml_unix_fchmod") + (param (ref eq) (ref eq)) (result (ref eq)) + ;; no notion of permissions in WASI + (ref.i31 (i32.const 0))) +) +(@else (func (export "unix_fchmod") (export "caml_unix_fchmod") (param $fd (ref eq)) (param $perms (ref eq)) (result (ref eq)) (try @@ -430,7 +938,38 @@ (catch $javascript_exception (call $caml_unix_error (pop externref) (ref.null eq)))) (ref.i31 (i32.const 0))) +)) +(@if wasi +(@then + (@string $rename "rename") + + (func (export "unix_rename") (export "caml_unix_rename") + (param $o (ref eq)) (param $n (ref eq)) (result (ref eq)) + (local $op (tuple i32 i32 i32)) + (local $np (tuple i32 i32 i32)) + (local $res i32) + (local.set $op + (call $unix_resolve_path (global.get $rename) (local.get $o))) + (local.set $np + (call $unix_resolve_path (global.get $rename) (local.get $n))) + (local.set $res + (call $path_rename + (tuple.extract 3 0 (local.get $op)) + (tuple.extract 3 1 (local.get $op)) + (tuple.extract 3 2 (local.get $op)) + (tuple.extract 3 0 (local.get $np)) + (tuple.extract 3 1 (local.get $np)) + (tuple.extract 3 2 (local.get $np)))) + (call $free (tuple.extract 3 1 (local.get $op))) + (call $free (tuple.extract 3 1 (local.get $np))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (global.get $rename) (local.get $o)))) + (ref.i31 (i32.const 0))) +) +(@else (func (export "unix_rename") (export "caml_unix_rename") (param $o (ref eq)) (param $n (ref eq)) (result (ref eq)) (try @@ -441,7 +980,39 @@ (catch $javascript_exception (call $caml_unix_error (pop externref) (ref.null eq)))) (ref.i31 (i32.const 0))) +)) + +(@if wasi +(@then + (@string $chdir "chdir") + (func (export "unix_chdir") (export "caml_unix_chdir") + (param $name (ref eq)) (result (ref eq)) + (local $p (tuple i32 i32 i32)) + (local $buffer i32) (local $res i32) (local $kind i32) + (local.set $p + (call $unix_resolve_path (global.get $chdir) (local.get $name))) + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $path_filestat_get + (tuple.extract 3 0 (local.get $p)) + (i32.const 1) + (tuple.extract 3 1 (local.get $p)) + (tuple.extract 3 2 (local.get $p)) + (local.get $buffer))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (global.get $chdir) (local.get $name)))) + (local.set $kind (i32.load8_u offset=16 (local.get $buffer))) + (if (i32.ne (local.get $kind) (i32.const 3)) + (then + (call $caml_unix_error (i32.const 54) ;; ENOTDIR + (global.get $chdir) (local.get $name)))) + (call $wasi_chdir (local.get $name)) + (ref.i31 (i32.const 0))) +) +(@else (func (export "unix_getcwd") (export "caml_unix_getcwd") (param (ref eq)) (result (ref eq)) (try (result (ref eq)) @@ -460,7 +1031,31 @@ (catch $javascript_exception (call $caml_unix_error (pop externref) (ref.null eq)))) (ref.i31 (i32.const 0))) +)) +(@if wasi +(@then + (@string $mkdir "mkdir") + + (func (export "unix_mkdir") (export "caml_unix_mkdir") + (param $path (ref eq)) (param $perm (ref eq)) (result (ref eq)) + (local $p (tuple i32 i32 i32)) + (local $res i32) + (local.set $p + (call $unix_resolve_path (global.get $mkdir) (local.get $path))) + (local.set $res + (call $path_create_directory + (tuple.extract 3 0 (local.get $p)) + (tuple.extract 3 1 (local.get $p)) + (tuple.extract 3 2 (local.get $p)))) + (call $free (tuple.extract 3 1 (local.get $p))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (global.get $mkdir) (local.get $path)))) + (ref.i31 (i32.const 0))) +) +(@else (func (export "unix_mkdir") (export "caml_unix_mkdir") (param $name (ref eq)) (param $perm (ref eq)) (result (ref eq)) (try @@ -471,7 +1066,147 @@ (catch $javascript_exception (call $caml_unix_error (pop externref) (ref.null eq)))) (ref.i31 (i32.const 0))) +)) + +(@if wasi +(@then + (type $directory + (struct + (field $fd i32) + (field $buffer (mut i32)) + (field $size (mut i32)) + (field $pos (mut i32)) + (field $available (mut i32)) + (field $cookie (mut i64)))) + + (@string $opendir "opendir") + (func $unix_opendir (export "unix_opendir") (export "caml_unix_opendir") + (param $name (ref eq)) (result (ref eq)) + (local $p (tuple i32 i32 i32)) + (local $buffer i32) (local $res i32) + (local.set $p + (call $unix_resolve_path (global.get $opendir) (local.get $name))) + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $path_open + (tuple.extract 3 0 (local.get $p)) + (i32.const 1) ;; symlink_follow + (tuple.extract 3 1 (local.get $p)) + (tuple.extract 3 2 (local.get $p)) + (i32.const 2) ;; O_DIRECTORY + (i64.const 0x4000) ;; allow fd_readdir + (i64.const 0) + (i32.const 0) + (local.get $buffer))) + (call $free (tuple.extract 3 1 (local.get $p))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (global.get $opendir) (local.get $name)))) + (struct.new $directory + (i32.load (local.get $buffer)) + (call $checked_malloc (i32.const 512)) + (i32.const 512) + (i32.const 0) + (i32.const 0) + (i64.const 0))) + + (func $readdir_helper + (param $vdir (ref eq)) (result (ref eq)) + (local $dir (ref $directory)) (local $buf i32) (local $res i32) + (local $buffer i32) (local $available i32) (local $left i32) + (local $namelen i32) (local $entry i32) (local $entry_size i32) + (local.set $dir (ref.cast (ref $directory) (local.get $vdir))) + (loop $loop + (block $refill + (local.set $left + (i32.sub (struct.get $directory $available (local.get $dir)) + (struct.get $directory $pos (local.get $dir)))) + (br_if $refill (i32.lt_u (local.get $left) (i32.const 24))) + (local.set $entry + (i32.add (struct.get $directory $buffer (local.get $dir)) + (struct.get $directory $pos (local.get $dir)))) + (local.set $namelen (i32.load offset=16 (local.get $entry))) + (local.set $entry_size (i32.add (local.get $namelen) (i32.const 24))) + (br_if $refill (i32.lt_u (local.get $left) (local.get $entry_size))) + (struct.set $directory $pos (local.get $dir) + (i32.add (struct.get $directory $pos (local.get $dir)) + (local.get $entry_size))) + (struct.set $directory $cookie (local.get $dir) + (i64.load (local.get $entry))) + (return_call $blit_memory_to_string + (i32.add (local.get $entry) (i32.const 24)) + (local.get $namelen))) + ;; refill + (if (i32.lt_u (struct.get $directory $size (local.get $dir)) + (local.get $entry_size)) + (then + ;; the entry does not fit + (local.set $buf (call $checked_malloc (local.get $entry_size))) + (call $free (struct.get $directory $buffer (local.get $dir))) + (struct.set $directory $buffer (local.get $dir) (local.get $buf)) + (struct.set $directory $size (local.get $dir) + (local.get $entry_size)))) + (block $done + (br_if $done + (i32.and + (i32.ne (i32.const 0) + (struct.get $directory $available (local.get $dir)) + (i32.lt_u (struct.get $directory $available (local.get $dir)) + (struct.get $directory $size (local.get $dir)))))) + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $fd_readddir + (struct.get $directory $fd (local.get $dir)) + (struct.get $directory $buffer (local.get $dir)) + (struct.get $directory $size (local.get $dir)) + (struct.get $directory $cookie (local.get $dir)) + (local.get $buffer))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (@string "readdir") (global.get $no_arg)))) + (local.set $available (i32.load (local.get $buffer))) + (br_if $done (i32.eqz (local.get $available))) + (struct.set $directory $pos (local.get $dir) (i32.const 0)) + (struct.set $directory $available (local.get $dir) + (local.get $available)) + (br $loop))) + ;; done + (call $caml_raise_end_of_file) + (ref.i31 (i32.const 0))) + + (func $unix_closedir (export "unix_closedir") (export "caml_unix_closedir") + (param $vdir (ref eq)) (result (ref eq)) + (local $dir (ref $directory)) (local $buf i32) (local $res i32) + (local.set $dir (ref.cast (ref $directory) (local.get $vdir))) + (local.set $buf (struct.get $directory $buffer (local.get $dir))) + (block $error + (if (i32.eqz (local.get $buf)) + (then + (local.set $res (i32.const 8)) ;; EBADF + (br $error))) + (call $free (local.get $buf)) + (struct.set $directory $buffer (local.get $dir) (i32.const 0)) + (local.set $res + (call $fd_close (struct.get $directory $fd (local.get $dir)))) + (br_if $error (local.get $res)) + (return (ref.i31 (i32.const 0)))) + (call $caml_unix_error + (local.get $res) (@string "closedir") (global.get $no_arg)) + (ref.i31 (i32.const 0))) + + (func (export "unix_rewinddir") (export "caml_unix_rewinddir") + (param $vdir (ref eq)) (result (ref eq)) + (local $dir (ref $directory)) + (local.set $dir (ref.cast (ref $directory) (local.get $vdir))) + (struct.set $directory $cookie (local.get $dir) (i64.const 0)) + (struct.set $directory $pos (local.get $dir) (i32.const 0)) + (struct.set $directory $available (local.get $dir) (i32.const 0)) + (ref.i31 (i32.const 0))) +) +(@else (func $unix_opendir (export "unix_opendir") (export "caml_unix_opendir") (param $name (ref eq)) (result (ref eq)) (try (result (ref eq)) @@ -493,8 +1228,6 @@ (local.get $cmd) (global.get $no_arg)))) - (data $readdir "readdir") - (func $readdir_helper (param $dir (ref eq)) (result (ref eq)) (block $end (return @@ -506,15 +1239,11 @@ (call $readdir (call $unwrap (local.get $dir))))))) (catch $javascript_exception (drop (pop externref)) - (call $throw_ebadf - (array.new_data $bytes $readdir - (i32.const 0) (i32.const 7))) + (call $throw_ebadf (@string "readdir")) (ref.i31 (i32.const 0)))))) (call $caml_raise_end_of_file) (ref.i31 (i32.const 0))) - (data $closedir "closedir") - (func $unix_closedir (export "unix_closedir") (export "caml_unix_closedir") (export "win_findclose") (export "caml_unix_findclose") (param $dir (ref eq)) (result (ref eq)) @@ -523,10 +1252,16 @@ (call $closedir (call $unwrap (local.get $dir)))) (catch $javascript_exception (drop (pop externref)) - (call $throw_ebadf - (array.new_data $bytes $closedir (i32.const 0) (i32.const 8))))) + (call $throw_ebadf (@string "closedir")))) (ref.i31 (i32.const 0))) + (func (export "unix_rewinddir") (export "caml_unix_rewinddir") + (param (ref eq)) (result (ref eq)) + (call $caml_invalid_argument + (@string "rewinddir not implemented")) + (ref.i31 (i32.const 0))) +)) + (func (export "unix_readdir") (export "caml_unix_readdir") (param $dir (ref eq)) (result (ref eq)) (block $return (result (ref eq)) @@ -558,15 +1293,29 @@ (call $win_find_next (local.get $dir)) (local.get $dir))) - (data $rewinddir_not_implemented "rewinddir not implemented") +(@if wasi +(@then + (@string $unlink "unlink") - (func (export "unix_rewinddir") (export "caml_unix_rewinddir") - (param (ref eq)) (result (ref eq)) - (call $caml_invalid_argument - (array.new_data $bytes $rewinddir_not_implemented - (i32.const 0) (i32.const 25))) + (func (export "unix_unlink") (export "caml_unix_unlink") + (param $path (ref eq)) (result (ref eq)) + (local $p (tuple i32 i32 i32)) + (local $res i32) + (local.set $p + (call $unix_resolve_path (global.get $unlink) (local.get $path))) + (local.set $res + (call $path_unlink_file + (tuple.extract 3 0 (local.get $p)) + (tuple.extract 3 1 (local.get $p)) + (tuple.extract 3 2 (local.get $p)))) + (call $free (tuple.extract 3 1 (local.get $p))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (global.get $unlink) (local.get $path)))) (ref.i31 (i32.const 0))) - +) +(@else (func (export "unix_unlink") (export "caml_unix_unlink") (param $p (ref eq)) (result (ref eq)) (try @@ -576,7 +1325,31 @@ (catch $javascript_exception (call $caml_unix_error (pop externref) (ref.null eq)))) (ref.i31 (i32.const 0))) +)) + +(@if wasi +(@then + (@string $rmdir "rmdir") + (func (export "unix_rmdir") (export "caml_unix_rmdir") + (param $path (ref eq)) (result (ref eq)) + (local $p (tuple i32 i32 i32)) + (local $res i32) + (local.set $p + (call $unix_resolve_path (global.get $rmdir) (local.get $path))) + (local.set $res + (call $path_remove_directory + (tuple.extract 3 0 (local.get $p)) + (tuple.extract 3 1 (local.get $p)) + (tuple.extract 3 2 (local.get $p)))) + (call $free (tuple.extract 3 1 (local.get $p))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (global.get $rmdir) (local.get $path)))) + (ref.i31 (i32.const 0))) +) +(@else (func (export "unix_rmdir") (export "caml_unix_rmdir") (param $p (ref eq)) (result (ref eq)) (try @@ -586,7 +1359,47 @@ (catch $javascript_exception (call $caml_unix_error (pop externref) (ref.null eq)))) (ref.i31 (i32.const 0))) +)) +(@if wasi +(@then + (@string $link "link") + + (func (export "unix_link") (export "caml_unix_link") + (param $follow (ref eq)) (param $o (ref eq)) (param $n (ref eq)) + (result (ref eq)) + (local $op (tuple i32 i32 i32)) + (local $np (tuple i32 i32 i32)) + (local $flags i32) + (local $res i32) + (local.set $op (call $unix_resolve_path (global.get $link) (local.get $o))) + (local.set $np (call $unix_resolve_path (global.get $link) (local.get $n))) + (if (ref.test (ref $block) (local.get $follow)) + (then + (local.set $flags + (i31.get_u + (ref.cast (ref i31) + (array.get $block + (ref.cast (ref $block) (local.get $follow)) + (i32.const 1))))))) + (local.set $res + (call $path_link + (tuple.extract 3 0 (local.get $op)) + (local.get $flags) + (tuple.extract 3 1 (local.get $op)) + (tuple.extract 3 2 (local.get $op)) + (tuple.extract 3 0 (local.get $np)) + (tuple.extract 3 1 (local.get $np)) + (tuple.extract 3 2 (local.get $np)))) + (call $free (tuple.extract 3 1 (local.get $op))) + (call $free (tuple.extract 3 1 (local.get $np))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (global.get $link) (local.get $o)))) + (ref.i31 (i32.const 0))) +) +(@else (data $link "link") (func (export "unix_link") (export "caml_unix_link") @@ -609,11 +1422,48 @@ (catch $javascript_exception (call $caml_unix_error (pop externref) (ref.null eq)))) (ref.i31 (i32.const 0))) +)) (func (export "unix_has_symlink") (export "caml_unix_has_symlink") (param (ref eq)) (result (ref eq)) (ref.i31 (i32.const 1))) +(@if wasi +(@then + (@string $symlink "symlink") + + (func (export "unix_symlink") (export "caml_unix_symlink") + (param $to_dir (ref eq)) (param $o (ref eq)) (param $n (ref eq)) + (result (ref eq)) + (local $path (ref $bytes)) + (local $len i32) + (local $op i32) + (local $np (tuple i32 i32 i32)) + (local $flags i32) + (local $res i32) + (local.set $path (ref.cast (ref $bytes) (local.get $o))) + (local.set $len (array.len (local.get $path))) + (local.set $op + (call $write_string_to_memory + (i32.const 0) (i32.const 0) (local.get $path))) + (local.set $np + (call $unix_resolve_path (global.get $symlink) (local.get $n))) + (local.set $res + (call $path_symlink + (local.get $op) + (local.get $len) + (tuple.extract 3 0 (local.get $np)) + (tuple.extract 3 1 (local.get $np)) + (tuple.extract 3 2 (local.get $np)))) + (call $free (local.get $op)) + (call $free (tuple.extract 3 1 (local.get $np))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (global.get $symlink) (local.get $o)))) + (ref.i31 (i32.const 0))) +) +(@else (func (export "unix_symlink") (export "caml_unix_symlink") (param $to_dir (ref eq)) (param $t (ref eq)) (param $p (ref eq)) (result (ref eq)) @@ -636,7 +1486,37 @@ (catch $javascript_exception (call $caml_unix_error (pop externref) (ref.null eq)))) (ref.i31 (i32.const 0))) +)) + +(@if wasi +(@then + (@string $readlink "readlink") + (func (export "unix_readlink") (export "caml_unix_readlink") + (param $path (ref eq)) (result (ref eq)) + (local $p (tuple i32 i32 i32)) + (local $buffer i32) (local $buf i32) (local $res i32) + (local.set $p + (call $unix_resolve_path (global.get $readlink) (local.get $path))) + (local.set $buffer (call $get_buffer)) + (local.set $buf (i32.add (local.get $buffer) (i32.const 4))) + (local.set $res + (call $path_readlink + (tuple.extract 3 0 (local.get $p)) + (tuple.extract 3 1 (local.get $p)) + (tuple.extract 3 2 (local.get $p)) + (local.get $buf) + (global.get $IO_BUFFER_SIZE) + (local.get $buffer))) + (call $free (tuple.extract 3 1 (local.get $p))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (global.get $readlink) (local.get $path)))) + (return_call $blit_memory_to_string + (local.get $buf) (i32.load (local.get $buffer)))) +) +(@else (func (export "unix_readlink") (export "caml_unix_readlink") (param $path (ref eq)) (result (ref eq)) (try @@ -649,7 +1529,60 @@ (catch $javascript_exception (call $caml_unix_error (pop externref) (ref.null eq)))) (ref.i31 (i32.const 0))) +)) + +(@if wasi +(@then + (@string $truncate "truncate") + + (func $truncate (param $path (ref eq)) (param $len i64) (result (ref eq)) + (local $p (tuple i32 i32 i32)) + (local $fd i32) (local $res i32) (local $buffer i32) + (block $error + (local.set $p + (call $unix_resolve_path (global.get $truncate) (local.get $path))) + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $path_open + (tuple.extract 3 0 (local.get $p)) + (i32.const 1) ;; symlink_follow + (tuple.extract 3 1 (local.get $p)) + (tuple.extract 3 2 (local.get $p)) + (i32.const 0) + (i64.const 0x400000) ;; allow fd_filestat_set_size + (i64.const 0) + (i32.const 0) + (local.get $buffer))) + (call $free (tuple.extract 3 1 (local.get $p))) + (br_if $error (local.get $res)) + (local.set $fd (i32.load (local.get $buffer))) + (local.set $res + (call $fd_filestat_set_size (local.get $fd) (local.get $len))) + (if (local.get $res) + (then + (drop (call $fd_close (local.get $fd))) + (br $error))) + (local.set $res (call $fd_close (local.get $fd))) + (br_if $error (local.get $res)) + (return (ref.i31 (i32.const 0)))) + (call $caml_unix_error + (local.get $res) (global.get $truncate) (local.get $path)) + (return (ref.i31 (i32.const 0)))) + + (func (export "unix_truncate") (export "caml_unix_truncate") + (param $path (ref eq)) (param $len (ref eq)) + (result (ref eq)) + (return_call $truncate (local.get $path) + (i64.extend_i32_s + (i31.get_s (ref.cast (ref i31) (local.get $len)))))) + (func (export "unix_truncate_64") (export "caml_unix_truncate_64") + (param $path (ref eq)) (param $len (ref eq)) + (result (ref eq)) + (return_call $truncate (local.get $path) + (call $Int64_val (local.get $len)))) +) +(@else (func (export "unix_truncate") (export "caml_unix_truncate") (param $path (ref eq)) (param $len (ref eq)) (result (ref eq)) @@ -675,7 +1608,33 @@ (catch $javascript_exception (call $caml_unix_error (pop externref) (ref.null eq)))) (ref.i31 (i32.const 0))) +)) + +(@if wasi +(@then + (func $ftruncate (param $vfd (ref eq)) (param $len i64) (result (ref eq)) + (local $fd i32) (local $res i32) + (local.set $fd (i31.get_u (ref.cast (ref i31) (local.get $vfd)))) + (local.set $res + (call $fd_filestat_set_size (local.get $fd) (local.get $len))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (@string "ftruncate") (global.get $no_arg)))) + (ref.i31 (i32.const 0))) + (func (export "unix_ftruncate") (export "caml_unix_ftruncate") + (param $fd (ref eq)) (param $len (ref eq)) (result (ref eq)) + (return_call $ftruncate (local.get $fd) + (i64.extend_i32_s + (i31.get_s (ref.cast (ref i31) (local.get $len)))))) + + (func (export "unix_ftruncate_64") (export "caml_unix_ftruncate_64") + (param $fd (ref eq)) (param $len (ref eq)) (result (ref eq)) + (return_call $ftruncate (local.get $fd) + (call $Int64_val (local.get $len)))) +) +(@else (func (export "unix_ftruncate") (export "caml_unix_ftruncate") (param $fd (ref eq)) (param $vlen (ref eq)) (result (ref eq)) @@ -724,7 +1683,35 @@ (struct.set $fd_offset $offset (local.get $fd_offset) (local.get $len)))) (ref.i31 (i32.const 0))) +)) +(@if wasi +(@then + (@string $access "access") + + ;; We can only check that the file exists + (func (export "unix_access") (export "caml_unix_access") + (param $path (ref eq)) (param $flags (ref eq)) (result (ref eq)) + (local $p (tuple i32 i32 i32)) + (local $res i32) (local $buffer i32) + (local.set $p + (call $unix_resolve_path (global.get $access) (local.get $path))) + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $path_filestat_get + (tuple.extract 3 0 (local.get $p)) + (i32.const 1) + (tuple.extract 3 1 (local.get $p)) + (tuple.extract 3 2 (local.get $p)) + (local.get $buffer))) + (call $free (tuple.extract 3 1 (local.get $p))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (global.get $access) (local.get $path)))) + (return (ref.i31 (i32.const 0)))) +) +(@else (global $access_flags (ref $flags) (array.new_fixed $flags 4 (i32.const 1) (i32.const 2) (i32.const 4) (i32.const 8))) @@ -743,8 +1730,69 @@ (catch $javascript_exception (call $caml_unix_error (pop externref) (ref.null eq)))) (ref.i31 (i32.const 0))) +)) + + (type $flags (array i16)) + +(@if wasi +(@then + ;; 0x1 O_RDONLY + ;; 0x2 O_WRONLY + ;; 0x3 O_RDWR + ;; 0x400 O_NONBLOCK + ;; 0x100 O_APPEND + ;; 0x10 O_CREAT + ;; 0x80 O_TRUNC + ;; 0x40 O_EXCL + ;; 0 O_NOCTTY + ;; 0x200 O_DSYNC + ;; 0x1000 O_SYNC + ;; 0x800 O_RSYNC + (global $unix_open_flags (ref $flags) + (array.new_fixed $flags 15 + (i32.const 1) (i32.const 2) (i32.const 3) (i32.const 0x400) + (i32.const 0x100) (i32.const 0x10) (i32.const 0x80) (i32.const 0x40) + (i32.const 0) (i32.const 0x200) (i32.const 0x1000) (i32.const 0x800) + (i32.const 0) (i32.const 0) (i32.const 0))) + + (@string $open "open") - (type $flags (array i8)) + (func (export "unix_open") (export "caml_unix_open") + (param $vpath (ref eq)) (param $vflags (ref eq)) (param $perm (ref eq)) + (result (ref eq)) + (local $flags i32) (local $offset i64) + (local $path (tuple i32 i32 i32)) + (local $res i32) (local $buffer i32) + (local.set $path + (call $unix_resolve_path (global.get $open) (local.get $vpath))) + (local.set $buffer (call $get_buffer)) + (local.set $flags + (call $convert_flag_list + (global.get $unix_open_flags) (local.get $vflags))) + (local.set $res + (call $path_open + (tuple.extract 3 0 (local.get $path)) + (i32.const 1) ;; symlink_follow + (tuple.extract 3 1 (local.get $path)) + (tuple.extract 3 2 (local.get $path)) + (i32.and (i32.shr_u (local.get $flags) (i32.const 4)) + (i32.const 0xF)) + (select + (i64.const 0x860007e) + (select (i64.const 0x860007c) (i64.const 0x820003e) + (i32.and (local.get $flags) (i32.const 2))) + (i32.eq (i32.and (local.get $flags) (i32.const 3)) (i32.const 3))) + (i64.const 0) + (i32.shr_u (local.get $flags) (i32.const 8)) + (local.get $buffer))) + (call $free (tuple.extract 3 1 (local.get $path))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (global.get $open) (local.get $vpath)))) + (ref.i31 (i32.load (local.get $buffer)))) +) +(@else ;; 1 O_RDONLY ;; 2 O_WRONLY ;; 4 O_RDWR @@ -784,6 +1832,7 @@ (call $caml_unix_error (pop externref) (ref.null eq)))) (call $initialize_fd_offset (local.get $fd) (local.get $offset)) (ref.i31 (local.get $fd))) +)) (global $io_buffer (mut externref) (ref.null extern)) @@ -799,6 +1848,217 @@ (br_on_null $null (call $get_fd_offset_unchecked (local.get $fd))))) (struct.new $fd_offset (i64.const 0) (i32.const 0))) +(@if wasi +(@then + (func (export "unix_write") (export "caml_unix_write") + (param $vfd (ref eq)) (param $vbuf (ref eq)) (param $vpos (ref eq)) + (param $vlen (ref eq)) (result (ref eq)) + (local $buffer i32) (local $res i32) + (local $iovs i32) (local $iovs_len i32) (local $nwritten i32) + (local $fd i32) (local $s (ref $bytes)) + (local $pos i32) (local $len i32) (local $numbytes i32) + (local $written i32) (local $n i32) + (local.set $fd (i31.get_u (ref.cast (ref i31) (local.get $vfd)))) + (local.set $s (ref.cast (ref $bytes) (local.get $vbuf))) + (local.set $pos (i31.get_u (ref.cast (ref i31) (local.get $vpos)))) + (local.set $len (i31.get_u (ref.cast (ref i31) (local.get $vlen)))) + (local.set $buffer (call $get_buffer)) + (local.set $nwritten (local.get $buffer)) + (local.set $iovs (i32.add (local.get $buffer) (i32.const 4))) + (local.set $buffer (i32.add (local.get $buffer) (i32.const 12))) + (i32.store (local.get $iovs) (local.get $buffer)) + (local.set $iovs_len (i32.const 1)) + (loop $loop + (if (i32.gt_u (local.get $len) (i32.const 0)) + (then + (local.set $numbytes + (select (global.get $IO_BUFFER_SIZE) (local.get $len) + (i32.gt_u (local.get $len) (global.get $IO_BUFFER_SIZE)))) + (call $blit_substring_to_memory + (local.get $buffer) (local.get $s) (local.get $pos) + (local.get $numbytes)) + (i32.store offset=4 (local.get $iovs) (local.get $numbytes)) + (local.set $res + (call $fd_write + (local.get $fd) (local.get $iovs) (local.get $iovs_len) + (local.get $nwritten))) + (if (local.get $res) + (then + (call $caml_unix_error (local.get $res) (@string "write") + (global.get $no_arg)))) + (local.set $n (i32.load (local.get $nwritten))) + (local.set $written (i32.add (local.get $written) (local.get $n))) + (local.set $pos (i32.add (local.get $pos) (local.get $n))) + (local.set $len (i32.sub (local.get $len) (local.get $n))) + (br $loop)))) + (ref.i31 (local.get $n))) + + (func (export "unix_single_write") (export "caml_unix_single_write") + (param $vfd (ref eq)) (param $vbuf (ref eq)) (param $vpos (ref eq)) + (param $vlen (ref eq)) (result (ref eq)) + (local $buffer i32) (local $res i32) + (local $iovs i32) (local $iovs_len i32) (local $nwritten i32) + (local $fd i32) (local $s (ref $bytes)) + (local $pos i32) (local $len i32) (local $numbytes i32) + (local $written i32) (local $n i32) + (local.set $fd (i31.get_u (ref.cast (ref i31) (local.get $vfd)))) + (local.set $s (ref.cast (ref $bytes) (local.get $vbuf))) + (local.set $pos (i31.get_u (ref.cast (ref i31) (local.get $vpos)))) + (local.set $len (i31.get_u (ref.cast (ref i31) (local.get $vlen)))) + (if (i32.eqz (local.get $len)) + (then (return (ref.i31 (i32.const 0))))) + (local.set $buffer (call $get_buffer)) + (local.set $nwritten (local.get $buffer)) + (local.set $iovs (i32.add (local.get $buffer) (i32.const 4))) + (local.set $buffer (i32.add (local.get $buffer) (i32.const 12))) + (i32.store (local.get $iovs) (local.get $buffer)) + (local.set $iovs_len (i32.const 1)) + (local.set $numbytes + (select (global.get $IO_BUFFER_SIZE) (local.get $len) + (i32.gt_u (local.get $len) (global.get $IO_BUFFER_SIZE)))) + (call $blit_substring_to_memory + (local.get $buffer) (local.get $s) (local.get $pos) + (local.get $numbytes)) + (i32.store offset=4 (local.get $iovs) (local.get $numbytes)) + (local.set $res + (call $fd_write + (local.get $fd) (local.get $iovs) (local.get $iovs_len) + (local.get $nwritten))) + (if (local.get $res) + (then + (call $caml_unix_error (local.get $res) (@string "write") + (global.get $no_arg)))) + (ref.i31 (i32.load (local.get $nwritten)))) + + (func (export "unix_read") (export "caml_unix_read") + (param $vfd (ref eq)) (param $vbuf (ref eq)) (param $vpos (ref eq)) + (param $vlen (ref eq)) (result (ref eq)) + (local $buffer i32) (local $res i32) + (local $iovs i32) (local $iovs_len i32) (local $nread i32) + (local $fd i32) (local $pos i32) (local $len i32) (local $n i32) + (local.set $fd (i31.get_u (ref.cast (ref i31) (local.get $vfd)))) + (local.set $pos (i31.get_u (ref.cast (ref i31) (local.get $vpos)))) + (local.set $len (i31.get_u (ref.cast (ref i31) (local.get $vlen)))) + (if (i32.gt_u (local.get $len) (global.get $IO_BUFFER_SIZE)) + (then + (local.set $len (global.get $IO_BUFFER_SIZE)))) + (local.set $buffer (call $get_buffer)) + (local.set $nread (local.get $buffer)) + (local.set $iovs (i32.add (local.get $buffer) (i32.const 4))) + (local.set $buffer (i32.add (local.get $buffer) (i32.const 12))) + (i32.store (local.get $iovs) (local.get $buffer)) + (i32.store offset=4 (local.get $iovs) (local.get $len)) + (local.set $iovs_len (i32.const 1)) + (local.set $res + (call $fd_read + (local.get $fd) (local.get $iovs) (local.get $iovs_len) + (local.get $nread))) + (if (local.get $res) + (then + (call $caml_unix_error (local.get $res) (@string "read") + (global.get $no_arg)))) + (local.set $n (i32.load (local.get $nread))) + (call $blit_memory_to_substring (local.get $buffer) + (ref.cast (ref $bytes) (local.get $vbuf)) + (local.get $pos) (local.get $n)) + (ref.i31 (local.get $n))) + + (type $data + (struct + (field $array (ref array)) + (field $offset i32) + (field $len i32))) + + (func (export "unix_write_bigarray") (export "caml_unix_write_bigarray") + (param $vfd (ref eq)) (param $vbuf (ref eq)) (param $vpos (ref eq)) + (param $vlen (ref eq)) (param $vsingle (ref eq)) (result (ref eq)) + (local $fd i32) (local $data (ref $data)) (local $buf (ref $bytes)) + (local $pos i32) (local $len i32) (local $n i32) (local $written i32) + (local $buffer i32) (local $nwritten i32) (local $iovs i32) + (local $iovs_len i32) (local $numbytes i32) (local $res i32) + (local.set $fd (i31.get_u (ref.cast (ref i31) (local.get $vfd)))) + (local.set $data + (ref.cast (ref $data) + (any.convert_extern (call $caml_ba_get_data (local.get $vbuf))))) + (local.set $buf + (ref.cast (ref $bytes) (struct.get $data $array (local.get $data)))) + (local.set $pos + (i32.add (i31.get_u (ref.cast (ref i31) (local.get $vpos))) + (struct.get $data $offset (local.get $data)))) + (local.set $len (i31.get_u (ref.cast (ref i31) (local.get $vlen)))) + (local.set $buffer (call $get_buffer)) + (local.set $nwritten (local.get $buffer)) + (local.set $iovs (i32.add (local.get $buffer) (i32.const 4))) + (local.set $buffer (i32.add (local.get $buffer) (i32.const 12))) + (i32.store (local.get $iovs) (local.get $buffer)) + (local.set $iovs_len (i32.const 1)) + (loop $loop + (if (i32.gt_u (local.get $len) (i32.const 0)) + (then + (local.set $numbytes + (select (global.get $IO_BUFFER_SIZE) (local.get $len) + (i32.gt_u (local.get $len) (global.get $IO_BUFFER_SIZE)))) + (call $blit_substring_to_memory + (local.get $buffer) (local.get $buf) (local.get $pos) + (local.get $numbytes)) + (i32.store offset=4 (local.get $iovs) (local.get $numbytes)) + (local.set $res + (call $fd_write + (local.get $fd) (local.get $iovs) (local.get $iovs_len) + (local.get $nwritten))) + (if (local.get $res) + (then + (call $caml_unix_error (local.get $res) (@string "write") + (global.get $no_arg)))) + (local.set $n (i32.load (local.get $nwritten))) + (local.set $written (i32.add (local.get $written) (local.get $n))) + (local.set $pos (i32.add (local.get $pos) (local.get $n))) + (local.set $len (i32.sub (local.get $len) (local.get $n))) + (br_if $loop + (ref.eq (local.get $vsingle) (ref.i31 (i32.const 0))))))) + (ref.i31 (local.get $written))) + + (func (export "unix_read_bigarray") (export "caml_unix_read_bigarray") + (param $vfd (ref eq)) (param $vbuf (ref eq)) (param $vpos (ref eq)) + (param $vlen (ref eq)) (result (ref eq)) + (local $fd i32) (local $data (ref $data)) (local $buf (ref $bytes)) + (local $pos i32) (local $len i32) (local $n i32) + (local $buffer i32) (local $nread i32) (local $iovs i32) + (local $iovs_len i32) (local $res i32) + (local.set $fd (i31.get_u (ref.cast (ref i31) (local.get $vfd)))) + (local.set $data + (ref.cast (ref $data) + (any.convert_extern (call $caml_ba_get_data (local.get $vbuf))))) + (local.set $buf + (ref.cast (ref $bytes) (struct.get $data $array (local.get $data)))) + (local.set $pos + (i32.add (i31.get_u (ref.cast (ref i31) (local.get $vpos))) + (struct.get $data $offset (local.get $data)))) + (local.set $len (i31.get_u (ref.cast (ref i31) (local.get $vlen)))) + (if (i32.gt_u (local.get $len) (global.get $IO_BUFFER_SIZE)) + (then + (local.set $len (global.get $IO_BUFFER_SIZE)))) + (local.set $buffer (call $get_buffer)) + (local.set $nread (local.get $buffer)) + (local.set $iovs (i32.add (local.get $buffer) (i32.const 4))) + (local.set $buffer (i32.add (local.get $buffer) (i32.const 12))) + (i32.store (local.get $iovs) (local.get $buffer)) + (i32.store offset=4 (local.get $iovs) (local.get $len)) + (local.set $iovs_len (i32.const 1)) + (local.set $res + (call $fd_read + (local.get $fd) (local.get $iovs) (local.get $iovs_len) + (local.get $nread))) + (if (local.get $res) + (then + (call $caml_unix_error (local.get $res) (@string "read") + (global.get $no_arg)))) + (local.set $n (i32.load (local.get $nread))) + (call $blit_memory_to_substring (local.get $buffer) + (local.get $buf) (local.get $pos) (local.get $n)) + (ref.i31 (local.get $n))) +) +(@else (func (export "unix_write") (export "caml_unix_write") (param $vfd (ref eq)) (param $vbuf (ref eq)) (param $vpos (ref eq)) (param $vlen (ref eq)) (result (ref eq)) @@ -998,7 +2258,28 @@ (struct.set $fd_offset $offset (local.get $fd_offset) (i64.add (local.get $offset) (i64.extend_i32_s (local.get $n)))) (ref.i31 (local.get $n))) +)) +(@if wasi +(@then + (func $lseek + (param $fd (ref eq)) (param $offset i64) (param $cmd (ref eq)) + (result i64) + (local $res i32) (local $buffer i32) + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $fd_seek + (i31.get_u (ref.cast (ref i31) (local.get $fd))) + (local.get $offset) + (i31.get_u (ref.cast (ref i31) (local.get $cmd))) + (local.get $buffer))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (@string "lseek") (global.get $no_arg)))) + (i64.load (local.get $buffer))) +) +(@else (@string $lseek "lseek") (func $lseek_exn (param $errno i32) (result (ref eq)) @@ -1036,6 +2317,7 @@ (struct.set $fd_offset $offset (local.get $fd_offset) (local.get $offset)) (struct.set $fd_offset $seeked (local.get $fd_offset) (i32.const 1)) (local.get $offset)) +)) (func (export "unix_lseek") (export "caml_unix_lseek") (param $fd (ref eq)) (param $ofs (ref eq)) (param $cmd (ref eq)) @@ -1057,6 +2339,20 @@ (call $Int64_val (local.get $ofs)) (local.get $cmd)))) +(@if wasi +(@then + (func (export "unix_fsync") (export "caml_unix_fsync") + (param $fd (ref eq)) (result (ref eq)) + (local $res i32) + (local.set $res + (call $fd_sync (i31.get_u (ref.cast (ref i31) (local.get $fd))))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (@string "fsync") (global.get $no_arg)))) + (ref.i31 (i32.const 0))) +) +(@else (func (export "unix_fsync") (export "caml_unix_fsync") (param $fd (ref eq)) (result (ref eq)) (try @@ -1065,6 +2361,7 @@ (catch $javascript_exception (call $caml_unix_error (pop externref) (ref.null eq)))) (ref.i31 (i32.const 0))) +)) (@string $out_channel_of_descr "out_channel_of_descr") (@string $in_channel_of_descr "in_channel_of_descr") @@ -1075,6 +2372,32 @@ (global.get $in_channel_of_descr) (local.get $out))) +(@if wasi +(@then + (func $caml_unix_check_stream_semantics (param $fd (ref eq)) (param $out i32) + (local $s (ref $block)) (local $kind i32) + (local $buffer i32) (local $res i32) (local $file_type i32) + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $fd_filestat_get + (i31.get_u (ref.cast (ref i31) (local.get $fd))) + (local.get $buffer))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) + (call $channel_of_descr_name (local.get $out)) + (global.get $no_arg)))) + (local.set $kind (i32.load8_u offset=16 (local.get $buffer))) + (block $ok + (block $bad + (br_table $bad $bad $ok $bad $ok $bad $ok $bad (local.get $kind))) + (call $caml_unix_error + (i32.const 28) (; EINVAL ;) + (call $channel_of_descr_name (local.get $out)) + (global.get $no_arg)))) +) +(@else (func $caml_unix_check_stream_semantics (param $fd (ref eq)) (param $out i32) (local $s (ref $block)) (local $kind i32) (local.set $s @@ -1100,6 +2423,7 @@ (ref.i31 (i32.const 12)) ;; EINVAL (call $channel_of_descr_name (local.get $out)) (global.get $no_arg))))) +)) (func (export "unix_inchannel_of_filedescr") (export "win_inchannel_of_filedescr") @@ -1115,6 +2439,20 @@ (call $caml_unix_check_stream_semantics (local.get $fd) (i32.const 1)) (return_call $caml_ml_open_descriptor_out (local.get $fd))) +(@if wasi +(@then + (func (export "unix_close") (export "caml_unix_close") + (param $fd (ref eq)) (result (ref eq)) + (local $res i32) + (local.set $res + (call $fd_close (i31.get_u (ref.cast (ref i31) (local.get $fd))))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (@string "close") (global.get $no_arg)))) + (ref.i31 (i32.const 0))) +) +(@else (func (export "unix_close") (export "caml_unix_close") (param $fd (ref eq)) (result (ref eq)) (call $release_fd_offset (i31.get_u (ref.cast (ref i31) (local.get $fd)))) @@ -1124,9 +2462,18 @@ (catch $javascript_exception (call $caml_unix_error (pop externref) (ref.null eq)))) (ref.i31 (i32.const 0))) +)) +(@if wasi +(@then + (func (export "unix_isatty") (export "caml_unix_isatty") + (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) +) +(@else (export "unix_isatty" (func $isatty)) (export "caml_unix_isatty" (func $isatty)) +)) (func (export "unix_getuid") (export "caml_unix_getuid") (export "unix_geteuid") (export "caml_unix_geteuid") diff --git a/runtime/wasm/wasi_errors.wat b/runtime/wasm/wasi_errors.wat new file mode 100644 index 0000000000..577fb410fa --- /dev/null +++ b/runtime/wasm/wasi_errors.wat @@ -0,0 +1,86 @@ +(module +(@if wasi +(@then + (type $block (array (mut (ref eq)))) + (type $bytes (array (mut i8))) + (global (export "error_messages") (ref $block) + (array.new_fixed $block 77 + (@string "Success") + (@string "Argument list too long") + (@string "Permission denied") + (@string "Address in use") + (@string "Address not available") + (@string "Address family not supported") + (@string "Resource unavailable, or operation would block") + (@string "Connection already in progress") + (@string "Bad file descriptor") + (@string "Bad message") + (@string "Device or resource busy") + (@string "Operation canceled") + (@string "No child processes") + (@string "Connection aborted") + (@string "Connection refused") + (@string "Connection reset") + (@string "Resource deadlock would occur") + (@string "Destination address required") + (@string "Mathematics argument out of domain of function") + (@string "Reserved") + (@string "File exists") + (@string "Bad address") + (@string "File too large") + (@string "Host is unreachable") + (@string "Identifier removed") + (@string "Illegal byte sequence") + (@string "Operation in progress") + (@string "Interrupted function") + (@string "Invalid argument") + (@string "I/O error") + (@string "Socket is connected") + (@string "Is a directory") + (@string "Too many levels of symbolic links") + (@string "File descriptor value too large") + (@string "Too many links") + (@string "Message too large") + (@string "Reserved") + (@string "Filename too long") + (@string "Network is down") + (@string "Connection aborted by network") + (@string "Network unreachable") + (@string "Too many files open in system") + (@string "No buffer space available") + (@string "No such device") + (@string "No such file or directory") + (@string "Executable file format error") + (@string "No locks available") + (@string "Reserved") + (@string "Not enough space") + (@string "No message of the desired type") + (@string "Protocol not available") + (@string "No space left on device") + (@string "Function not supported") + (@string "The socket is not connected") + (@string "Not a directory or a symbolic link to a directory") + (@string "Directory not empty") + (@string "State not recoverable") + (@string "Not a socket") + (@string "Not supported, or operation not supported on socket") + (@string "Inappropriate I/O control operation") + (@string "No such device or address") + (@string "Value too large to be stored in data type") + (@string "Previous owner died") + (@string "Operation not permitted") + (@string "Broken pipe") + (@string "Protocol error") + (@string "Protocol not supported") + (@string "Protocol wrong type for socket") + (@string "Result too large") + (@string "Read-only file system") + (@string "Invalid seek") + (@string "No such process") + (@string "Reserved") + (@string "Connection timed out") + (@string "Text file busy") + (@string "Cross-device link") + (@string "Capabilities insufficient"))) +)) +) diff --git a/runtime/wasm/wasi_memory.wat b/runtime/wasm/wasi_memory.wat new file mode 100644 index 0000000000..0e737a46db --- /dev/null +++ b/runtime/wasm/wasi_memory.wat @@ -0,0 +1,98 @@ +(module +(@if wasi +(@then + (import "libc" "memory" (memory 2)) + (import "libc" "malloc" (func $malloc (param i32) (result i32))) + (import "libc" "free" (func $free (param i32))) + (import "io" "IO_BUFFER_SIZE" (global $IO_BUFFER_SIZE i32)) + (import "fail" "caml_raise_out_of_memory" (func $caml_raise_out_of_memory)) + + (type $bytes (array (mut i8))) + + (func (export "checked_malloc") (param $size i32) (result i32) + (local $p i32) + (local.set $p (call $malloc (local.get $size))) + (if (i32.eqz (local.get $p)) + (then (call $caml_raise_out_of_memory))) + (local.get $p)) + + (func (export "blit_substring_to_memory") + (param $buf i32) (param $s (ref $bytes)) (param $ofs i32) (param $len i32) + (local $i i32) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (i32.store8 (i32.add (local.get $buf) (local.get $i)) + (array.get $bytes (local.get $s) + (i32.add (local.get $ofs) (local.get $i)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop))))) + + (func $blit_string_to_memory (export "blit_string_to_memory") + (param $buf i32) (param $s (ref $bytes)) + (local $i i32) (local $len i32) + (local.set $len (array.len (local.get $s))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (i32.store8 (i32.add (local.get $buf) (local.get $i)) + (array.get $bytes (local.get $s) (local.get $i))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop))))) + + (func (export "blit_memory_to_substring") + (param $buf i32) (param $s (ref $bytes)) (param $ofs i32) (param $len i32) + (local $i i32) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (array.set $bytes (local.get $s) + (i32.add (local.get $ofs) (local.get $i)) + (i32.load8_u (i32.add (local.get $buf) (local.get $i)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop))))) + + (func $blit_memory_to_string (export "blit_memory_to_string") + (param $buf i32) (param $len i32) (result (ref $bytes)) + (local $s (ref $bytes)) + (local $i i32) + (local.set $s (array.new $bytes (i32.const 0) (local.get $len))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (array.set $bytes (local.get $s) (local.get $i) + (i32.load8_u (i32.add (local.get $buf) (local.get $i)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (local.get $s)) + + (func (export "write_string_to_memory") + (param $buf i32) (param $avail i32) (param $v (ref eq)) + (result i32) + (local $s (ref $bytes)) (local $i i32) (local $len i32) + (local.set $s (ref.cast (ref $bytes) (local.get $v))) + (local.set $len (array.len (local.get $s))) + (if (i32.lt_u (local.get $avail) (i32.add (local.get $len) (i32.const 1))) + (then + (local.set $buf + (call $checked_malloc (i32.add (local.get $len) (i32.const 1)))))) + (call $blit_string_to_memory (local.get $buf) (local.get $s)) + (i32.store8 (i32.add (local.get $buf) (local.get $len)) (i32.const 0)) + (local.get $buf)) + + (func (export "release_memory") (param $initial_buffer i32) (param $buf i32) + (if (i32.ne (local.get $initial_buffer) (local.get $buf)) + (then + (call $free (local.get $buf))))) + + (global $buffer (mut i32) (i32.const 0)) + + (func $get_buffer (export "get_buffer") (result i32) + (if (i32.eqz (global.get $buffer)) + (then + (global.set $buffer + (call $checked_malloc + (i32.add (global.get $IO_BUFFER_SIZE) (i32.const 12)))))) + (global.get $buffer)) +)) +) diff --git a/runtime/wasm/weak.wat b/runtime/wasm/weak.wat index 1f704b8071..68d5328c04 100644 --- a/runtime/wasm/weak.wat +++ b/runtime/wasm/weak.wat @@ -21,6 +21,19 @@ (func $caml_obj_dup (param (ref eq)) (result (ref eq)))) (import "fail" "caml_invalid_argument" (func $caml_invalid_argument (param $arg (ref eq)))) + +(@if wasi +(@then + (func $wrap (param (ref eq)) (result (ref eq)) + (local.get 0)) + (func $unwrap (param (ref eq)) (result (ref eq)) + (local.get 0)) + (func $weak_new (param $v (ref eq)) (result (ref eq)) + (local.get $v)) + (func $weak_deref (param $r (ref eq)) (result (ref eq)) + (local.get $r)) +) +(@else (import "bindings" "weak_new" (func $weak_new (param (ref eq)) (result anyref))) (import "bindings" "weak_deref" @@ -32,6 +45,8 @@ (func $map_set (param (ref any)) (param (ref eq)) (param (ref any)))) (import "jslib" "unwrap" (func $unwrap (param (ref eq)) (result anyref))) (import "jslib" "wrap" (func $wrap (param anyref) (result (ref eq)))) +)) + (type $block (array (mut (ref eq)))) (type $bytes (array (mut i8))) (type $js (struct (field anyref))) @@ -62,6 +77,8 @@ (block $released (br_if $no_data (ref.eq (local.get $d) (global.get $caml_ephe_none))) +(@if (not wasi) +(@then (local.set $i (global.get $caml_ephe_key_offset)) (local.set $len (array.len (local.get $x))) (local.set $m (ref.as_non_null (call $unwrap (local.get $d)))) @@ -81,9 +98,11 @@ (br_on_null $released (call $map_get (local.get $m) (local.get $v)))) (br $loop)))) + (local.set $d (ref.cast (ref eq) (local.get $m))) +)) (return (array.new_fixed $block 2 (ref.i31 (i32.const 0)) - (ref.cast (ref eq) (local.get $m))))) + (local.get $d)))) (array.set $block (local.get $x) (global.get $caml_ephe_data_offset) (global.get $caml_ephe_none))) (ref.i31 (i32.const 0))) @@ -110,6 +129,8 @@ (local $m (ref any)) (local $m' (ref any)) (local $i i32) (local.set $x (ref.cast (ref $block) (local.get $vx))) +(@if (not wasi) +(@then (local.set $i (array.len (local.get $x))) (local.set $m (local.get $data)) (loop $loop @@ -133,8 +154,10 @@ (array.set $block (local.get $x) (local.get $i) (global.get $caml_ephe_none)) (br $loop)))) + (local.set $data (call $wrap (local.get $m))) +)) (array.set $block (local.get $x) (global.get $caml_ephe_data_offset) - (call $wrap (local.get $m))) + (local.get $data)) (ref.i31 (i32.const 0))) (func (export "caml_ephe_unset_data") From 29f552f1ed96f7bcd15c032e1368076f8e9b4066 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Fri, 14 Feb 2025 10:40:26 +0100 Subject: [PATCH 22/29] Add flag trap-on-exception To test with Wasm engines which do not support exceptions --- compiler/bin-wasm_of_ocaml/compile.ml | 4 +- compiler/bin-wasm_of_ocaml/gen/gen.ml | 2 +- compiler/lib-wasm/binaryen.ml | 7 +-- compiler/lib-wasm/wat_output.ml | 40 ++++++++++------- compiler/lib-wasm/wat_preprocess.ml | 63 +++++++++++++++++++++++++++ compiler/lib/config.ml | 2 + compiler/lib/config.mli | 2 + 7 files changed, 100 insertions(+), 20 deletions(-) diff --git a/compiler/bin-wasm_of_ocaml/compile.ml b/compiler/bin-wasm_of_ocaml/compile.ml index 09c7e66dc4..7611d011a0 100644 --- a/compiler/bin-wasm_of_ocaml/compile.ml +++ b/compiler/bin-wasm_of_ocaml/compile.ml @@ -90,7 +90,9 @@ let with_runtime_files ~runtime_wasm_files f = let build_runtime ~runtime_file = (* Keep this variables in sync with gen/gen.ml *) - let variables = [ "wasi", Config.Flag.wasi () ] in + let variables = + [ "wasi", Config.Flag.wasi (); "trap-on-exception", Config.Flag.trap_on_exception () ] + in match List.find_opt Runtime_files.precompiled_runtimes ~f:(fun (flags, _) -> assert ( diff --git a/compiler/bin-wasm_of_ocaml/gen/gen.ml b/compiler/bin-wasm_of_ocaml/gen/gen.ml index 9aa293250c..36f17fb970 100644 --- a/compiler/bin-wasm_of_ocaml/gen/gen.ml +++ b/compiler/bin-wasm_of_ocaml/gen/gen.ml @@ -3,7 +3,7 @@ let read_file ic = really_input_string ic (in_channel_length ic) (* Keep the two variables below in sync with function build_runtime in ../compile.ml *) -let default_flags = [] +let default_flags = [ "trap-on-exception", false ] let interesting_runtimes = [ [ "wasi", false ]; [ "wasi", true ] ] diff --git a/compiler/lib-wasm/binaryen.ml b/compiler/lib-wasm/binaryen.ml index 581c6d6939..878b54f908 100644 --- a/compiler/lib-wasm/binaryen.ml +++ b/compiler/lib-wasm/binaryen.ml @@ -112,9 +112,9 @@ let dead_code_elimination filter_unused_primitives primitives usage_file let optimization_options = - [| [ "-O2"; "--skip-pass=inlining-optimizing"; "--traps-never-happen" ] - ; [ "-O2"; "--skip-pass=inlining-optimizing"; "--traps-never-happen" ] - ; [ "-O3"; "--skip-pass=inlining-optimizing"; "--traps-never-happen" ] + [| [ "-O2"; "--skip-pass=inlining-optimizing" ] + ; [ "-O2"; "--skip-pass=inlining-optimizing" ] + ; [ "-O3"; "--skip-pass=inlining-optimizing" ] |] let optimize @@ -133,6 +133,7 @@ let optimize command ("wasm-opt" :: (common_options () + @ (if Config.Flag.trap_on_exception () then [] else [ "--traps-never-happen" ]) @ Option.value ~default:optimization_options.(level - 1) options @ [ Filename.quote input_file; "-o"; Filename.quote output_file ]) @ opt_flag "--input-source-map" opt_input_sourcemap diff --git a/compiler/lib-wasm/wat_output.ml b/compiler/lib-wasm/wat_output.ml index 27c2307801..c5fe887b26 100644 --- a/compiler/lib-wasm/wat_output.ml +++ b/compiler/lib-wasm/wat_output.ml @@ -444,19 +444,23 @@ let expression_or_instructions ctx st in_function = @ [ List (Atom "else" :: expression iff) ]) ] | Try (ty, body, catches) -> - [ List - (Atom "try" - :: (block_type st ty - @ List (Atom "do" :: instructions body) - :: List.map - ~f:(fun (tag, i, ty) -> - List - (Atom "catch" - :: index st.tag_names tag - :: (instruction (Wasm_ast.Event Code_generation.hidden_location) - @ instruction (Wasm_ast.Br (i + 1, Some (Pop ty)))))) - catches)) - ] + if Config.Flag.trap_on_exception () + then [ List (Atom "block" :: (block_type st ty @ instructions body)) ] + else + [ List + (Atom "try" + :: (block_type st ty + @ List (Atom "do" :: instructions body) + :: List.map + ~f:(fun (tag, i, ty) -> + List + (Atom "catch" + :: index st.tag_names tag + :: (instruction + (Wasm_ast.Event Code_generation.hidden_location) + @ instruction (Wasm_ast.Br (i + 1, Some (Pop ty)))))) + catches)) + ] and instruction i = match i with | Drop e -> [ List (Atom "drop" :: expression e) ] @@ -499,8 +503,14 @@ let expression_or_instructions ctx st in_function = | None -> [] | Some e -> expression e)) ] - | Throw (tag, e) -> [ List (Atom "throw" :: index st.tag_names tag :: expression e) ] - | Rethrow i -> [ List [ Atom "rethrow"; Atom (string_of_int i) ] ] + | Throw (tag, e) -> + if Config.Flag.trap_on_exception () + then [ List [ Atom "unreachable" ] ] + else [ List (Atom "throw" :: index st.tag_names tag :: expression e) ] + | Rethrow i -> + if Config.Flag.trap_on_exception () + then [ List [ Atom "unreachable" ] ] + else [ List [ Atom "rethrow"; Atom (string_of_int i) ] ] | CallInstr (f, l) -> [ List (Atom "call" diff --git a/compiler/lib-wasm/wat_preprocess.ml b/compiler/lib-wasm/wat_preprocess.ml index 5637781e9c..63d6ce675d 100644 --- a/compiler/lib-wasm/wat_preprocess.ml +++ b/compiler/lib-wasm/wat_preprocess.ml @@ -410,6 +410,69 @@ let rec rewrite_list st l = List.iter ~f:(rewrite st) l and rewrite st elt = match elt with + | { desc = + List + ({ desc = Atom "try"; _ } + :: { desc = List ({ desc = Atom "result"; _ } :: _) + ; loc = pos_before_result, pos_after_result + } + :: { desc = List ({ desc = Atom "do"; loc = _, pos_after_do } :: body) + ; loc = _, pos_after_body + } + :: _) + ; loc = pos, pos' + } + when variable_is_set st "trap-on-exception" -> + write st pos; + Buffer.add_string st.buf "(block"; + skip st pos_before_result; + write st pos_after_result; + skip st pos_after_do; + rewrite_list st body; + write st pos_after_body; + skip st pos' + | { desc = + List + ({ desc = Atom "try"; _ } + :: { desc = List ({ desc = Atom "do"; loc = _, pos_after_do } :: body) + ; loc = _, pos_after_body + } + :: _) + ; loc = pos, pos' + } + when variable_is_set st "trap-on-exception" -> + write st pos; + Buffer.add_string st.buf "(block"; + skip st pos_after_do; + rewrite_list st body; + write st pos_after_body; + skip st pos' + | { desc = List ({ desc = Atom "throw"; _ } :: _); loc = pos, pos' } + when variable_is_set st "trap-on-exception" -> + write st pos; + Buffer.add_string st.buf "(unreachable)"; + skip st pos' + | { desc = List ({ desc = Atom "tag"; _ } :: _); loc = pos, pos' } + | { desc = + List + ({ desc = Atom "import"; _ } + :: _ + :: _ + :: { desc = List ({ desc = Atom "tag"; _ } :: _); _ } + :: _) + ; loc = pos, pos' + } + | { desc = + List + ({ desc = Atom "export"; _ } + :: _ + :: { desc = List ({ desc = Atom "tag"; _ } :: _); _ } + :: _) + ; loc = pos, pos' + } + when variable_is_set st "trap-on-exception" -> + write st pos; + skip st pos' | { desc = List [ { desc = Atom "@if"; _ } diff --git a/compiler/lib/config.ml b/compiler/lib/config.ml index 28031afa8f..109b477a4d 100644 --- a/compiler/lib/config.ml +++ b/compiler/lib/config.ml @@ -103,6 +103,8 @@ module Flag = struct let es6 = o ~name:"es6" ~default:false let wasi = o ~name:"wasi" ~default:false + + let trap_on_exception = o ~name:"trap-on-exception" ~default:false end module Param = struct diff --git a/compiler/lib/config.mli b/compiler/lib/config.mli index a4f7a5538f..a05274a2bd 100644 --- a/compiler/lib/config.mli +++ b/compiler/lib/config.mli @@ -78,6 +78,8 @@ module Flag : sig val wasi : unit -> bool + val trap_on_exception : unit -> bool + val enable : string -> unit val disable : string -> unit From 73bac498178e5086d8e2c280de732b788018e3dc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Fri, 14 Feb 2025 13:05:37 +0100 Subject: [PATCH 23/29] Node wrapper: support for using alternative Wasm engines --- tools/node_wrapper.ml | 44 ++++++++++++++++++++++++++++++++++++------- 1 file changed, 37 insertions(+), 7 deletions(-) diff --git a/tools/node_wrapper.ml b/tools/node_wrapper.ml index 15979975a8..dfa7a8bf47 100644 --- a/tools/node_wrapper.ml +++ b/tools/node_wrapper.ml @@ -1,6 +1,20 @@ +let wizard_args = [ "-ext:stack-switching"; "-stack-size=2M"; "--dir=."; "--dir=/tmp" ] + +let wasmtime_args = + [ (* "-C"; "collector=null"; *) "-W=all-proposals=y"; "--dir=."; "--dir=/tmp" ] + +let wasmedge_args = + [ "--enable-gc" + ; "--enable-exception-handling" + ; "--enable-tail-call" + ; "--dir=." + ; "--dir=/tmp" + ] + let extra_args_for_wasoo = [ "--experimental-wasm-imported-strings" ; "--experimental-wasm-stack-switching" + ; "--experimental-wasm-exnref" ; "--stack-size=10000" ] @@ -23,16 +37,32 @@ let env = else e) env -let args = +let environment_args () = + List.filter + (fun e -> not (String.contains e ',')) + (Array.to_list (Array.map (fun e -> "--env=" ^ e) env)) + +let wasm_file file = + Filename.concat (Filename.chop_extension file ^ ".assets") "code.wasm" + +let common_args file argv = environment_args () @ (wasm_file file :: List.tl argv) + +let exe, args = match Array.to_list Sys.argv with | exe :: argv -> - let argv = + let exe', argv = match argv with - | file :: _ when Filename.check_suffix file ".wasm.js" -> - extra_args_for_wasoo @ argv - | _ -> extra_args_for_jsoo @ argv + | file :: _ when Filename.check_suffix file ".wasm.js" -> ( + match Sys.getenv_opt "WASM_ENGINE" with + | Some "wizard" -> "wizeng.x86-linux", wizard_args @ common_args file argv + | Some "wizard-fast" -> + "wizeng.x86-64-linux", wizard_args @ common_args file argv + | Some "wasmtime" -> "wasmtime", wasmtime_args @ common_args file argv + | Some "wasmedge" -> "wasmedge", wasmedge_args @ common_args file argv + | _ -> "node", extra_args_for_wasoo @ argv) + | _ -> "node", extra_args_for_jsoo @ argv in - Array.of_list (exe :: argv) + exe', Array.of_list (exe :: argv) | [] -> assert false let () = @@ -45,4 +75,4 @@ let () = | _, WEXITED n -> exit n | _, WSIGNALED _ -> exit 9 | _, WSTOPPED _ -> exit 9 - else Unix.execvpe "node" args env + else Unix.execvpe exe args env From a8e0de9ef15afebeb3879f38d0327e3ba0aa3258 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Fri, 14 Feb 2025 13:06:30 +0100 Subject: [PATCH 24/29] CI updates --- .github/workflows/build-wasm_of_ocaml.yml | 60 ++++++++++++++++++++++- dune | 13 ++++- 2 files changed, 70 insertions(+), 3 deletions(-) diff --git a/.github/workflows/build-wasm_of_ocaml.yml b/.github/workflows/build-wasm_of_ocaml.yml index 70ee887c56..12a95b63a2 100644 --- a/.github/workflows/build-wasm_of_ocaml.yml +++ b/.github/workflows/build-wasm_of_ocaml.yml @@ -16,6 +16,8 @@ jobs: matrix: os: - ubuntu-latest + os-name: + - Ubuntu ocaml-compiler: - "4.14" - "5.0" @@ -27,30 +29,50 @@ jobs: - false all_jane_street_tests: - false + wasi: + - false include: - os: macos-latest + os-name: MacOS ocaml-compiler: "5.3" separate_compilation: true jane_street_tests: false all_jane_street_tests: false + wasi: false - os: windows-latest + os-name: Windows ocaml-compiler: "5.2" separate_compilation: true jane_street_tests: true all_jane_street_tests: true + wasi: false - os: ubuntu-latest + os-name: Ubuntu ocaml-compiler: "5.2" separate_compilation: true jane_street_tests: true all_jane_street_tests: true + wasi: false - os: ubuntu-latest + os-name: Ubuntu ocaml-compiler: "5.2" separate_compilation: false jane_street_tests: true all_jane_street_tests: false + wasi: false + - os: ubuntu-latest + os-name: Ubuntu + ocaml-compiler: "5.3" + separate_compilation: true + jane_street_tests: false + all_jane_street_tests: false + wasi: true runs-on: ${{ matrix.os }} + name: + ${{ matrix.wasi && 'WASI / ' || '' }}${{ (! matrix.separate_compilation) && 'Whole program / ' || ''}}${{ matrix.ocaml-compiler }} / ${{ matrix.os-name }}${{ matrix.all_jane_street_tests && ' / Jane Street tests' || ''}} + steps: - name: Set git to use LF if: ${{ matrix.os == 'windows-latest' && matrix.ocaml-compiler < 5.2 }} @@ -77,6 +99,25 @@ jobs: with: node-version: latest + - name: Set-up Rust toolchain + if: matrix.wasi + uses: actions-rust-lang/setup-rust-toolchain@v1 + + - name: Checkout Wasmtime + if: matrix.wasi + uses: actions/checkout@v4 + with: + repository: bytecodealliance/wasmtime + path: wasmtime + submodules: true + + - name: Build Wasmtime + if: matrix.wasi + working-directory: ./wasmtime + run: | + cargo build + echo `pwd`/target/debug >> "$GITHUB_PATH" + - name: Set-up OCaml ${{ matrix.ocaml-compiler }} uses: ocaml/setup-ocaml@v3 with: @@ -127,7 +168,7 @@ jobs: opam install num cohttp-lwt-unix ppx_expect cstruct uucp - name: Run tests - if: ${{ matrix.separate_compilation }} + if: ${{ matrix.separate_compilation && ! matrix.wasi }} working-directory: ./wasm_of_ocaml run: opam exec -- dune build @runtest-wasm @@ -136,11 +177,26 @@ jobs: # See https://github.com/libuv/libuv/issues/3622 - name: Run tests with CPS effects - if: ${{ matrix.ocaml-compiler >= '5.' && matrix.separate_compilation }} + if: ${{ matrix.ocaml-compiler >= '5.' && matrix.separate_compilation && ! matrix.wasi }} continue-on-error: ${{ matrix.os == 'windows-latest' }} working-directory: ./wasm_of_ocaml run: opam exec -- dune build @runtest-wasm --profile with-effects + - name: Run tests (WASI runtime - node) + if: ${{ matrix.wasi }} + working-directory: ./wasm_of_ocaml + run: opam exec -- dune build @runtest-wasm --profile wasi + + - name: Run tests (WASI runtime - wasmtime) + if: ${{ matrix.wasi }} + working-directory: ./wasm_of_ocaml + env: + WASM_ENGINE: wasmtime + WASI_FLAGS: --enable trap-on-exception + RUST_BACKTRACE: 0 + continue-on-error: true + run: opam exec -- dune build @runtest-wasm --profile wasi + - name: Run Base tests if: matrix.all_jane_street_tests continue-on-error: ${{ matrix.os == 'windows-latest' }} diff --git a/dune b/dune index 150a7dacbd..e8b701e0d7 100644 --- a/dune +++ b/dune @@ -33,7 +33,11 @@ (wasi (wasm_of_ocaml (flags - (:standard --pretty --enable wasi)) + (:standard + --pretty + --enable + wasi + (:include wasi_extra_flags))) (compilation_mode whole_program)) (binaries (tools/node_wrapper.exe as node) @@ -63,6 +67,13 @@ %{dep:VERSION} %{dep:tools/version/GIT-VERSION})))) +(rule + (targets wasi_extra_flags) + (action + (with-stdout-to + %{targets} + (echo "(%{env:WASI_FLAGS=})")))) + (data_only_dirs _wikidoc doc-dev janestreet) (vendored_dirs) From 623f0dbabb3c92a7308dff220f134e77d5b260da Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Thu, 6 Feb 2025 19:07:05 +0100 Subject: [PATCH 25/29] CI: use Wizard engine as well --- .github/workflows/build-wasm_of_ocaml.yml | 37 +++++++++++++++++++++++ 1 file changed, 37 insertions(+) diff --git a/.github/workflows/build-wasm_of_ocaml.yml b/.github/workflows/build-wasm_of_ocaml.yml index 12a95b63a2..d81164650e 100644 --- a/.github/workflows/build-wasm_of_ocaml.yml +++ b/.github/workflows/build-wasm_of_ocaml.yml @@ -118,6 +118,35 @@ jobs: cargo build echo `pwd`/target/debug >> "$GITHUB_PATH" + - name: Checkout Virgil + if: matrix.wasi + uses: actions/checkout@v4 + with: + repository: titzer/virgil + path: virgil + + - name: Build Virgil + if: matrix.wasi + working-directory: ./virgil + run: | + export PATH=$PATH:`pwd`/bin + echo `pwd`/bin >> "$GITHUB_PATH" + make + + - name: Checkout Wizard engine + if: matrix.wasi + uses: actions/checkout@v4 + with: + repository: titzer/wizard-engine + path: wizard-engine + + - name: Build Wizard engine + if: matrix.wasi + working-directory: ./wizard-engine + run: | + make -j 4 + echo `pwd`/bin >> "$GITHUB_PATH" + - name: Set-up OCaml ${{ matrix.ocaml-compiler }} uses: ocaml/setup-ocaml@v3 with: @@ -197,6 +226,14 @@ jobs: continue-on-error: true run: opam exec -- dune build @runtest-wasm --profile wasi + - name: Run tests (WASI runtime - Wizard engine) + if: ${{ matrix.wasi }} + working-directory: ./wasm_of_ocaml + env: + WASM_ENGINE: wizard-fast + continue-on-error: true + run: opam exec -- dune build @runtest-wasm --profile wasi + - name: Run Base tests if: matrix.all_jane_street_tests continue-on-error: ${{ matrix.os == 'windows-latest' }} From 85a9891211026568ebb52a1fb3db0c631ed810b7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Wed, 19 Feb 2025 11:45:49 +0100 Subject: [PATCH 26/29] WASI: support for separate compilation --- compiler/bin-wasm_of_ocaml/compile.ml | 9 +- compiler/lib-wasm/generate.ml | 33 ++++ compiler/lib-wasm/generate.mli | 3 + compiler/lib-wasm/link.ml | 223 +++++++++++++++++++++----- compiler/lib-wasm/link.mli | 8 + compiler/lib-wasm/wasm_link.ml | 28 ++-- compiler/lib-wasm/wasm_link.mli | 3 +- compiler/lib/build_info.ml | 7 +- dune | 7 +- 9 files changed, 265 insertions(+), 56 deletions(-) diff --git a/compiler/bin-wasm_of_ocaml/compile.ml b/compiler/bin-wasm_of_ocaml/compile.ml index 7611d011a0..cd967dcaea 100644 --- a/compiler/bin-wasm_of_ocaml/compile.ml +++ b/compiler/bin-wasm_of_ocaml/compile.ml @@ -522,9 +522,12 @@ let run tmp_wasm_file in let wasm_name = - Printf.sprintf - "code-%s" - (String.sub (Digest.to_hex (Digest.file tmp_wasm_file)) ~pos:0 ~len:20) + if Config.Flag.wasi () + then "code" + else + Printf.sprintf + "code-%s" + (String.sub (Digest.to_hex (Digest.file tmp_wasm_file)) ~pos:0 ~len:20) in let tmp_wasm_file' = Filename.concat tmp_dir (wasm_name ^ ".wasm") in Sys.rename tmp_wasm_file tmp_wasm_file'; diff --git a/compiler/lib-wasm/generate.ml b/compiler/lib-wasm/generate.ml index 308f8d5602..cb1eefcfea 100644 --- a/compiler/lib-wasm/generate.ml +++ b/compiler/lib-wasm/generate.ml @@ -1078,6 +1078,35 @@ module Generate (Target : Target_sig.S) = struct :: context.other_fields; name + let add_missing_primitives ~context l = + let failwith_desc = W.Fun { params = [ Value.value ]; result = [] } in + List.iter l ~f:(fun (exported_name, arity) -> + let name = Code.Var.fresh_n exported_name in + let locals, body = + function_body + ~context + ~param_names:[] + ~body: + (let* failwith = + register_import ~import_module:"env" ~name:"caml_failwith" failwith_desc + in + let* msg = + Constant.translate (String (exported_name ^ " not implemented")) + in + let* () = instr (CallInstr (failwith, [ msg ])) in + push Value.unit) + in + context.other_fields <- + W.Function + { name + ; exported_name = Some exported_name + ; typ = func_type arity + ; param_names = [] + ; locals + ; body + } + :: context.other_fields) + let entry_point context toplevel_fun entry_name = let typ, param_names, body = entry_point ~toplevel_fun in let locals, body = function_body ~context ~param_names ~body in @@ -1238,6 +1267,10 @@ let add_init_function = let module G = Generate (Gc_target) in G.add_init_function +let add_missing_primitives = + let module G = Generate (Gc_target) in + G.add_missing_primitives + let output ch ~context = let module G = Generate (Gc_target) in let fields = G.output ~context in diff --git a/compiler/lib-wasm/generate.mli b/compiler/lib-wasm/generate.mli index 773917310b..d183c865c0 100644 --- a/compiler/lib-wasm/generate.mli +++ b/compiler/lib-wasm/generate.mli @@ -34,6 +34,9 @@ val add_start_function : context:Code_generation.context -> Wasm_ast.var -> unit val add_init_function : context:Code_generation.context -> to_link:string list -> unit +val add_missing_primitives : + context:Code_generation.context -> (string * int) list -> unit + val output : out_channel -> context:Code_generation.context -> unit val wasm_output : out_channel -> context:Code_generation.context -> unit diff --git a/compiler/lib-wasm/link.ml b/compiler/lib-wasm/link.ml index 4178ce0b3a..037d90a8de 100644 --- a/compiler/lib-wasm/link.ml +++ b/compiler/lib-wasm/link.ml @@ -181,12 +181,13 @@ module Wasm_binary = struct let reftype ch = reftype' (input_byte ch) ch - let valtype ch = - let i = read_uint ch in + let valtype' i ch = match i with - | 0x7b | 0x7c | 0x7d | 0x7e | 0x7f -> () + | 0x7B | 0x7C | 0x7D | 0x7E | 0x7F -> () | _ -> reftype' i ch + let valtype ch = valtype' (read_uint ch) ch + let limits ch = match input_byte ch with | 0 -> ignore (read_uint ch) @@ -201,32 +202,95 @@ module Wasm_binary = struct reftype ch; limits ch + type comptype = + | Func of { arity : int } + | Struct + | Array + + let supertype ch = + match input_byte ch with + | 0 -> () + | 1 -> ignore (read_uint ch) + | _ -> assert false + + let storagetype ch = + let i = read_uint ch in + match i with + | 0x78 | 0x77 -> () + | _ -> valtype' i ch + + let fieldtype ch = + storagetype ch; + ignore (input_byte ch) + + let comptype i ch = + match i with + | 0x5E -> + fieldtype ch; + Array + | 0x5F -> + ignore (vec fieldtype ch); + Struct + | 0x60 -> + let params = vec valtype ch in + let _ = vec valtype ch in + Func { arity = List.length params } + | c -> failwith (Printf.sprintf "Unknown comptype %d" c) + + let subtype i ch = + match i with + | 0x50 -> + supertype ch; + comptype (input_byte ch) ch + | 0x4F -> + supertype ch; + comptype (input_byte ch) ch + | _ -> comptype i ch + + let rectype ch = + match input_byte ch with + | 0x4E -> vec (fun ch -> subtype (input_byte ch) ch) ch + | i -> [ subtype i ch ] + + type importdesc = + | Func of int + | Table + | Mem + | Global + | Tag + type import = { module_ : string ; name : string + ; desc : importdesc } let import ch = let module_ = name ch in let name = name ch in let d = read_uint ch in - let _ = + let desc = match d with - | 0 -> ignore (read_uint ch) - | 1 -> tabletype ch - | 2 -> memtype ch + | 0 -> Func (read_uint ch) + | 1 -> + tabletype ch; + Table + | 2 -> + memtype ch; + Mem | 3 -> let _typ = valtype ch in let _mut = input_byte ch in - () + Global | 4 -> assert (read_uint ch = 0); - ignore (read_uint ch) + ignore (read_uint ch); + Tag | _ -> Format.eprintf "Unknown import %x@." d; assert false in - { module_; name } + { module_; name; desc } let export ch = let name = name ch in @@ -256,6 +320,7 @@ module Wasm_binary = struct type interface = { imports : import list ; exports : string list + ; types : comptype array } let read_interface ch = @@ -263,7 +328,11 @@ module Wasm_binary = struct match next_section ch with | None -> i | Some s -> - if s.id = 2 + if s.id = 1 + then + find_sections + { i with types = Array.of_list (List.flatten (vec rectype ch.ch)) } + else if s.id = 2 then find_sections { i with imports = vec import ch.ch } else if s.id = 7 then { i with exports = vec export ch.ch } @@ -271,7 +340,7 @@ module Wasm_binary = struct skip_section ch s; find_sections i) in - find_sections { imports = []; exports = [] } + find_sections { imports = []; exports = []; types = [||] } let append_source_map_section ~file ~url = let ch = open_out_gen [ Open_wronly; Open_append; Open_binary ] 0o666 file in @@ -405,6 +474,13 @@ let generate_start_function ~to_link ~out_file = Generate.wasm_output ch ~context; if times () then Format.eprintf " generate start: %a@." Timer.print t1 +let generate_missing_primitives ~missing_primitives ~out_file = + Filename.gen_file out_file + @@ fun ch -> + let context = Generate.start () in + Generate.add_missing_primitives ~context missing_primitives; + Generate.wasm_output ch ~context + let output_js js = Code.Var.reset (); let b = Buffer.create 1024 in @@ -665,17 +741,20 @@ let compute_dependencies ~files_to_link ~files = let compute_missing_primitives (runtime_intf, intfs) = let provided_primitives = StringSet.of_list runtime_intf.Wasm_binary.exports in - StringSet.elements + StringMap.bindings @@ List.fold_left - ~f:(fun s { Wasm_binary.imports; _ } -> + ~f:(fun s { Wasm_binary.imports; types; _ } -> List.fold_left - ~f:(fun s { Wasm_binary.module_; name; _ } -> - if String.equal module_ "env" && not (StringSet.mem name provided_primitives) - then StringSet.add name s - else s) + ~f:(fun s { Wasm_binary.module_; name; desc } -> + match module_, desc with + | "env", Func idx when not (StringSet.mem name provided_primitives) -> ( + match types.(idx) with + | Func { arity } -> StringMap.add name arity s + | _ -> s) + | _ -> s) ~init:s imports) - ~init:StringSet.empty + ~init:StringMap.empty intfs let load_information files = @@ -711,6 +790,69 @@ let gen_dir dir f = remove_directory d_tmp; raise exc +let link_to_module ~to_link ~files_to_link ~files ~enable_source_maps:_ ~dir = + let process_file ~name ~module_name file = + Zip.with_open_in file + @@ fun z -> + let intf = + let ch, pos, len, _ = Zip.get_entry z ~name in + Wasm_binary.read_interface (Wasm_binary.from_channel ~name ch pos len) + in + ( { Wasm_link.module_name + ; file + ; code = Some (Zip.read_entry z ~name) + ; opt_source_map = None + } + , intf ) + in + let runtime_file = fst (List.hd files) in + let z = Zip.open_in runtime_file in + let runtime, runtime_intf = + process_file ~name:"runtime.wasm" ~module_name:"env" runtime_file + in + let prelude = + { Wasm_link.module_name = "OCaml" + ; file = runtime_file + ; code = Some (Zip.read_entry z ~name:"prelude.wasm") + ; opt_source_map = None + } + in + Zip.close_in z; + let lst = + List.tl files + |> List.filter_map ~f:(fun (file, _) -> + if StringSet.mem file files_to_link + then Some (process_file ~name:"code.wasm" ~module_name:"OCaml" file) + else None) + in + let missing_primitives = + if Config.Flag.genprim () + then compute_missing_primitives (runtime_intf, List.map ~f:snd lst) + else [] + in + let start_module = Filename.concat dir "start.wasm" in + generate_start_function ~to_link ~out_file:start_module; + let start = + { Wasm_link.module_name = "OCaml" + ; file = start_module + ; code = None + ; opt_source_map = None + } + in + generate_missing_primitives ~missing_primitives ~out_file:"stubs.wasm"; + let missing_primitives = + { Wasm_link.module_name = "env" + ; file = "stubs.wasm" + ; code = None + ; opt_source_map = None + } + in + ignore + (Wasm_link.f + (runtime :: prelude :: missing_primitives :: start :: List.map ~f:fst lst) + ~filter_export:(fun nm -> String.equal nm "_start" || String.equal nm "memory") + ~output_file:(Filename.concat dir "code.wasm")) + let link ~output_file ~linkall ~enable_source_maps ~files = if times () then Format.eprintf "linking@."; let t = Timer.make () in @@ -801,30 +943,35 @@ let link ~output_file ~linkall ~enable_source_maps ~files = if times () then Format.eprintf " finding what to link: %a@." Timer.print t1; if times () then Format.eprintf " scan: %a@." Timer.print t; let t = Timer.make () in - let interfaces, wasm_dir, link_spec = + let missing_primitives, wasm_dir, link_spec = let dir = Filename.chop_extension output_file ^ ".assets" in gen_dir dir @@ fun tmp_dir -> Sys.mkdir tmp_dir 0o777; - let start_module = - "start-" - ^ String.sub - (Digest.to_hex (Digest.string (String.concat ~sep:"/" to_link))) - ~pos:0 - ~len:8 - in - generate_start_function - ~to_link - ~out_file:(Filename.concat tmp_dir (start_module ^ ".wasm")); - let module_names, interfaces = - link_to_directory ~files_to_link ~files ~enable_source_maps ~dir:tmp_dir - in - ( interfaces - , dir - , let to_link = compute_dependencies ~files_to_link ~files in - List.combine module_names (None :: None :: to_link) @ [ start_module, None ] ) + if not (Config.Flag.wasi ()) + then ( + let start_module = + "start-" + ^ String.sub + (Digest.to_hex (Digest.string (String.concat ~sep:"/" to_link))) + ~pos:0 + ~len:8 + in + let module_names, interfaces = + link_to_directory ~files_to_link ~files ~enable_source_maps ~dir:tmp_dir + in + let missing_primitives = compute_missing_primitives interfaces in + generate_start_function + ~to_link + ~out_file:(Filename.concat tmp_dir (start_module ^ ".wasm")); + ( List.map ~f:fst missing_primitives + , dir + , let to_link = compute_dependencies ~files_to_link ~files in + List.combine module_names (None :: None :: to_link) @ [ start_module, None ] )) + else ( + link_to_module ~to_link ~files_to_link ~files ~enable_source_maps ~dir:tmp_dir; + [], dir, [ "code", None ]) in - let missing_primitives = compute_missing_primitives interfaces in if times () then Format.eprintf " copy wasm files: %a@." Timer.print t; let t1 = Timer.make () in let js_runtime = diff --git a/compiler/lib-wasm/link.mli b/compiler/lib-wasm/link.mli index 0c788e7d47..55424663f1 100644 --- a/compiler/lib-wasm/link.mli +++ b/compiler/lib-wasm/link.mli @@ -19,9 +19,17 @@ open Stdlib module Wasm_binary : sig + type importdesc = + | Func of int + | Table + | Mem + | Global + | Tag + type import = { module_ : string ; name : string + ; desc : importdesc } val check : contents:string -> bool diff --git a/compiler/lib-wasm/wasm_link.ml b/compiler/lib-wasm/wasm_link.ml index a53fc34a4d..b3a1939f82 100644 --- a/compiler/lib-wasm/wasm_link.ml +++ b/compiler/lib-wasm/wasm_link.ml @@ -1878,7 +1878,7 @@ type input = ; opt_source_map : Source_map.Standard.t option } -let f files ~output_file = +let f ?(filter_export = fun _ -> true) files ~output_file = let files = Array.map ~f:(fun { module_name; file; code; opt_source_map } -> @@ -2132,20 +2132,28 @@ let f files ~output_file = Array.iter ~f:Scan.clear_position_data positions; (* 7: export *) + let exports = + Array.map + ~f:(fun intf -> + map_exportable_info + (fun _ exports -> List.filter ~f:(fun (nm, _) -> filter_export nm) exports) + intf.Read.exports) + intfs + in let export_count = Array.fold_left - ~f:(fun count intf -> + ~f:(fun count exports -> fold_exportable_info (fun _ exports count -> List.length exports + count) count - intf.Read.exports) + exports) ~init:0 - intfs + exports in Write.uint buf export_count; - let exports = Hashtbl.create 128 in + let export_tbl = Hashtbl.create 128 in Array.iteri - ~f:(fun i intf -> + ~f:(fun i exports -> iter_exportable_info (fun kind lst -> let map = @@ -2158,7 +2166,7 @@ let f files ~output_file = in List.iter ~f:(fun (name, idx) -> - match Hashtbl.find exports name with + match Hashtbl.find export_tbl name with | i' -> failwith (Printf.sprintf @@ -2167,11 +2175,11 @@ let f files ~output_file = files.(i').file files.(i).file) | exception Not_found -> - Hashtbl.add exports name i; + Hashtbl.add export_tbl name i; Write.export buf kind name map.(idx)) lst) - intf.Read.exports) - intfs; + exports) + exports; add_section out_ch ~id:7 buf; (* 8: start *) diff --git a/compiler/lib-wasm/wasm_link.mli b/compiler/lib-wasm/wasm_link.mli index 0c0ed0a582..4cbd769668 100644 --- a/compiler/lib-wasm/wasm_link.mli +++ b/compiler/lib-wasm/wasm_link.mli @@ -23,4 +23,5 @@ type input = ; opt_source_map : Source_map.Standard.t option } -val f : input list -> output_file:string -> Source_map.t +val f : + ?filter_export:(string -> bool) -> input list -> output_file:string -> Source_map.t diff --git a/compiler/lib/build_info.ml b/compiler/lib/build_info.ml index 4de9956edf..b5da01bbb4 100644 --- a/compiler/lib/build_info.ml +++ b/compiler/lib/build_info.ml @@ -68,6 +68,7 @@ let create kind = | v -> Printf.sprintf "%s+%s" Compiler_version.s v in [ "use-js-string", string_of_bool (Config.Flag.use_js_string ()) + ; "wasi", string_of_bool (Config.Flag.wasi ()) ; "effects", string_of_effects_backend (Config.effects ()) ; "version", version ; "kind", string_of_kind kind @@ -139,9 +140,9 @@ let merge fname1 info1 fname2 info2 = match k, v1, v2 with | "kind", v1, v2 -> if Option.equal String.equal v1 v2 then v1 else Some (string_of_kind `Unknown) - | ("effects" | "use-js-string" | "version"), Some v1, Some v2 + | ("effects" | "use-js-string" | "wasi" | "version"), Some v1, Some v2 when String.equal v1 v2 -> Some v1 - | (("effects" | "use-js-string" | "version") as key), v1, v2 -> + | (("effects" | "use-js-string" | "wasi" | "version") as key), v1, v2 -> raise (Incompatible_build_info { key; first = fname1, v1; second = fname2, v2 }) | _, Some v1, Some v2 when String.equal v1 v2 -> Some v1 @@ -156,7 +157,7 @@ let configure t = StringMap.iter (fun k v -> match k with - | "use-js-string" -> Config.Flag.set k (bool_of_string v) + | "use-js-string" | "wasi" -> Config.Flag.set k (bool_of_string v) | "effects" -> Config.set_effects_backend (effects_backend_of_string v) | _ -> ()) t diff --git a/dune b/dune index e8b701e0d7..21183b243c 100644 --- a/dune +++ b/dune @@ -32,13 +32,18 @@ (tools/node_wrapper.exe as node.exe))) (wasi (wasm_of_ocaml + (build_runtime_flags + (:standard + --enable + wasi + (:include wasi_extra_flags))) (flags (:standard --pretty --enable wasi (:include wasi_extra_flags))) - (compilation_mode whole_program)) + (compilation_mode separate)) (binaries (tools/node_wrapper.exe as node) (tools/node_wrapper.exe as node.exe))) From 0b4e60b15aa0c62e9c159609519fdb3ea4a6c14c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Thu, 6 Feb 2025 18:59:36 +0100 Subject: [PATCH 27/29] CI: install a version on Binaryen with stack-switching support --- .github/actions/install-binaryen/action.yml | 90 +++++++++++++++++++++ .github/workflows/build-wasm_of_ocaml.yml | 8 +- .github/workflows/build.yml | 8 +- 3 files changed, 100 insertions(+), 6 deletions(-) create mode 100644 .github/actions/install-binaryen/action.yml diff --git a/.github/actions/install-binaryen/action.yml b/.github/actions/install-binaryen/action.yml new file mode 100644 index 0000000000..b3c3615521 --- /dev/null +++ b/.github/actions/install-binaryen/action.yml @@ -0,0 +1,90 @@ +name: Install Binaryen + +inputs: + repository: + description: 'Repository name with owner. For example, actions/checkout' + default: WebAssembly/binaryen + ref: + description: > + The branch, tag or SHA to checkout. When checking out the repository that + triggered a workflow, this defaults to the reference or SHA for that + event. Otherwise, uses the default branch. + default: latest + build: + description: Whether we should build from source + default: false +runs: + using: composite + steps: + - name: Restore cached binaryen + if: ${{ inputs.build && inputs.build != 'false' }} + id: cache-binaryen + uses: actions/cache/restore@v4 + with: + path: binaryen + key: ${{ runner.os }}-binaryen-${{ inputs.ref }} + + - name: Checkout binaryen + if: ${{ inputs.build && inputs.build != 'false' && steps.cache-binaryen.outputs.cache-hit != 'true' }} + uses: actions/checkout@v4 + with: + repository: ${{ inputs.repository }} + path: binaryen + submodules: true + ref: ${{ inputs.ref == 'latest' && 'main' || inputs.ref }} + + - name: Install ninja (Linux) + if: ${{ inputs.build && inputs.build != 'false' && runner.os == 'Linux' && steps.cache-binaryen.outputs.cache-hit != 'true' }} + shell: bash + run: sudo apt-get install ninja-build + + - name: Install ninja (MacOS) + if: ${{ inputs.build && inputs.build != 'false' && runner.os == 'macOS' && steps.cache-binaryen.outputs.cache-hit != 'true' }} + shell: bash + run: brew install ninja + + - name: Build binaryen + if: ${{ inputs.build && inputs.build != 'false' && runner.os != 'Windows' && steps.cache-binaryen.outputs.cache-hit != 'true' }} + working-directory: ./binaryen + shell: bash + run: | + cmake -G Ninja . + ninja + + - name: Install binaryen build dependencies (Windows) + if: ${{ inputs.build && inputs.build != 'false' && runner.os == 'Windows' && steps.cache-binaryen.outputs.cache-hit != 'true' }} + working-directory: ./binaryen + shell: bash + run: opam install conf-cmake conf-c++ + + - name: Build binaryen (Windows) + if: ${{ inputs.build && inputs.build != 'false' && runner.os == 'Windows' && steps.cache-binaryen.outputs.cache-hit != 'true' }} + working-directory: ./binaryen + shell: bash + run: | + opam exec -- cmake . -DBUILD_STATIC_LIB=ON -DBUILD_TESTS=off -DINSTALL_LIBS=off -DCMAKE_C_COMPILER=x86_64-w64-mingw32-gcc + make -j 4 + + - name: Cache binaryen + if: ${{ inputs.build && inputs.build != 'false' && steps.cache-binaryen.outputs.cache-hit != 'true' }} + uses: actions/cache/save@v4 + with: + path: binaryen + key: ${{ runner.os }}-binaryen-${{ inputs.ref }} + + - name: Set binaryen's path + if: ${{ inputs.build && inputs.build != 'false' && runner.os != 'Windows' }} + shell: bash + run: echo "$GITHUB_WORKSPACE/binaryen/bin" >> $GITHUB_PATH + + - name: Copy binaryen's tools (Windows) + if: ${{ inputs.build && inputs.build != 'false' && runner.os == 'Windows' }} + shell: bash + run: cp $GITHUB_WORKSPACE/binaryen/bin/wasm-{merge,opt}.exe _opam/bin + + - name: Download Binaryen + if: ${{ ! inputs.build || inputs.build == 'false' }} + uses: Aandreba/setup-binaryen@v1.0.0 + with: + token: ${{ github.token }} + version: ${{ inputs.ref }} diff --git a/.github/workflows/build-wasm_of_ocaml.yml b/.github/workflows/build-wasm_of_ocaml.yml index d81164650e..8ed5785109 100644 --- a/.github/workflows/build-wasm_of_ocaml.yml +++ b/.github/workflows/build-wasm_of_ocaml.yml @@ -152,10 +152,12 @@ jobs: with: ocaml-compiler: ${{ matrix.ocaml-compiler }} - - name: Set-up Binaryen - uses: Aandreba/setup-binaryen@v1.0.0 + - name: Install Binaryen + uses: ./wasm_of_ocaml/.github/actions/install-binaryen with: - token: ${{ github.token }} + build: true + repository: vouillon/binaryen + ref: stack-switching-fixes - name: Pin faked binaryen-bin package # It's faster to use a cached version diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 02aae3e8d5..7150cc9919 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -127,10 +127,12 @@ jobs: - run: opam install conf-pkg-config conf-mingw-w64-g++-i686 conf-mingw-w64-g++-x86_64 if: runner.os == 'Windows' - - name: Set-up Binaryen - uses: Aandreba/setup-binaryen@v1.0.0 + - name: Install Binaryen + uses: ./.github/actions/install-binaryen with: - token: ${{ github.token }} + build: true + repository: vouillon/binaryen + ref: stack-switching-fixes - name: Install faked binaryen-bin package # It's faster to use a cached version From 6a657944d799854a9580232c4aff8d36d30fc13e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Tue, 18 Feb 2025 17:35:25 +0100 Subject: [PATCH 28/29] Update Wasm linker to support stack switching instructions --- compiler/lib-wasm/link.ml | 19 ++++++++- compiler/lib-wasm/wasm_link.ml | 78 ++++++++++++++++++++++++++++------ 2 files changed, 83 insertions(+), 14 deletions(-) diff --git a/compiler/lib-wasm/link.ml b/compiler/lib-wasm/link.ml index 037d90a8de..81ec5b5954 100644 --- a/compiler/lib-wasm/link.ml +++ b/compiler/lib-wasm/link.ml @@ -173,7 +173,20 @@ module Wasm_binary = struct let reftype' i ch = match i with - | 0x6a | 0x6b | 0x6c | 0x6d | 0x6e | 0x6f | 0x70 | 0x71 | 0x72 | 0x73 -> () + | 0x68 + | 0x69 + | 0x6a + | 0x6b + | 0x6c + | 0x6d + | 0x6e + | 0x6f + | 0x70 + | 0x71 + | 0x72 + | 0x73 + | 0x74 + | 0x75 -> () | 0x63 | 0x64 -> heaptype ch | _ -> Format.eprintf "Unknown reftype %x@." i; @@ -206,6 +219,7 @@ module Wasm_binary = struct | Func of { arity : int } | Struct | Array + | Cont let supertype ch = match input_byte ch with @@ -225,6 +239,9 @@ module Wasm_binary = struct let comptype i ch = match i with + | 0x5D -> + ignore (read_sint ch); + Cont | 0x5E -> fieldtype ch; Array diff --git a/compiler/lib-wasm/wasm_link.ml b/compiler/lib-wasm/wasm_link.ml index b3a1939f82..13a593c5b6 100644 --- a/compiler/lib-wasm/wasm_link.ml +++ b/compiler/lib-wasm/wasm_link.ml @@ -23,6 +23,10 @@ type heaptype = | Nofunc | Extern | Noextern + | Exn + | Noexn + | Cont + | Nocont | Any | Eq | I31 @@ -66,6 +70,7 @@ type comptype = } | Struct of fieldtype array | Array of fieldtype + | Cont of int type subtype = { final : bool @@ -147,6 +152,8 @@ module Write = struct let heaptype st ch typ = match (typ : heaptype) with + | Nocont -> byte ch 0x75 + | Noexn -> byte ch 0x74 | Nofunc -> byte ch 0x73 | Noextern -> byte ch 0x72 | None_ -> byte ch 0x71 @@ -157,6 +164,8 @@ module Write = struct | I31 -> byte ch 0x6C | Struct -> byte ch 0x6B | Array -> byte ch 0x6A + | Exn -> byte ch 0x69 + | Cont -> byte ch 0x68 | Type idx -> sint ch (typeidx st idx) let reftype st ch { nullable; typ } = @@ -202,6 +211,9 @@ module Write = struct byte ch 1; uint ch (typeidx st supertype)); match typ with + | Cont idx -> + byte ch 0x5D; + sint ch (typeidx st idx) | Array field_type -> byte ch 0x5E; fieldtype st ch field_type @@ -569,7 +581,9 @@ module Read = struct let heaptype st ch = let i = sint ch in match i + 128 with - | 0X73 -> Nofunc + | 0x75 -> Nocont + | 0x74 -> Noexn + | 0x73 -> Nofunc | 0x72 -> Noextern | 0x71 -> None_ | 0x70 -> Func @@ -579,6 +593,8 @@ module Read = struct | 0x6C -> I31 | 0x6B -> Struct | 0x6A -> Array + | 0x69 -> Exn + | 0x68 -> Cont | _ -> if i < 0 then failwith (Printf.sprintf "Unknown heaptype %x@." i); let i = @@ -596,7 +612,9 @@ module Read = struct let reftype' st i ch = match i with - | 0X73 -> nullable Nofunc + | 0x75 -> nullable Nocont + | 0x74 -> nullable Noexn + | 0x73 -> nullable Nofunc | 0x72 -> nullable Noextern | 0x71 -> nullable None_ | 0x70 -> nullable Func @@ -606,6 +624,8 @@ module Read = struct | 0x6C -> nullable I31 | 0x6B -> nullable Struct | 0x6A -> nullable Array + | 0x69 -> nullable Exn + | 0x68 -> nullable Cont | 0x63 -> nullable (heaptype st ch) | 0x64 -> { nullable = false; typ = heaptype st ch } | _ -> failwith (Printf.sprintf "Unknown reftype %x@." i) @@ -652,6 +672,14 @@ module Read = struct let comptype st i ch = match i with + | 0x5D -> + let i = sint ch in + let i = + if i >= st.type_index_count + then lnot (i - st.type_index_count) + else st.type_mapping.(i) + in + Cont i | 0x5E -> Array (fieldtype st ch) | 0x5F -> Struct (vec (fieldtype st) ch) | 0x60 -> @@ -1252,6 +1280,13 @@ module Scan = struct | 0xD1 (* ref.is_null *) | 0xD3 (* ref.eq *) | 0xD4 (* ref.as_non_null *) -> pos + 1 |> instructions | 0xD2 (* ref.func *) -> pos + 1 |> funcidx |> instructions + | 0xE0 (* cont.new *) -> pos + 1 |> typeidx |> instructions + | 0xE1 (* cont.bind *) -> pos + 1 |> typeidx |> typeidx |> instructions + | 0xE2 (* suspend *) -> pos + 1 |> tagidx |> instructions + | 0xE3 (* resume *) -> pos + 1 |> typeidx |> vector on_clause |> instructions + | 0xE4 (* resume_throw *) -> + pos + 1 |> typeidx |> tagidx |> vector on_clause |> instructions + | 0xE5 (* switch *) -> pos + 1 |> typeidx |> tagidx |> instructions | 0xFB -> pos + 1 |> gc_instruction | 0xFC -> ( if debug then Format.eprintf " %d@." (get (pos + 1)); @@ -1386,6 +1421,11 @@ module Scan = struct | 0 (* catch *) | 1 (* catch_ref *) -> pos + 1 |> tagidx |> labelidx | 2 (* catch_all *) | 3 (* catch_all_ref *) -> pos + 1 |> labelidx | c -> failwith (Printf.sprintf "bad catch 0x02%d@." c) + and on_clause pos = + match get pos with + | 0 (* on *) -> pos + 1 |> tagidx |> labelidx + | 1 (* on .. switch *) -> pos + 1 |> tagidx + | c -> failwith (Printf.sprintf "bad on clause 0x02%d@." c) and block_end pos = if debug then Format.eprintf "0x%02X (@%d) block end@." (get pos) pos; match get pos with @@ -1538,30 +1578,43 @@ let rec subtype subtyping_info (i : int) i' = | None -> false | Some s -> subtype subtyping_info s i' -let heap_subtype (subtyping_info : subtype array) (ty : heaptype) (ty' : heaptype) = +let rec heap_subtype (subtyping_info : subtype array) (ty : heaptype) (ty' : heaptype) = match ty, ty' with - | (Func | Nofunc), Func - | Nofunc, Nofunc - | (Extern | Noextern), Extern + | Func, Func + | Extern, Extern + | Noextern, Noextern + | Exn, Exn + | Noexn, Noexn + | Cont, Cont + | Nocont, Nocont | (Any | Eq | I31 | Struct | Array | None_ | Type _), Any | (Eq | I31 | Struct | Array | None_ | Type _), Eq - | (I31 | None_), I31 - | (Struct | None_), Struct - | (Array | None_), Array + | I31, I31 + | Struct, Struct + | Array, Array | None_, None_ -> true | Type i, Struct -> ( match subtyping_info.(i).typ with | Struct _ -> true - | Array _ | Func _ -> false) + | Array _ | Func _ | Cont _ -> false) | Type i, Array -> ( match subtyping_info.(i).typ with | Array _ -> true - | Struct _ | Func _ -> false) + | Struct _ | Func _ | Cont _ -> false) | Type i, Func -> ( match subtyping_info.(i).typ with | Func _ -> true - | Struct _ | Array _ -> false) + | Struct _ | Array _ | Cont _ -> false) + | Type i, Cont -> ( + match subtyping_info.(i).typ with + | Cont _ -> true + | Struct _ | Array _ | Func _ -> false) | Type i, Type i' -> subtype subtyping_info i i' + | Nofunc, _ -> heap_subtype subtyping_info ty' Func + | Noextern, _ -> heap_subtype subtyping_info ty' Extern + | Noexn, _ -> heap_subtype subtyping_info ty' Exn + | Nocont, _ -> heap_subtype subtyping_info ty' Cont + | None_, _ -> heap_subtype subtyping_info ty' Any | _ -> false let ref_subtype subtyping_info { nullable; typ } { nullable = nullable'; typ = typ' } = @@ -2449,7 +2502,6 @@ let f ?(filter_export = fun _ -> true) files ~output_file = (* LATER - testsuite : import/export matching, source maps, multiple start functions, ... -- missing instructions ==> typed continuations (?) - check features? MAYBE From a8763e20e3200d2d85588ad69c396e61ca858eb2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Sun, 24 Mar 2024 12:57:09 +0100 Subject: [PATCH 29/29] Effects based on Stack Switching proposal --- .github/workflows/build-wasm_of_ocaml.yml | 5 +- compiler/lib-wasm/binaryen.ml | 1 + compiler/tests-jsoo/lib-effects/dune | 8 +- compiler/tests-ocaml/effect-syntax/dune | 8 +- compiler/tests-ocaml/effects/dune | 8 +- runtime/wasm/effect-native.wat | 242 ++++++++++++++++++++++ runtime/wasm/effect.wat | 4 +- runtime/wasm/stdlib.wat | 10 + 8 files changed, 269 insertions(+), 17 deletions(-) create mode 100644 runtime/wasm/effect-native.wat diff --git a/.github/workflows/build-wasm_of_ocaml.yml b/.github/workflows/build-wasm_of_ocaml.yml index 8ed5785109..55250a1f3d 100644 --- a/.github/workflows/build-wasm_of_ocaml.yml +++ b/.github/workflows/build-wasm_of_ocaml.yml @@ -214,12 +214,12 @@ jobs: run: opam exec -- dune build @runtest-wasm --profile with-effects - name: Run tests (WASI runtime - node) - if: ${{ matrix.wasi }} + if: ${{ false }} working-directory: ./wasm_of_ocaml run: opam exec -- dune build @runtest-wasm --profile wasi - name: Run tests (WASI runtime - wasmtime) - if: ${{ matrix.wasi }} + if: ${{ false }} working-directory: ./wasm_of_ocaml env: WASM_ENGINE: wasmtime @@ -233,7 +233,6 @@ jobs: working-directory: ./wasm_of_ocaml env: WASM_ENGINE: wizard-fast - continue-on-error: true run: opam exec -- dune build @runtest-wasm --profile wasi - name: Run Base tests diff --git a/compiler/lib-wasm/binaryen.ml b/compiler/lib-wasm/binaryen.ml index 878b54f908..af3ef0ed13 100644 --- a/compiler/lib-wasm/binaryen.ml +++ b/compiler/lib-wasm/binaryen.ml @@ -37,6 +37,7 @@ let common_options () = ; "--enable-nontrapping-float-to-int" ; "--enable-strings" ; "--enable-multimemory" (* To keep wasm-merge happy *) + ; "--enable-stack-switching" ] in if Config.Flag.pretty () then "-g" :: l else l diff --git a/compiler/tests-jsoo/lib-effects/dune b/compiler/tests-jsoo/lib-effects/dune index 113ee4a090..68d1d8568a 100644 --- a/compiler/tests-jsoo/lib-effects/dune +++ b/compiler/tests-jsoo/lib-effects/dune @@ -1,10 +1,10 @@ (env (with-effects-double-translation) (with-effects) - (wasi - (wasm_of_ocaml - (flags - (:standard --enable effects)))) + ; (wasi + ; (wasm_of_ocaml + ; (flags + ; (:standard --enable effects)))) (_ (js_of_ocaml (flags diff --git a/compiler/tests-ocaml/effect-syntax/dune b/compiler/tests-ocaml/effect-syntax/dune index 6b08c88e72..d7e7e2fa3b 100644 --- a/compiler/tests-ocaml/effect-syntax/dune +++ b/compiler/tests-ocaml/effect-syntax/dune @@ -1,10 +1,10 @@ (env (with-effects-double-translation) (with-effects) - (wasi - (wasm_of_ocaml - (flags - (:standard --enable=effects)))) + ; (wasi + ; (wasm_of_ocaml + ; (flags + ; (:standard --enable=effects)))) (_ (js_of_ocaml (flags diff --git a/compiler/tests-ocaml/effects/dune b/compiler/tests-ocaml/effects/dune index d832b983a7..bb7cc86051 100644 --- a/compiler/tests-ocaml/effects/dune +++ b/compiler/tests-ocaml/effects/dune @@ -1,10 +1,10 @@ (env (with-effects-double-translation) (with-effects) - (wasi - (wasm_of_ocaml - (flags - (:standard --enable=effects)))) + ; (wasi + ; (wasm_of_ocaml + ; (flags + ; (:standard --enable=effects)))) (_ (js_of_ocaml (flags diff --git a/runtime/wasm/effect-native.wat b/runtime/wasm/effect-native.wat new file mode 100644 index 0000000000..aca6344883 --- /dev/null +++ b/runtime/wasm/effect-native.wat @@ -0,0 +1,242 @@ +(module +(@if wasi +(@then + (import "fail" "caml_raise_constant" + (func $caml_raise_constant (param (ref eq)))) + (import "fail" "caml_raise_with_arg" + (func $caml_raise_with_arg (param $tag (ref eq)) (param $arg (ref eq)))) + (import "obj" "caml_fresh_oo_id" + (func $caml_fresh_oo_id (param (ref eq)) (result (ref eq)))) + (import "obj" "cont_tag" (global $cont_tag i32)) + (import "stdlib" "caml_named_value" + (func $caml_named_value (param (ref eq)) (result (ref null eq)))) + (import "fail" "ocaml_exception" (tag $ocaml_exception (param (ref eq)))) + (import "fail" "javascript_exception" + (tag $javascript_exception (param externref))) + (import "jslib" "caml_wrap_exception" + (func $caml_wrap_exception (param externref) (result (ref eq)))) + (import "stdlib" "caml_main_wrapper" + (global $caml_main_wrapper (mut (ref null $wrapper_func)))) + (import "effect" "effect_allowed" (global $effect_allowed (mut i32))) + + (type $block (array (mut (ref eq)))) + (type $bytes (array (mut i8))) + (type $function_1 (func (param (ref eq) (ref eq)) (result (ref eq)))) + (type $closure (sub (struct (;(field i32);) (field (ref $function_1))))) + (type $function_3 + (func (param (ref eq) (ref eq) (ref eq) (ref eq)) (result (ref eq)))) + (type $closure_3 + (sub $closure + (struct (field (ref $function_1)) (field (ref $function_3))))) + + ;; Effect types + + (tag $effect (param (ref eq)) (result (ref eq) (ref eq))) + + (type $cont_function (func (param (ref eq) (ref eq)) (result (ref eq)))) + + (type $cont (cont $cont_function)) + + (type $handlers + (struct + (field $value (ref eq)) + (field $exn (ref eq)) + (field $effect (ref eq)))) + + (type $fiber + (struct + (field $handlers (mut (ref $handlers))) + (field $cont (ref $cont)))) + + ;; Unhandled effects + + (@string $effect_unhandled "Effect.Unhandled") + + (func $raise_unhandled + (param $eff (ref eq)) (param (ref eq)) (result (ref eq)) + (block $null + (call $caml_raise_with_arg + (br_on_null $null + (call $caml_named_value (global.get $effect_unhandled))) + (local.get $eff))) + (call $caml_raise_constant + (array.new_fixed $block 3 (ref.i31 (i32.const 248)) + (global.get $effect_unhandled) + (call $caml_fresh_oo_id (ref.i31 (i32.const 0))))) + (ref.i31 (i32.const 0))) + + (global $raise_unhandled (ref $closure) + (struct.new $closure (ref.func $raise_unhandled))) + + (type $func (func (result (ref eq)))) + (type $wrapper_func (func (param (ref $func)))) + (type $func_closure (struct (field (ref $func)))) + + (func $wrapper_cont + (param $f (ref eq)) (param (ref eq)) (result (ref eq)) + (return_call_ref $func + (local.get $f) + (struct.get $func_closure 0 + (ref.cast (ref $func_closure) (local.get $f))))) + + (func $unhandled_effect_wrapper (param $start (ref $func)) + (local $cont (ref $cont)) + (local $f (ref eq)) (local $v (ref eq)) + (local $resume_res (tuple (ref eq) (ref $cont))) + (local.set $cont (cont.new $cont (ref.func $wrapper_cont))) + (local.set $f (struct.new $func_closure (local.get $start))) + (local.set $v (ref.i31 (i32.const 0))) + (loop $loop + (local.set $resume_res + (block $handle_effect (result (ref eq) (ref $cont)) + (resume $cont (on $effect $handle_effect) + (local.get $f) (local.get $v) (local.get $cont)) + (return))) + (local.set $cont (tuple.extract 2 1 (local.get $resume_res))) + (local.set $v (tuple.extract 2 0 (local.get $resume_res))) + (local.set $f (global.get $raise_unhandled)) + (br $loop))) + + (func $init + (global.set $caml_main_wrapper (ref.func $unhandled_effect_wrapper))) + + (start $init) + + ;; Resume + + (@string $already_resumed "Effect.Continuation_already_resumed") + + (func $resume (export "%resume") + (param $vfiber (ref eq)) (param $f (ref eq)) (param $v (ref eq)) + (param $tail (ref eq)) (result (ref eq)) + (local $fiber (ref $fiber)) + (local $res (ref eq)) + (local $exn (ref eq)) + (local $resume_res (tuple (ref eq) (ref $cont))) + (if (ref.eq (local.get $vfiber) (ref.i31 (i32.const 0))) + (then + (call $caml_raise_constant + (ref.as_non_null + (call $caml_named_value (global.get $already_resumed)))))) + (local.set $fiber (ref.cast (ref $fiber) (local.get $vfiber))) + (local.set $exn + (block $handle_exception (result (ref eq)) + (local.set $resume_res + (block $handle_effect (result (ref eq) (ref $cont)) + (local.set $res + (try (result (ref eq)) + (do + (resume $cont + (on $effect $handle_effect) + (local.get $f) (local.get $v) + (struct.get $fiber $cont (local.get $fiber)))) +(@if (not wasi) +(@then + (catch $javascript_exception + (br $handle_exception + (call $caml_wrap_exception (pop externref)))) +)) + (catch $ocaml_exception + (br $handle_exception (pop (ref eq)))))) + ;; handle return + (return_call_ref $function_1 (local.get $res) + (local.tee $f + (struct.get $handlers $value + (struct.get $fiber $handlers (local.get $fiber)))) + (struct.get $closure 0 + (ref.cast (ref $closure) (local.get $f)))))) + ;; handle effect + (return_call_ref $function_3 + (tuple.extract 2 0 (local.get $resume_res)) + (array.new_fixed $block 3 (ref.i31 (global.get $cont_tag)) + (struct.new $fiber + (struct.get $fiber $handlers (local.get $fiber)) + (tuple.extract 2 1 (local.get $resume_res))) + (ref.i31 (i32.const 0))) + (local.get $tail) + (local.tee $f + (struct.get $handlers $effect + (struct.get $fiber $handlers (local.get $fiber)))) + (struct.get $closure_3 1 + (ref.cast (ref $closure_3) (local.get $f)))))) + ;; handle exception + (return_call_ref $function_1 (local.get $exn) + (local.tee $f + (struct.get $handlers $exn + (struct.get $fiber $handlers (local.get $fiber)))) + (struct.get $closure 0 (ref.cast (ref $closure) (local.get $f))))) + + ;; Perform + + (func (export "%reperform") + (param $eff (ref eq)) (param $cont (ref eq)) (param $tail (ref eq)) + (result (ref eq)) + (local $res (tuple (ref eq) (ref eq))) + (local.set $res (suspend $effect (local.get $eff))) + (return_call $resume + (ref.as_non_null + (array.get $block + (ref.cast (ref $block) (local.get $cont)) + (i32.const 1))) + (tuple.extract 2 0 (local.get $res)) + (tuple.extract 2 1 (local.get $res)) + (local.get $tail))) + + (func (export "%perform") (param $eff (ref eq)) (result (ref eq)) + (local $res (tuple (ref eq) (ref eq))) + (if (i32.eqz (global.get $effect_allowed)) + (then + (return_call $raise_unhandled + (local.get $eff) (ref.i31 (i32.const 0))))) + (local.set $res (suspend $effect (local.get $eff))) + (return_call_ref $function_1 (tuple.extract 2 1 (local.get $res)) + (tuple.extract 2 0 (local.get $res)) + (struct.get $closure 0 + (ref.cast (ref $closure) (tuple.extract 2 0 (local.get $res)))))) + + ;; Allocate a stack + + (func $initial_cont + (param $f (ref eq)) (param $x (ref eq)) (result (ref eq)) + (return_call_ref $function_1 (local.get $x) + (local.get $f) + (struct.get $closure 0 (ref.cast (ref $closure) (local.get $f))))) + + (func (export "caml_alloc_stack") + (param $hv (ref eq)) (param $hx (ref eq)) (param $hf (ref eq)) + (result (ref eq)) + (struct.new $fiber + (struct.new $handlers (local.get $hv) (local.get $hx) (local.get $hf)) + (cont.new $cont (ref.func $initial_cont)))) + + ;; Other functions + + (func $caml_continuation_use_noexc (export "caml_continuation_use_noexc") + (param (ref eq)) (result (ref eq)) + (local $cont (ref $block)) + (local $stack (ref eq)) + (drop (block $used (result (ref eq)) + (local.set $cont (ref.cast (ref $block) (local.get 0))) + (local.set $stack + (br_on_cast_fail $used (ref eq) (ref $fiber) + (array.get $block (local.get $cont) (i32.const 1)))) + (array.set $block (local.get $cont) (i32.const 1) + (ref.i31 (i32.const 0))) + (return (local.get $stack)))) + (ref.i31 (i32.const 0))) + + (func (export "caml_continuation_use_and_update_handler_noexc") + (param $cont (ref eq)) (param $hval (ref eq)) (param $hexn (ref eq)) + (param $heff (ref eq)) (result (ref eq)) + (local $stack (ref eq)) + (local.set $stack (call $caml_continuation_use_noexc (local.get $cont))) + (drop (block $used (result (ref eq)) + (struct.set $fiber $handlers + (br_on_cast_fail $used (ref eq) (ref $fiber) + (local.get $stack)) + (struct.new $handlers + (local.get $hval) (local.get $hexn) (local.get $heff))) + (ref.i31 (i32.const 0)))) + (local.get $stack)) +)) +) diff --git a/runtime/wasm/effect.wat b/runtime/wasm/effect.wat index d0443d17e9..4d144bdae4 100644 --- a/runtime/wasm/effect.wat +++ b/runtime/wasm/effect.wat @@ -84,7 +84,7 @@ (call $caml_fresh_oo_id (ref.i31 (i32.const 0))))) (ref.i31 (i32.const 0))) - (global $effect_allowed (mut i32) (i32.const 1)) + (global $effect_allowed (export "effect_allowed") (mut i32) (i32.const 1)) (@if (not wasi) (@then @@ -366,7 +366,6 @@ (struct.new $handlers (local.get $hv) (local.get $hx) (local.get $hf)) (struct.new $cont (ref.func $initial_cont)) (ref.null $fiber))) -)) ;; Other functions @@ -397,6 +396,7 @@ (local.get $hval) (local.get $hexn) (local.get $heff))) (ref.i31 (i32.const 0)))) (local.get $stack)) +)) (func (export "caml_get_continuation_callstack") (param (ref eq) (ref eq)) (result (ref eq)) diff --git a/runtime/wasm/stdlib.wat b/runtime/wasm/stdlib.wat index 12c21652d5..3686074745 100644 --- a/runtime/wasm/stdlib.wat +++ b/runtime/wasm/stdlib.wat @@ -214,6 +214,11 @@ (call $caml_main (ref.func $reraise_exception))) )) + (type $wrapper_func (func (param (ref $func)))) + (global $caml_main_wrapper (export "caml_main_wrapper") + (mut (ref null $wrapper_func)) + (ref.null $wrapper_func)) + (func $caml_main (export "caml_main") (param $start (ref func)) (local $exn (ref eq)) (local $msg (ref eq)) @@ -226,6 +231,11 @@ )) (try (do + (block $fallback + (call_ref $wrapper_func + (ref.cast (ref $func) (local.get $start)) + (br_on_null $fallback (global.get $caml_main_wrapper))) + (return)) (drop (call_ref $func (ref.cast (ref $func) (local.get $start))))) (catch $ocaml_exit) (catch $ocaml_exception