Merge pull request #136 from ocaml-wasm/5.3

vouillon · web-flow · commit 8fd1de5ed770 · 2024-12-04T10:28:20.000+01:00
Updates for OCaml 5.3
diff --git a/.github/workflows/build-wasm_of_ocaml.yml b/.github/workflows/build-wasm_of_ocaml.yml
@@ -20,6 +20,7 @@ jobs:
           - 5.00.x
           - 5.01.x
           - 5.02.x
+          - ocaml-compiler.5.3.0~beta2
         separate_compilation:
           - true
         include:
diff --git a/compiler/lib-wasm/generate.ml b/compiler/lib-wasm/generate.ml
@@ -1168,9 +1168,13 @@ end
 
 let init () =
   let l =
-    [ "caml_ensure_stack_capacity", "%identity"; "caml_callback", "caml_trampoline" ]
+    [ "caml_ensure_stack_capacity", "%identity"
+    ; "caml_process_pending_actions_with_root", "%identity"
+    ; "caml_callback", "caml_trampoline"
+    ; "caml_make_array", "caml_array_of_uniform_array"
+    ]
   in
-  Primitive.register "caml_make_array" `Mutable None None;
+  Primitive.register "caml_array_of_uniform_array" `Mutable None None;
   let l =
     if Config.Flag.effects ()
     then ("caml_alloc_stack", "caml_cps_alloc_stack") :: l
diff --git a/compiler/lib/flow.ml b/compiler/lib/flow.ml
@@ -198,7 +198,9 @@ let rec block_escape st x =
             | Immutable -> ()
             | Maybe_mutable -> Code.Var.ISet.add st.possibly_mutable y);
             Array.iter l ~f:(fun z -> block_escape st z)
-        | Expr (Prim (Extern "caml_make_array", [ Pv y ])) -> block_escape st y
+        | Expr
+            (Prim (Extern ("caml_make_array" | "caml_array_of_uniform_array"), [ Pv y ]))
+          -> block_escape st y
         | _ -> Code.Var.ISet.add st.possibly_mutable y))
     (Var.Tbl.get st.known_origins x)
 
@@ -208,7 +210,7 @@ let expr_escape st _x e =
   | Apply { args; _ } -> List.iter args ~f:(fun x -> block_escape st x)
   | Prim (Array_get, [ Pv x; _ ]) -> block_escape st x
   | Prim ((Vectlength | Array_get | Not | IsInt | Eq | Neq | Lt | Le | Ult), _) -> ()
-  | Prim (Extern "caml_make_array", [ Pv _ ]) -> ()
+  | Prim (Extern ("caml_make_array" | "caml_array_of_uniform_array"), [ Pv _ ]) -> ()
   | Prim (Extern name, l) ->
       let ka =
         match Primitive.kind_args name with
@@ -233,7 +235,10 @@ let expr_escape st _x e =
                 | Expr (Constant (Tuple _)) -> ()
                 | Expr (Block (_, a, _, _)) ->
                     Array.iter a ~f:(fun x -> block_escape st x)
