Merge pull request #58 from ocaml-wasm/named-value

Fix implementation of caml_register_named_value

Author: vouillon

compiler/tests-jsoo/bin/dune

@@ -1,6 +1,11 @@
 (executables
  (names error1 error2 error3)
- (modes js)
+ (modes exe js)
+ (foreign_stubs
+  (language c)
+  (names named_value_stubs))
+ (js_of_ocaml
+  (javascript_files runtime.js))
  (libraries js_of_ocaml))
 
 (rule

compiler/tests-jsoo/bin/named_value_stubs.c

@@ -0,0 +1,5 @@
+#include "caml/mlvalues.h"
+
+CAMLprim value caml_unregister_named_value(value nm) {
+   return Val_unit;
+}

compiler/tests-jsoo/bin/runtime.js

@@ -0,0 +1,7 @@
+//Provides: caml_unregister_named_value (const)
+//Requires: caml_named_values, caml_jsbytes_of_string
+function caml_unregister_named_value(nm) {
+  nm = caml_jsbytes_of_string(nm);
+  delete caml_named_values[nm];
+  return 0;
+}

runtime/stdlib.js

@@ -131,16 +131,7 @@ var caml_named_values = {};
 //Provides: caml_register_named_value (const,mutable)
 //Requires: caml_named_values, caml_jsbytes_of_string
 function caml_register_named_value(nm,v) {
-  nm = caml_jsbytes_of_string(nm);
-  if (!caml_named_values.hasOwnProperty(nm)) caml_named_values[nm] = v;
-  return 0;
-}
-
-//Provides: caml_unregister_named_value (const)
-//Requires: caml_named_values, caml_jsbytes_of_string
-function caml_unregister_named_value(nm) {
-  nm = caml_jsbytes_of_string(nm);
-  delete caml_named_values[nm];
+  caml_named_values[caml_jsbytes_of_string(nm)] = v;
   return 0;
 }
 

runtime/wasm/stdlib.wat

@@ -51,7 +51,7 @@
    (type $assoc
       (struct
          (field (ref $string))
-         (field (ref eq))
+         (field (mut (ref eq)))
          (field (mut (ref null $assoc)))))
 
    (type $assoc_array (array (field (mut (ref null $assoc)))))
@@ -62,9 +62,9 @@
      (array.new $assoc_array (ref.null $assoc) (global.get $Named_value_size)))
 
    (func $find_named_value
-      (param $s (ref eq)) (param $l (ref null $assoc)) (result (ref null eq))
+      (param $s (ref eq)) (param $l (ref null $assoc)) (result (ref null $assoc))
       (local $a (ref $assoc))
-      (block $tail (result (ref null eq))
+      (block $tail (result (ref null $assoc))
          (loop $loop
             (local.set $a
                (br_on_cast_fail $tail (ref null eq) (ref $assoc) (local.get $l)))
@@ -74,21 +74,26 @@
                           (local.get $s)
                           (struct.get $assoc 0 (local.get $a)))))
                (then
-                  (return (struct.get $assoc 1 (local.get $a)))))
+                  (return (local.get $a))))
             (local.set $l (struct.get $assoc 2 (local.get $a)))
             (br $loop))))
 
    (func $caml_named_value (export "caml_named_value")
       (param $s (ref $string)) (result (ref null eq))
-      (return_call $find_named_value
-         (local.get $s)
-         (array.get $assoc_array (global.get $named_value_table)
-            (i32.rem_u
-               (i31.get_s
-                  (ref.cast (ref i31)
-                     (call $caml_string_hash
-                        (ref.i31 (i32.const 0)) (local.get $s))))
-               (global.get $Named_value_size)))))
+      (block $not_found
+         (return
+            (struct.get $assoc 1
+               (br_on_null $not_found
+                  (call $find_named_value
+                     (local.get $s)
+                     (array.get $assoc_array (global.get $named_value_table)
+                        (i32.rem_u
+                           (i31.get_s
+                              (ref.cast (ref i31)
+                                 (call $caml_string_hash
+                                    (ref.i31 (i32.const 0)) (local.get $s))))
+                           (global.get $Named_value_size))))))))
+      (return (ref.null eq)))
 
    (func (export "caml_register_named_value")
       (param (ref eq)) (param (ref eq)) (result (ref eq))
@@ -104,15 +109,20 @@
       (local.set $r
          (array.get $assoc_array
             (global.get $named_value_table) (local.get $h)))
-      (if (ref.is_null (call $find_named_value (local.get 0) (local.get $r)))
-         (then
-            (array.set $assoc_array
-               (global.get $named_value_table) (local.get $h)
-               (struct.new $assoc
-                  (ref.cast (ref $string) (local.get 0))
-                  (local.get 1) (local.get $r)))))
+      (block $not_found
+         (struct.set $assoc 1
+            (br_on_null $not_found
+               (call $find_named_value (local.get 0) (local.get $r)))
+            (local.get 1))
+         (return (ref.i31 (i32.const 0))))
+      (array.set $assoc_array
+         (global.get $named_value_table) (local.get $h)
+         (struct.new $assoc
+            (ref.cast (ref $string) (local.get 0))
+            (local.get 1) (local.get $r)))
       (ref.i31 (i32.const 0)))
 
+   ;; Used only for testing (tests-jsoo/bin), but inconvenient to pull out
    (func (export "caml_unregister_named_value")
       (param $name (ref eq)) (result (ref eq))
       (local $h i32)