Merge pull request #113 from ocaml-wasm/caml-make-array

 Fix creation of float arrays

Author: vouillon

compiler/lib/wasm/wa_generate.ml

@@ -1148,10 +1148,7 @@ end
 
 let init () =
   let l =
-    [ "caml_make_array", "%identity"
-    ; "caml_ensure_stack_capacity", "%identity"
-    ; "caml_callback", "caml_trampoline"
-    ]
+    [ "caml_ensure_stack_capacity", "%identity"; "caml_callback", "caml_trampoline" ]
   in
 
   let l =

compiler/tests-wasm_of_ocaml/dune

@@ -1,5 +1,5 @@
 (executables
- (names gh38 gh46 gh107)
+ (names gh38 gh46 gh107 gh112)
  (modes js)
  (js_of_ocaml
   (flags :standard --disable optcall --no-inline)))
@@ -33,3 +33,13 @@
   (with-outputs-to
    %{target}
    (run node %{dep:gh107.bc.js}))))
+
+(rule
+ (target gh112.actual)
+ (enabled_if
+  (= %{profile} wasm))
+ (alias runtest)
+ (action
+  (with-outputs-to
+   %{target}
+   (run node %{dep:gh112.bc.js}))))

compiler/tests-wasm_of_ocaml/gh112.ml

@@ -0,0 +1,49 @@
+let construct x = [| x |]
+
+let get (x : float array) = x.(0)
+
+let get_ (x : _ array) = x.(0)
+
+let set (x : float array) e = x.(0) <- e
+
+let set_ (x : _ array) e = x.(0) <- e
+
+let a = construct 1.0
+
+let _ = set a 2.0
+
+let _ = assert (Float.equal (get a) 2.0)
+
+let _ = assert (Float.equal (get_ a) 2.0)
+
+let _ = set_ a 3.0
+
+let _ = assert (Float.equal (get a) 3.0)
+
+let _ = assert (Float.equal (get_ a) 3.0)
+
+let b = [| 1.0 |]
+
+let _ = set b 2.0
+
+let _ = assert (Float.equal (get b) 2.0)
+
+let _ = assert (Float.equal (get_ b) 2.0)
+
+let _ = set_ b 3.0
+
+let _ = assert (Float.equal (get b) 3.0)
+
+let _ = assert (Float.equal (get_ b) 3.0)
+
+let construct2 x = [| x; x |]
+
+let c = construct2 1.
+
+let _ = assert (Float.equal c.(0) 1. && Float.equal c.(1) 1.)
+
+let _ = c.(1) <- 2.
+
+let _ = assert (Array.length c = 2)
+
+let _ = assert (Float.equal c.(0) 1. && Float.equal c.(1) 2.)

runtime/wasm/array.wat

@@ -64,6 +64,30 @@
       (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))
+      (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)))
+      (local.set $size (array.len (local.get $init)))
+      (if (i32.ne (local.get $size) (i32.const 1))
+         (then
+            (if (ref.test (ref $float)
+                   (array.get $block (local.get $init) (i32.const 1)))
+               (then
+                  (local.set $size (i32.sub (local.get $size) (i32.const 1)))
+                  (local.set $res
+                     (array.new $float_array (f64.const 0) (local.get $size)))
+                  (loop $loop
+                     (array.set $float_array (local.get $res) (local.get $i)
+                        (struct.get $float 0
+                           (ref.cast (ref $float)
+                              (array.get $block (local.get $init)
+                                 (i32.add (local.get $i) (i32.const 1))))))
+                     (local.set $i (i32.add (local.get $i) (i32.const 1)))
+                     (br_if $loop (i32.lt_u (local.get $i) (local.get $size))))
+                  (return (local.get $res))))))
+      (return (local.get $init)))
+
    (func (export "caml_floatarray_unsafe_get")
       (param $a (ref eq)) (param $i (ref eq)) (result (ref eq))
       (struct.new $float