Optimization of primitives: some improvements

CHANGES.md

@@ -22,6 +22,7 @@
 * Ppx: explicitly disallow polymorphic method (#1897)
 * Ppx: allow "function" in object literals (#1897)
 * Lib: make the Wasm version of Json.output work with native ints and JavaScript objects (#1872)
+* Compiler: static evaluation of more primitives (#1912)
 
 ## Bug fixes
 * Compiler: fix stack overflow issues with double translation (#1869)

compiler/lib-wasm/gc_target.ml

@@ -1395,10 +1395,9 @@ module JavaScript = struct
     return (W.Call (wrap, [ Call (f, args) ]))
 end
 
-let internal_primitives = Hashtbl.create 100
-
-let () =
-  let register name f = Hashtbl.add internal_primitives name f in
+let internal_primitives =
+  let l = ref [] in
+  let register name ?(kind = `Mutator) f = l := (name, kind, f) :: !l in
   let module J = Javascript in
   let call_prim ~transl_prim_arg name args =
     let arity = List.length args in
@@ -1409,8 +1408,8 @@ let () =
     let* args = expression_list Fun.id args in
     return (W.Call (f, args))
   in
-  let register_js_expr prim_name =
-    register prim_name (fun transl_prim_arg l ->
+  let register_js_expr (prim_name, kind) =
+    register prim_name ~kind (fun transl_prim_arg l ->
         match l with
         | Code.[ Pc (String str) ] -> (
             try
@@ -1445,7 +1444,11 @@ let () =
   in
   List.iter
     ~f:register_js_expr
-    [ "caml_js_expr"; "caml_pure_js_expr"; "caml_js_var"; "caml_js_eval_string" ];
+    [ "caml_js_expr", `Mutator
+    ; "caml_pure_js_expr", `Pure
+    ; "caml_js_var", `Mutable
+    ; "caml_js_eval_string", `Mutator
+    ];
   register "%caml_js_opt_call" (fun transl_prim_arg l ->
       let arity = List.length l - 2 in
       let name = Printf.sprintf "call_%d" arity in
@@ -1662,7 +1665,8 @@ let () =
               , AUnknown ))
       in
       let l = List.map ~f:transl_prim_arg vl in
-      JavaScript.invoke_fragment name l)
+      JavaScript.invoke_fragment name l);
+  !l
 
 let externref = W.Ref { nullable = true; typ = Extern }
 

compiler/lib-wasm/target_sig.ml

@@ -247,7 +247,10 @@ module type S = sig
   end
 
   val internal_primitives :
-    (string, (Code.prim_arg -> expression) -> Code.prim_arg list -> expression) Hashtbl.t
+    (string
+    * Primitive.kind
+    * ((Code.prim_arg -> expression) -> Code.prim_arg list -> expression))
+    list
 
   val handle_exceptions :
        result_typ:Wasm_ast.value_type list

compiler/lib-wasm/wat_output.ml

@@ -306,12 +306,20 @@ let remove_nops l = List.filter ~f:(fun i -> not (Poly.equal i Nop)) l
 
 let float64 _ f =
   match classify_float f with
-  | FP_normal | FP_subnormal | FP_zero | FP_nan -> Printf.sprintf "%h" f
+  | FP_normal | FP_subnormal | FP_zero -> Printf.sprintf "%h" f
+  | FP_nan ->
+      Printf.sprintf
+        "nan:0x%Lx"
+        Int64.(logand (bits_of_float f) (of_int ((1 lsl 52) - 1)))
   | FP_infinite -> if Float.(f > 0.) then "inf" else "-inf"
 
 let float32 _ f =
   match classify_float f with
-  | FP_normal | FP_subnormal | FP_zero | FP_nan -> Printf.sprintf "%h" f
+  | FP_normal | FP_subnormal | FP_zero -> Printf.sprintf "%h" f
+  | FP_nan ->
+      Printf.sprintf
+        "nan:0x%lx"
+        Int32.(logand (bits_of_float f) (of_int ((1 lsl 23) - 1)))
   | FP_infinite -> if Float.(f > 0.) then "inf" else "-inf"
 
 let expression_or_instructions ctx st in_function =

compiler/tests-compiler/test_string.ml

@@ -55,10 +55,11 @@ let (_ : string) = here ()
         runtime = globalThis.jsoo_runtime,
         cst_a = "a",
         cst_b = "b",
-        caml_string_concat = runtime.caml_string_concat;
-       function _a_(_b_){return cst_a + cst_a + cst_b + cst_b;}
-       _a_(0);
-       var Test = [0, caml_string_concat, _a_];
+        caml_string_concat = runtime.caml_string_concat,
+        Test =
+          [0,
+           caml_string_concat,
+           function(_a_){return cst_a + cst_a + cst_b + cst_b;}];
        runtime.caml_register_global(2, Test, "Test");
        return;
       }
@@ -103,14 +104,15 @@ let (_ : string) = here ()
         caml_string_concat = runtime.caml_string_concat,
         caml_string_of_jsbytes = runtime.caml_string_of_jsbytes,
         cst_a = caml_string_of_jsbytes("a"),
-        cst_b = caml_string_of_jsbytes("b");
-       function _a_(_b_){
-        return caml_string_concat
-                (cst_a,
-                 caml_string_concat(cst_a, caml_string_concat(cst_b, cst_b)));
-       }
-       _a_(0);
-       var Test = [0, caml_string_concat, _a_];
+        cst_b = caml_string_of_jsbytes("b"),
+        Test =
+          [0,
+           caml_string_concat,
+           function(_a_){
+            return caml_string_concat
+                    (cst_a,
+                     caml_string_concat(cst_a, caml_string_concat(cst_b, cst_b)));
+           }];
        runtime.caml_register_global(2, Test, "Test");
        return;
       }

runtime/js/compare.js

@@ -256,7 +256,8 @@ function caml_compare_val(a, b, total) {
 function caml_compare(a, b) {
   return caml_compare_val(a, b, true);
 }
-//Provides: caml_int_compare mutable (const, const)
+
+//Provides: caml_int_compare const
 //Alias: caml_int32_compare
 //Alias: caml_nativeint_compare
 function caml_int_compare(a, b) {

runtime/js/ieee_754.js

@@ -186,7 +186,7 @@ function caml_nextafter_float(x, y) {
   return caml_int64_float_of_bits(bits);
 }
 
-//Provides: caml_trunc_float
+//Provides: caml_trunc_float const
 function caml_trunc_float(x) {
   return Math.trunc(x);
 }

runtime/js/ints.js

@@ -160,11 +160,12 @@ function caml_mod(x, y) {
   return x % y;
 }
 
-//Provides: caml_bswap16
+//Provides: caml_bswap16 const
 function caml_bswap16(x) {
   return ((x & 0x00ff) << 8) | ((x & 0xff00) >> 8);
 }
-//Provides: caml_int32_bswap
+
+//Provides: caml_int32_bswap const
 //Alias: caml_nativeint_bswap
 function caml_int32_bswap(x) {
   return (
@@ -174,7 +175,7 @@ function caml_int32_bswap(x) {
     ((x & 0xff000000) >>> 24)
   );
 }
-//Provides: caml_int64_bswap
+//Provides: caml_int64_bswap const
 //Requires: caml_int64_to_bytes, caml_int64_of_bytes
 function caml_int64_bswap(x) {
   var y = caml_int64_to_bytes(x);

runtime/js/mlBytes.js

@@ -688,13 +688,13 @@ function caml_ml_bytes_length(s) {
   return s.l;
 }
 
-//Provides: caml_string_concat
+//Provides: caml_string_concat const
 //If: js-string
 function caml_string_concat(a, b) {
   return a + b;
 }
 
-//Provides: caml_string_concat
+//Provides: caml_string_concat const
 //Requires: caml_convert_string_to_bytes, MlBytes
 //If: !js-string
 function caml_string_concat(s1, s2) {

runtime/js/prng.js

@@ -14,7 +14,7 @@ var caml_lxm_daba = caml_int64_of_string(
   caml_string_of_jsstring("0xdaba0b6eb09322e3"),
 );
 
-//Provides: caml_lxm_next
+//Provides: caml_lxm_next const
 //Requires: caml_int64_shift_left
 //Requires: caml_int64_shift_right_unsigned
 //Requires: caml_int64_or

runtime/wasm/float.wat

@@ -793,11 +793,6 @@
          (struct.new $float (tuple.extract 2 0 (local.get $r)))
          (ref.i31 (tuple.extract 2 1 (local.get $r)))))
 
-   (func (export "caml_signbit_float") (param $x f64) (result (ref eq))
-      (ref.i31
-         (i32.wrap_i64
-            (i64.shr_u (i64.reinterpret_f64 (local.get $x)) (i64.const 63)))))
-
    (func $erf (export "caml_erf_float") (param $x f64) (result f64)
       (local $a1 f64) (local $a2 f64) (local $a3 f64)
       (local $a4 f64) (local $a5 f64) (local $p f64)