-                | Expr (Prim (Extern "caml_make_array", [ Pv y ])) -> (
+                | Expr
+                    (Prim
+                      ( Extern ("caml_make_array" | "caml_array_of_uniform_array")
+                      , [ Pv y ] )) -> (
                     match st.defs.(Var.idx y) with
                     | Expr (Block (_, a, _, _)) ->
                         Array.iter a ~f:(fun x -> block_escape st x)
@@ -416,7 +421,7 @@ let the_native_string_of ~target info x =
 let the_block_contents_of info x =
   match the_def_of info x with
   | Some (Block (_, a, _, _)) -> Some a
-  | Some (Prim (Extern "caml_make_array", [ x ])) -> (
+  | Some (Prim (Extern ("caml_make_array" | "caml_array_of_uniform_array"), [ x ])) -> (
       match the_def_of info x with
       | Some (Block (_, a, _, _)) -> Some a
       | _ -> None)
diff --git a/dune-project b/dune-project
@@ -139,7 +139,7 @@
  (description
   "Wasm_of_ocaml is a compiler from OCaml bytecode to WebAssembly. It makes it possible to run pure OCaml programs in JavaScript environment like browsers and Node.js")
  (depends
-  (ocaml (and (>= 4.14) (< 5.3)))
+  (ocaml (>= 4.14))
   (js_of_ocaml (= :version))
   (num :with-test)
   (ppx_expect (and (>= v0.14.2) :with-test))
diff --git a/ppx/ppx_js/tests/dune b/ppx/ppx_js/tests/dune
@@ -7,14 +7,18 @@
 (rule
  (targets ppx.mlt.corrected)
  (enabled_if
-  (>= %{ocaml_version} 5.2))
+  (and
+   (>= %{ocaml_version} 5.2)
+   (< %{ocaml_version} 5.3)))
  (action
   (run %{exe:main.bc} %{dep:ppx.mlt})))
 
 (rule
  (alias runtest)
  (package js_of_ocaml-ppx)
  (enabled_if
-  (>= %{ocaml_version} 5.2))
+  (and
+   (>= %{ocaml_version} 5.2)
+   (< %{ocaml_version} 5.3)))
  (action
   (diff ppx.mlt ppx.mlt.corrected)))
diff --git a/runtime/wasm/array.wat b/runtime/wasm/array.wat
@@ -29,7 +29,7 @@
    (global $empty_array (ref eq)
       (array.new_fixed $block 1 (ref.i31 (i32.const 0))))
 
-   (func $caml_make_vect (export "caml_make_vect")
+   (func $caml_make_vect (export "caml_make_vect") (export "caml_array_make")
       (param $n (ref eq)) (param $v (ref eq)) (result (ref eq))
       (local $sz i32) (local $b (ref $block)) (local $f f64)
       (local.set $sz (i31.get_s (ref.cast (ref i31) (local.get $n))))
@@ -51,8 +51,24 @@
       (array.set $block (local.get $b) (i32.const 0) (ref.i31 (i32.const 0)))
       (local.get $b))
 
-   (export "caml_make_float_vect" (func $caml_floatarray_create))
-   (func $caml_floatarray_create (export "caml_floatarray_create")
+   (func (export "caml_floatarray_make")
+      (param $n (ref eq)) (param $v (ref eq)) (result (ref eq))
+      (local $sz i32) (local $f f64)
+      (local.set $sz (i31.get_s (ref.cast (ref i31) (local.get $n))))
+      (if (i32.lt_s (local.get $sz) (i32.const 0))
+         (then
+            (call $caml_invalid_argument
+               (array.new_data $string $Array_make
+                               (i32.const 0) (i32.const 10)))))
+      (if (i32.eqz (local.get $sz)) (then (return (global.get $empty_array))))
+      (local.set $f
+         (struct.get $float 0
+            (ref.cast (ref $float) (local.get $v))))
+      (array.new $float_array (local.get $f) (local.get $sz)))
+
+   (func $caml_floatarray_create
+      (export "caml_make_float_vect") (export "caml_floatarray_create")
+      (export "caml_array_create_float")
       (param $n (ref eq)) (result (ref eq))
       (local $sz i32)
       (local.set $sz (i31.get_s (ref.cast (ref i31) (local.get $n))))
@@ -64,7 +80,8 @@
       (if (i32.eqz (local.get $sz)) (then (return (global.get $empty_array))))
       (array.new $float_array (f64.const 0) (local.get $sz)))
 
-   (func (export "caml_make_array") (param $vinit (ref eq)) (result (ref eq))
+   (func (export "caml_array_of_uniform_array")
+      (param $vinit (ref eq)) (result (ref eq))
       (local $init (ref $block)) (local $res (ref $float_array))
       (local $size i32) (local $i i32)
       (local.set $init (ref.cast (ref $block) (local.get $vinit)))
@@ -130,6 +147,21 @@
          (local.get $len))
       (local.get $fa2))
 
+   (func (export "caml_floatarray_sub")
+      (param $a (ref eq)) (param $i (ref eq)) (param $vlen (ref eq))
+      (result (ref eq))
+      (local $len i32)
+      (local $fa1 (ref $float_array)) (local $fa2 (ref $float_array))
+      (local.set $len (i31.get_u (ref.cast (ref i31) (local.get $vlen))))
+      (if (i32.eqz (local.get $len)) (then (return (global.get $empty_array))))
+      (local.set $fa1 (ref.cast (ref $float_array) (local.get $a)))
+      (local.set $fa2 (array.new $float_array (f64.const 0) (local.get $len)))
+      (array.copy $float_array $float_array
+         (local.get $fa2) (i32.const 0) (local.get $fa1)
+         (i31.get_u (ref.cast (ref i31) (local.get $i)))
+         (local.get $len))
+      (local.get $fa2))
+
    (func $caml_floatarray_dup (param $a (ref $float_array)) (result (ref eq))
       (local $a' (ref $float_array))
       (local $len i32)
@@ -188,6 +220,30 @@
          (return (local.get $fa))))
       (return_call $caml_floatarray_dup (local.get $fa1)))
 
+   (func (export "caml_floatarray_append")
+      (param $va1 (ref eq)) (param $va2 (ref eq)) (result (ref eq))
+      (local $fa1 (ref $float_array)) (local $fa2 (ref $float_array))
+      (local $fa (ref $float_array))
+      (local $l1 i32) (local $l2 i32)
+      (local.set $fa1 (ref.cast (ref $float_array) (local.get $va1)))
+      (drop (block $a2_not_float_array (result (ref eq))
+         (local.set $fa2
+            (br_on_cast_fail $a2_not_float_array (ref eq) (ref $float_array)
+               (local.get $va2)))
+         (local.set $l1 (array.len (local.get $fa1)))
+         (local.set $l2 (array.len (local.get $fa2)))
+         (local.set $fa
+            (array.new $float_array (f64.const 0)
+               (i32.add (local.get $l1) (local.get $l2))))
+         (array.copy $float_array $float_array
+            (local.get $fa) (i32.const 0) (local.get $fa1) (i32.const 0)
+            (local.get $l1))
+         (array.copy $float_array $float_array
+            (local.get $fa) (local.get $l1) (local.get $fa2) (i32.const 0)
+            (local.get $l2))
+         (return (local.get $fa))))
+      (return_call $caml_floatarray_dup (local.get $fa1)))
+
    (func (export "caml_array_concat") (param (ref eq)) (result (ref eq))
       (local $i i32) (local $len i32)
       (local $l (ref eq)) (local $v (ref eq))
@@ -334,4 +390,18 @@
                (struct.get $float 0 (ref.cast (ref $float) (local.get $v)))
                (local.get $len))))
       (ref.i31 (i32.const 0)))
