Wasm runtime: additional primitives

Author: vouillon

runtime/wasm/array.wat

@@ -315,6 +315,90 @@
                    (br $fill))))
             (local.get $a))))
 
+   (func (export "caml_float_array_concat") (param (ref eq)) (result (ref eq))
+      (local $i i32) (local $len i32)
+      (local $l (ref eq)) (local $v (ref eq))
+      (local $b (ref $block))
+      (local $fa (ref $float_array)) (local $fa' (ref $float_array))
+      (local.set $l (local.get 0))
+      (local.set $len (i32.const 0))
+      (loop $compute_length
+         (drop (block $exit (result (ref eq))
+            (local.set $b
+               (br_on_cast_fail $exit (ref eq) (ref $block) (local.get $l)))
+            (local.set $v (array.get $block (local.get $b) (i32.const 1)))
+            (local.set $len
+               (i32.add (local.get $len)
+                  (array.len (ref.cast (ref $float_array) (local.get $v)))))
+            (local.set $l (array.get $block (local.get $b) (i32.const 2)))
+            (br $compute_length))))
+      (local.set $fa
+         (array.new $float_array (f64.const 0) (local.get $len)))
+      (local.set $l (local.get 0))
+      (local.set $i (i32.const 0))
+      (loop $fill
+         (drop (block $exit (result (ref eq))
+             (local.set $b
+                (br_on_cast_fail $exit (ref eq) (ref $block)
+                   (local.get $l)))
+             (local.set $l (array.get $block (local.get $b) (i32.const 2)))
+             (drop (block $not_float (result (ref eq))
+                (local.set $fa'
+                   (br_on_cast_fail $not_float (ref eq) (ref $float_array)
+                      (array.get $block (local.get $b) (i32.const 1))))
+                (local.set $len (array.len (local.get $fa')))
+                (array.copy $float_array $float_array
+                   (local.get $fa) (local.get $i)
+                   (local.get $fa') (i32.const 0)
+                   (local.get $len))
+                (local.set $i (i32.add (local.get $i) (local.get $len)))
+                (br $fill)))
+             (br $fill))))
+      (local.get $fa))
+
+   (func (export "caml_uniform_array_concat") (param (ref eq)) (result (ref eq))
+      (local $i i32) (local $len i32)
+      (local $l (ref eq)) (local $v (ref eq))
+      (local $b (ref $block))
+      (local $a (ref $block)) (local $a' (ref $block))
+      (local.set $l (local.get 0))
+      (local.set $len (i32.const 0))
+      (loop $compute_length
+         (drop (block $exit (result (ref eq))
+            (local.set $b
+               (br_on_cast_fail $exit (ref eq) (ref $block) (local.get $l)))
+            (local.set $v (array.get $block (local.get $b) (i32.const 1)))
+            (local.set $len
+               (i32.add (local.get $len)
+                  (i32.sub
+                     (array.len (ref.cast (ref $block) (local.get $v)))
+                     (i32.const 1))))
+            (local.set $l (array.get $block (local.get $b) (i32.const 2)))
+            (br $compute_length))))
+      (local.set $a
+         (array.new $block (ref.i31 (i32.const 0))
+            (i32.add (local.get $len) (i32.const 1))))
+      (local.set $l (local.get 0))
+      (local.set $i (i32.const 1))
+      (loop $fill
+         (drop (block $exit (result (ref eq))
+             (local.set $b
+                (br_on_cast_fail $exit (ref eq) (ref $block)
+                   (local.get $l)))
+             (local.set $a'
+                (ref.cast (ref $block)
+                   (array.get $block (local.get $b) (i32.const 1))))
+             (local.set $len
+                (i32.sub (array.len (local.get $a')) (i32.const 1)))
+             (array.copy $block $block
+                (local.get $a) (local.get $i)
+                (local.get $a') (i32.const 1)
+                (local.get $len))
+             (local.set $i (i32.add (local.get $i) (local.get $len)))
+             (local.set $l (array.get $block (local.get $b) (i32.const 2)))
+             (br $fill))))
+      (local.get $a))
+
    (func $caml_floatarray_blit (export "caml_floatarray_blit")
       (param $a1 (ref eq)) (param $i1 (ref eq))
       (param $a2 (ref eq)) (param $i2 (ref eq))

runtime/wasm/domain.wat

@@ -38,9 +38,31 @@
          (else
             (ref.i31 (i32.const 0)))))
 
+   (func (export "caml_atomic_cas_field")
+      (param $ref (ref eq)) (param $i (ref eq)) (param $o (ref eq))
+      (param $n (ref eq)) (result (ref eq))
+      (local $b (ref $block))
+      (local $j i32)
+      (local.set $j
+         (i32.add (i31.get_u (ref.cast (ref i31) (local.get $i))) (i32.const 1)))
+      (local.set $b (ref.cast (ref $block) (local.get $ref)))
+      (if (result (ref eq))
+         (ref.eq (array.get $block (local.get $b) (local.get $j))
+                 (local.get $o))
+         (then
+            (array.set $block (local.get $b) (local.get $j) (local.get $n))
+            (ref.i31 (i32.const 1)))
+         (else
+            (ref.i31 (i32.const 0)))))
+
    (func (export "caml_atomic_load") (param (ref eq)) (result (ref eq))
       (array.get $block (ref.cast (ref $block) (local.get 0)) (i32.const 1)))
 
+   (func (export "caml_atomic_load_field")
+      (param $b (ref eq)) (param $i (ref eq)) (result (ref eq))
+      (array.get $block (ref.cast (ref $block) (local.get $b))
+        (i32.add (i31.get_u (ref.cast (ref i31) (local.get $i))) (i32.const 1))))
+
    (func (export "caml_atomic_fetch_add")
       (param $ref (ref eq)) (param $i (ref eq)) (result (ref eq))
       (local $b (ref $block))
@@ -52,6 +74,21 @@
                            (i31.get_s (ref.cast (ref i31) (local.get $i))))))
       (local.get $old))
 
+   (func (export "caml_atomic_fetch_add_field")
+      (param $ref (ref eq)) (param $i (ref eq)) (param $n (ref eq))
+      (result (ref eq))
+      (local $b (ref $block))
+      (local $old (ref eq))
+      (local $j i32)
+      (local.set $j
+         (i32.add (i31.get_u (ref.cast (ref i31) (local.get $i))) (i32.const 1)))
+      (local.set $b (ref.cast (ref $block) (local.get $ref)))
+      (local.set $old (array.get $block (local.get $b) (local.get $j)))
+      (array.set $block (local.get $b) (local.get $j)
+         (ref.i31 (i32.add (i31.get_s (ref.cast (ref i31) (local.get $old)))
+                           (i31.get_s (ref.cast (ref i31) (local.get $n))))))
+      (local.get $old))
+
    (func (export "caml_atomic_exchange")
       (param $ref (ref eq)) (param $v (ref eq)) (result (ref eq))
       (local $b (ref $block))
@@ -61,6 +98,19 @@
       (array.set $block (local.get $b) (i32.const 1) (local.get $v))
       (local.get $r))
 
+   (func (export "caml_atomic_exchange_field")
+      (param $ref (ref eq)) (param $i (ref eq)) (param $v (ref eq))
+      (result (ref eq))
+      (local $b (ref $block))
+      (local $r (ref eq))
+      (local $j i32)
+      (local.set $j
+         (i32.add (i31.get_u (ref.cast (ref i31) (local.get $i))) (i32.const 1)))
+      (local.set $b (ref.cast (ref $block) (local.get $ref)))
+      (local.set $r (array.get $block (local.get $b) (local.get $j)))
+      (array.set $block (local.get $b) (local.get $j) (local.get $v))
+      (local.get $r))
+
    (func (export "caml_atomic_make_contended")
       (param $v (ref eq)) (result (ref eq))
       (array.new_fixed $block 2 (ref.i31 (i32.const 0)) (local.get $v)))

runtime/wasm/fs.wat

@@ -16,11 +16,13 @@
 ;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
 (module
+   (import "bindings" "on_windows" (global $on_windows i32))
    (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" "rmdir" (func $rmdir (param anyref)))
    (import "bindings" "unlink" (func $unlink (param anyref)))
+   (import "bindings" "tmpdir" (func $tmpdir (result anyref)))
    (import "bindings" "read_dir"
       (func $read_dir (param anyref) (result (ref extern))))
    (import "bindings" "file_exists"
@@ -172,6 +174,12 @@
             (call $caml_handle_sys_error (pop externref))
             (return (ref.i31 (i32.const 0))))))
 
+   (func (export "caml_sys_temp_dir_name") (param (ref eq)) (result (ref eq))
+      (if (global.get $on_windows)
+         (then
+            (return_call $caml_string_of_jsstring (call $wrap (call $tmpdir)))))
+      (@string ""))
+
    (func (export "caml_mount_autoload")
       (param (ref eq) (ref eq)) (result (ref eq))
       (ref.i31 (i32.const 0)))

runtime/wasm/gc.wat

@@ -16,6 +16,10 @@
 ;; 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))))
+
    (type $float (struct (field f64)))
    (type $block (array (mut (ref eq))))
 
@@ -118,4 +122,12 @@
 
    (func (export "caml_eventlog_resume") (param (ref eq)) (result (ref eq))
       (ref.i31 (i32.const 0)))
+
+   (func (export "caml_ml_gc_ramp_up") (param $f (ref eq)) (result (ref eq))
+      (array.new_fixed $block 3 (ref.i31 (i32.const 0))
+         (call $caml_callback_1 (local.get $f) (ref.i31 (i32.const 0)))
+         (ref.i31 (i32.const 0))))
+
+   (func (export "caml_ml_gc_ramp_down") (param (ref eq)) (result (ref eq))
+      (ref.i31 (i32.const 0)))
 )

runtime/wasm/io.wat

@@ -260,6 +260,9 @@
             (call $caml_handle_sys_error (pop externref))))
       (ref.i31 (i32.const 0)))
 
