Improved handling of NaNs

CHANGES.md

@@ -6,6 +6,7 @@
 * Compiler/wasm: specialization of number comparisons and bigarray operations (#1954)
 * Compiler/wasm: make the type of some Wasm primitives more precise (#2100)
 * Compiler: reference unboxing (#1958)
+* Runtime: improved handling of NaNs (#2110)
 
 ## Bug fixes
 * Compiler: fix purity of comparison functions (again) (#2092)

compiler/lib-wasm/wat_output.ml

@@ -328,18 +328,22 @@ let float64 _ f =
   match classify_float f with
   | FP_normal | FP_subnormal | FP_zero -> Printf.sprintf "%h" f
   | FP_nan ->
+      let f = Int64.(bits_of_float f) in
       Printf.sprintf
-        "nan:0x%Lx"
-        Int64.(logand (bits_of_float f) (of_int ((1 lsl 52) - 1)))
+        "%snan:0x%Lx"
+        (if Int64.( >= ) f 0L then "" else "-")
+        Int64.(logand 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 -> Printf.sprintf "%h" f
   | FP_nan ->
+      let f = Int32.(bits_of_float f) in
       Printf.sprintf
-        "nan:0x%lx"
-        Int32.(logand (bits_of_float f) (of_int ((1 lsl 23) - 1)))
+        "%snan:0x%lx"
+        (if Int32.( >= ) f 0l then "" else "-")
+        Int32.(logand 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/lib/eval.ml

@@ -139,7 +139,9 @@ let nativeint_shiftop (l : constant list) (f : int32 -> int -> int32) : constant
   | [ NativeInt i; Int j ] -> Some (NativeInt (f i (Targetint.to_int_exn j)))
   | _ -> None
 
-let eval_prim x =
+let quiet_nan n = Int64.logor n 0x00_08_00_00_00_00_00_00L
+
+let eval_prim ~target x =
   match x with
   | Not, [ Int i ] -> bool (Targetint.is_zero i)
   | Lt, [ Int i; Int j ] -> bool Targetint.(i < j)
@@ -231,7 +233,15 @@ let eval_prim x =
       (* int32 *)
       | "caml_int32_bits_of_float", [ Float f ] ->
           int32 (Int32.bits_of_float (Int64.float_of_bits f))
-      | "caml_int32_float_of_bits", [ Int32 i ] -> Some (float (Int32.float_of_bits i))
+      | "caml_int32_float_of_bits", [ Int32 i ]
+        when match target with
+             | `JavaScript ->
+                 let f = Int32.float_of_bits i in
+                 (not (Float.is_nan f))
+                 || Int64.equal
+                      (quiet_nan (Int64.bits_of_float f))
+                      (Int64.bits_of_float nan)
+             | `Wasm -> true -> Some (float (Int32.float_of_bits i))
       | "caml_int32_of_float", [ Float f ] ->
           int32 (Int32.of_float (Int64.float_of_bits f))
       | "caml_int32_to_float", [ Int32 i ] -> Some (float (Int32.to_float i))
@@ -258,8 +268,15 @@ let eval_prim x =
       (* nativeint *)
       | "caml_nativeint_bits_of_float", [ Float f ] ->
           nativeint (Int32.bits_of_float (Int64.float_of_bits f))
-      | "caml_nativeint_float_of_bits", [ NativeInt i ] ->
-          Some (float (Int32.float_of_bits i))
+      | "caml_nativeint_float_of_bits", [ NativeInt i ]
+        when match target with
+             | `JavaScript ->
+                 let f = Int32.float_of_bits i in
+                 (not (Float.is_nan f))
+                 || Int64.equal
+                      (quiet_nan (Int64.bits_of_float f))
+                      (Int64.bits_of_float nan)
+             | `Wasm -> true -> Some (float (Int32.float_of_bits i))
       | "caml_nativeint_of_float", [ Float f ] ->
           nativeint (Int32.of_float (Int64.float_of_bits f))
       | "caml_nativeint_to_float", [ NativeInt i ] -> Some (float (Int32.to_float i))
@@ -284,7 +301,12 @@ let eval_prim x =
       | "caml_nativeint_of_int", [ Int i ] -> nativeint (Targetint.to_int32 i)
       (* int64 *)
       | "caml_int64_bits_of_float", [ Float f ] -> int64 f
-      | "caml_int64_float_of_bits", [ Int64 i ] -> Some (Float i)
+      | "caml_int64_float_of_bits", [ Int64 i ]
+        when match target with
+             | `JavaScript ->
+                 (not (Float.is_nan (Int64.float_of_bits i)))
+                 || Int64.equal (quiet_nan i) (Int64.bits_of_float nan)
+             | `Wasm -> true -> Some (Float i)
       | "caml_int64_of_float", [ Float f ] ->
           int64 (Int64.of_float (Int64.float_of_bits f))
       | "caml_int64_to_float", [ Int64 i ] -> Some (float (Int64.to_float i))
@@ -632,6 +654,7 @@ let eval_instr update_count inline_constant ~target info i =
             | _ -> false)
         then
           eval_prim
+            ~target
             ( prim
             , List.map prim_args' ~f:(function
                 | Some c -> c

compiler/tests-jsoo/test_nan.ml

@@ -0,0 +1,15 @@
+let none = Int64.float_of_bits 0x7ff0_1234_5678_90ABL
+
+let sign_mask = 0x8000_0000_0000_0000L
+
+let some x =
+  if Float.is_nan x
+  then if Int64.(logand (bits_of_float x) sign_mask = 0L) then nan else -.nan
+  else x
+
+let is_none t = Int64.equal (Int64.bits_of_float t) (Int64.bits_of_float none)
+
+let () =
+  assert (is_none none);
+  let l = [ nan; -.nan; 1.; -7.; infinity; neg_infinity; 0.; none ] in
+  List.iter (fun f -> assert (not (is_none (some f)))) l

runtime/js/ieee_754.js

@@ -27,10 +27,14 @@ function caml_int64_bits_of_float(x) {
   jsoo_dataview.setFloat64(0, x, true);
   var lo32 = jsoo_dataview.getUint32(0, true);
   var hi32 = jsoo_dataview.getUint32(4, true);
-  var r1 = lo32 & 0xffffff;
-  var r2 = (lo32 >>> 24) | ((hi32 << 8) & 0xffffff);
-  var r3 = (hi32 >>> 16) & 0xffff;
-  return caml_int64_create_lo_mi_hi(r1, r2, r3);
+  var lo = lo32 & 0xffffff;
+  var mi = (lo32 >>> 24) | ((hi32 << 8) & 0xffffff);
+  var hi = (hi32 >>> 16) & 0xffff;
+  // V8 uses signaling NaNs as sentinal. So, NaNs are made quiet when
+  // they are stored in an array. Make them quiet here so that we get
+  // consistent results.
+  if ((hi & 0x7ff8) === 0x7ff0 && (mi | lo | (hi & 0xf)) !== 0) hi |= 8;
+  return caml_int64_create_lo_mi_hi(lo, mi, hi);
 }
 
 //Provides: caml_int32_bits_of_float const
@@ -108,6 +112,10 @@ function caml_int64_float_of_bits(x) {
   var lo = x.lo;
   var mi = x.mi;
   var hi = x.hi;
+  // V8 uses signaling NaNs as sentinal. So, NaNs are made quiet when
+  // they are stored in an array. Make them quiet here so that we get
+  // consistent results.
+  if ((hi & 0x7ff8) === 0x7ff0 && (mi | lo | (hi & 0xf)) !== 0) hi |= 8;
   jsoo_dataview.setUint32(0, lo | (mi << 24), true);
   jsoo_dataview.setUint32(4, (mi >>> 8) | (hi << 16), true);
   return jsoo_dataview.getFloat64(0, true);