+
+   (func (export "caml_floatarray_fill")
+      (param $a (ref eq)) (param $i (ref eq)) (param $vlen (ref eq))
+      (param $v (ref eq)) (result (ref eq))
+      (local $len i32)
+      (local.set $len (i31.get_u (ref.cast (ref i31) (local.get $vlen))))
+      (if (local.get $len)
+         (then
+            (array.fill $float_array
+               (ref.cast (ref $float_array) (local.get $a))
+               (i31.get_u (ref.cast (ref i31) (local.get $i)))
+               (struct.get $float 0 (ref.cast (ref $float) (local.get $v)))
+               (local.get $len))))
+      (ref.i31 (i32.const 0)))
 )
diff --git a/runtime/wasm/domain.wat b/runtime/wasm/domain.wat
@@ -95,7 +95,8 @@
    (global $caml_domain_latest_id (export "caml_domain_latest_id") (mut i32)
       (i32.const 1))
 
-   (func (export "caml_ml_domain_id") (param (ref eq)) (result (ref eq))
+   (func (export "caml_ml_domain_id") (export "caml_ml_domain_index")
+      (param (ref eq)) (result (ref eq))
       (ref.i31 (global.get $caml_domain_id)))
 
    (func (export "caml_ml_domain_cpu_relax") (param (ref eq)) (result (ref eq))
diff --git a/runtime/wasm/md5.wat b/runtime/wasm/md5.wat
@@ -32,7 +32,7 @@
          (field (ref $int_array)) ;; buffer
          (field (ref $string))))  ;; intermediate buffer
 
-   (func (export "caml_md5_string")
+   (func (export "caml_md5_string") (export "caml_md5_bytes")
       (param (ref eq)) (param (ref eq)) (param (ref eq)) (result (ref eq))
       (local $ctx (ref $context))
       (local.set $ctx (call $MD5Init))
diff --git a/runtime/wasm/runtime_events.wat b/runtime/wasm/runtime_events.wat
@@ -62,4 +62,8 @@
    (func (export "caml_runtime_events_read_poll")
       (param (ref eq)) (param (ref eq)) (param (ref eq)) (result (ref eq))
       (ref.i31 (i32.const 0)))
+
+   (func (export "caml_ml_runtime_events_path")
+      (param (ref eq)) (result (ref eq))
+      (ref.i31 (i32.const 0)))
 )
diff --git a/wasm_of_ocaml-compiler.opam b/wasm_of_ocaml-compiler.opam
@@ -13,7 +13,7 @@ doc: "https://ocsigen.org/js_of_ocaml/latest/manual/overview"
 bug-reports: "https://github.com/ocsigen/js_of_ocaml/issues"
 depends: [
   "dune" {>= "3.17"}
-  "ocaml" {>= "4.14" & < "5.3"}
+  "ocaml" {>= "4.14"}
   "js_of_ocaml" {= version}
   "num" {with-test}
   "ppx_expect" {>= "v0.14.2" & with-test}

Original file line number	Diff line number	Diff line change
`@@ -62,4 +62,8 @@`
`62`	`62`	`(func (export "caml_runtime_events_read_poll")`
`63`	`63`	`(param (ref eq)) (param (ref eq)) (param (ref eq)) (result (ref eq))`
`64`	`64`	`(ref.i31 (i32.const 0)))`
	`65`	`+`
	`66`	`+ (func (export "caml_ml_runtime_events_path")`
	`67`	`+ (param (ref eq)) (result (ref eq))`
	`68`	`+ (ref.i31 (i32.const 0)))`
`65`	`69`	`)`