+   (func (export "caml_sys_io_buffer_size") (param (ref eq)) (result (ref eq))
+      (ref.i31 (global.get $IO_BUFFER_SIZE)))
+
    (func (export "caml_ml_set_channel_name")
       (param (ref eq)) (param (ref eq)) (result (ref eq))
       (ref.i31 (i32.const 0)))

runtime/wasm/obj.wat

@@ -176,6 +176,26 @@
          (return (ref.i31 (i32.const 0)))))
       (unreachable))
 
+   (func (export "caml_alloc_dummy_lazy") (param (ref eq)) (result (ref eq))
+      (array.new_fixed $block 2 (ref.i31 (i32.const 0)) (ref.i31 (i32.const 0))))
+
+   (func (export "caml_update_dummy_lazy")
+      (param $dummy (ref eq)) (param $newval (ref eq)) (result (ref eq))
+      (local $tag i32)
+      (local $b (ref $block))
+      (local.set $tag
+         (i31.get_s (ref.cast (ref i31) (call $caml_obj_tag (local.get $newval)))))
+      (block $update
+         (br_if $update (i32.eq (local.get $tag) (global.get $lazy_tag)))
+         (br_if $update (i32.eq (local.get $tag) (global.get $forcing_tag)))
+         (br_if $update (i32.eq (local.get $tag) (global.get $forward_tag)))
+         (local.set $b (ref.cast (ref $block) (local.get $dummy)))
+         (array.set $block (local.get $b) (i32.const 0)
+            (ref.i31 (global.get $forward_tag)))
+         (array.set $block (local.get $b) (i32.const 1) (local.get $newval))
+         (return (ref.i31 (i32.const 0))))
+     (return_call $caml_update_dummy (local.get $dummy) (local.get $newval)))
+
    (func $caml_obj_dup (export "caml_obj_dup")
       (param (ref eq)) (result (ref eq))
       (local $orig (ref $block)) (local $res (ref $block))

runtime/wasm/runtime.js

@@ -538,6 +538,7 @@
       }
       fs.renameSync(o, n);
     },
+    tmpdir: () => require("node:os").tmpdir(),
     start_fiber: (x) => start_fiber(x),
     suspend_fiber: make_suspending((f, env) => new Promise((k) => f(k, env))),
     resume_fiber: (k, v) => k(v),

runtime/wasm/sys.wat

@@ -78,6 +78,18 @@
             (call $caml_raise_not_found)))
       (return_call $caml_string_of_jsstring (call $wrap (local.get $res))))
 
+   (func (export "caml_sys_getenv_opt")
+      (param (ref eq)) (result (ref eq))
+      (local $res anyref)
+      (local.set $res
+         (call $getenv
+            (call $unwrap (call $caml_jsstring_of_string (local.get 0)))))
+      (if (i32.eqz (call $jsstring_test (local.get $res)))
+         (then
+            (return (ref.i31 (i32.const 0)))))
+      (array.new_fixed $block 2 (ref.i31 (i32.const 0))
+         (call $caml_string_of_jsstring (call $wrap (local.get $res)))))
+
    (func (export "caml_sys_argv") (param (ref eq)) (result (ref eq))
       ;; ZZZ
       (call $caml_js_to_string_array (call $argv)))
@@ -179,6 +191,14 @@
       (param (ref eq) (ref eq)) (result (ref eq))
       (ref.i31 (i32.const 0)))
 
+   (func (export "caml_sys_convert_signal_number")
+      (param $signo (ref eq)) (result (ref eq))
+      (local.get $signo))
+
+   (func (export "caml_sys_rev_convert_signal_number")
+      (param $signo (ref eq)) (result (ref eq))
+      (local.get $signo))
+
    (global $caml_runtime_warnings (mut i32) (i32.const 0))
 
    (func (export "caml_ml_enable_runtime_warnings")