Make phys_equal more like native

CHANGES.md

@@ -18,6 +18,7 @@
   that follows the semantic of the backend (js or wasm)
 * Compiler: warn on joo_global_object
 * Compiler: revisit static env handling (#1708)
+* Compiler: Make phys_equal more like native (wrt NaN and +0/-0) #1410
 * Runtime: change Sys.os_type on windows (Cygwin -> Win32)
 * Runtime: backtraces are really expensive, they need to be be explicitly
   requested at compile time (--enable with-js-error) or at startup (OCAMLRUNPARAM=b=1)

compiler/lib/code.ml

@@ -289,14 +289,19 @@ end
 
 type cont = Addr.t * Var.t list
 
+type float_or_not =
+  | Float
+  | Not_float
+  | Unknown
+
 type prim =
   | Vectlength
   | Array_get
   | Extern of string
   | Not
   | IsInt
-  | Eq
-  | Neq
+  | Eq of float_or_not
+  | Neq of float_or_not
   | Lt
   | Le
   | Ult
@@ -557,8 +562,8 @@ module Print = struct
     | Extern s, _ -> Format.fprintf f "\"%s\"(%a)" s (list arg) l
     | Not, [ x ] -> Format.fprintf f "!%a" arg x
     | IsInt, [ x ] -> Format.fprintf f "is_int(%a)" arg x
-    | Eq, [ x; y ] -> Format.fprintf f "%a === %a" arg x arg y
-    | Neq, [ x; y ] -> Format.fprintf f "!(%a === %a)" arg x arg y
+    | Eq _, [ x; y ] -> Format.fprintf f "%a === %a" arg x arg y
+    | Neq _, [ x; y ] -> Format.fprintf f "!(%a === %a)" arg x arg y
     | Lt, [ x; y ] -> Format.fprintf f "%a < %a" arg x arg y
     | Le, [ x; y ] -> Format.fprintf f "%a <= %a" arg x arg y
     | Ult, [ x; y ] -> Format.fprintf f "%a <= %a" arg x arg y

compiler/lib/code.mli

@@ -139,14 +139,19 @@ end
 
 type cont = Addr.t * Var.t list
 
+type float_or_not =
+  | Float
+  | Not_float
+  | Unknown
+
 type prim =
   | Vectlength
   | Array_get
   | Extern of string
   | Not
   | IsInt
-  | Eq
-  | Neq
+  | Eq of float_or_not
+  | Neq of float_or_not
   | Lt
   | Le
   | Ult

compiler/lib/eval.ml

@@ -83,8 +83,8 @@ let eval_prim x =
   | Not, [ Int i ] -> bool (Targetint.is_zero i)
   | Lt, [ Int i; Int j ] -> bool Targetint.(i < j)
   | Le, [ Int i; Int j ] -> bool Targetint.(i <= j)
-  | Eq, [ Int i; Int j ] -> bool Targetint.(i = j)
-  | Neq, [ Int i; Int j ] -> bool Targetint.(i <> j)
+  | Eq _, [ Int i; Int j ] -> bool Targetint.(i = j)
+  | Neq _, [ Int i; Int j ] -> bool Targetint.(i <> j)
   | Ult, [ Int i; Int j ] -> bool (Targetint.(j < zero) || Targetint.(i < j))
   | Extern name, l -> (
       let name = Primitive.resolve name in

compiler/lib/flow.ml

@@ -206,7 +206,7 @@ let expr_escape st _x e =
   | Special _ | Constant _ | Closure _ | Block _ | Field _ -> ()
   | 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 ((Vectlength | Array_get | Not | IsInt | Eq _ | Neq _ | Lt | Le | Ult), _) -> ()
   | Prim (Extern name, l) ->
       let ka =
         match Primitive.kind_args name with
@@ -340,6 +340,68 @@ let the_def_of info x =
         x
   | Pc c -> Some (Constant c)
 
+let float_or_not x : Code.float_or_not =
+  match x with
+  | Block _ -> Not_float
+  | Closure _ -> Not_float
+  | Special (Alias_prim _) -> Not_float
+  | Field _ -> Unknown
+  | Apply _ -> Unknown
+  | Prim (prim, _) -> (
+      match prim with
+      | Extern
+          ( "caml_ml_string_length"
+          | "caml_ml_bytes_length"
+          | "caml_bytes_unsafe_get"
+          | "caml_bytes_get"
+          | "caml_string_unsafe_get"
+          | "caml_string_get"
+          | "%int_add"
+          | "%int_sub"
+          | "%int_mul"
+          | "%direct_int_mul"
+          | "%int_div"
+          | "%direct_int_div"
+          | "%int_mod"
+          | "%direct_int_mod"
+          | "caml_obj_tag" ) -> Not_float
+      | Array_get -> Unknown
+      | Extern _ -> Unknown
+      | Vectlength -> Not_float
+      | Not -> Not_float
+      | IsInt -> Not_float
+      | Eq _ | Neq _ -> Not_float
+      | Lt | Le | Ult -> Not_float)
+  | Constant
+      ( String _
+      | NativeString _
+      | Float_array _
+      | Int _
+      | Int32 _
+      | Int64 _
+      | Tuple _
+      | NativeInt _ ) -> Not_float
+  | Constant (Float _) -> Float
+
+let the_float_or_not_of info x =
+  match x with
+  | Pv x ->
+      get_approx
+        info
+        (fun x ->
+          match info.info_defs.(Var.idx x) with
+          | Expr e -> float_or_not e
+          | Param | Phi _ -> Unknown)
+        Unknown
+        (fun a b ->
+          match a, b with
+          | Unknown, _ | _, Unknown -> Unknown
+          | Float, Float -> Float
+          | Not_float, Not_float -> Not_float
+          | Float, Not_float | Not_float, Float -> Unknown)
+        x
+  | Pc c -> float_or_not (Constant c)
+
 (* If [constant_identical a b = true], then the two values cannot be
    distinguished, i.e., they are not different objects (and [caml_js_equals a b
    = true]) and if both are floats, they are bitwise equal. *)

compiler/lib/flow.mli

@@ -52,6 +52,8 @@ val get_approx :
 
 val the_def_of : Info.t -> Code.prim_arg -> Code.expr option
 
+val the_float_or_not_of : Info.t -> Code.prim_arg -> Code.float_or_not
+
 val the_const_of :
   target:[ `JavaScript | `Wasm ] -> Info.t -> Code.prim_arg -> Code.constant option
 

compiler/lib/generate.ml

@@ -343,6 +343,8 @@ let plus_int x y =
 
 let bool e = J.ECond (e, one, zero)
 
+let bool_not e = J.ECond (e, zero, one)
+
 (****)
 
 let source_location debug ?force (pc : Code.loc) =
@@ -976,6 +978,7 @@ let _ =
   register_un_prim "caml_obj_dup" `Mutable (fun cx loc ->
       J.call (J.dot cx (Utf8_string.of_string_exn "slice")) [] loc);
   register_un_prim "caml_int_of_float" `Pure (fun cx _loc -> to_int cx);
+  register_un_prim "caml_float_of_int" `Pure (fun cx _loc -> cx);
   register_un_math_prim "caml_abs_float" "abs";
   register_un_math_prim "caml_acos_float" "acos";
   register_un_math_prim "caml_asin_float" "asin";
@@ -1348,22 +1351,42 @@ let rec translate_expr ctx queue loc x e level : _ * J.statement_list =
             let (px, cx), queue = access_queue' ~ctx queue x in
             let (py, cy), queue = access_queue' ~ctx queue y in
             bool (J.EBin (J.LeInt, cx, cy)), or_p px py, queue
-        | Eq, [ x; y ] ->
+        | Eq k, [ x; y ] ->
             let (px, cx), queue = access_queue' ~ctx queue x in
             let (py, cy), queue = access_queue' ~ctx queue y in
-            bool (J.EBin (J.EqEqEq, cx, cy)), or_p px py, queue
-        | Neq, [ x; y ] ->
+            let e =
+              match k with
+              | Not_float -> bool (J.EBin (J.EqEqEq, cx, cy))
+              | Float | Unknown ->
+                  bool
+                    (J.call
+                       (J.dot (s_var "Object") (Utf8_string.of_string_exn "is"))
+                       [ cx; cy ]
+                       loc)
+            in
+            e, or_p px py, queue
+        | Neq k, [ x; y ] ->
             let (px, cx), queue = access_queue' ~ctx queue x in
             let (py, cy), queue = access_queue' ~ctx queue y in
-            bool (J.EBin (J.NotEqEq, cx, cy)), or_p px py, queue
+            let e =
+              match k with
+              | Not_float -> bool (J.EBin (J.NotEqEq, cx, cy))
+              | Float | Unknown ->
+                  bool_not
+                    (J.call
+                       (J.dot (s_var "Object") (Utf8_string.of_string_exn "is"))
+                       [ cx; cy ]
+                       loc)
+            in
+            e, or_p px py, queue
         | IsInt, [ x ] ->
             let (px, cx), queue = access_queue' ~ctx queue x in
             bool (Mlvalue.is_immediate cx), px, queue
         | Ult, [ x; y ] ->
             let (px, cx), queue = access_queue' ~ctx queue x in
             let (py, cy), queue = access_queue' ~ctx queue y in
             bool (J.EBin (J.LtInt, unsigned cx, unsigned cy)), or_p px py, queue
-        | (Vectlength | Array_get | Not | IsInt | Eq | Neq | Lt | Le | Ult), _ ->
+        | (Vectlength | Array_get | Not | IsInt | Eq _ | Neq _ | Lt | Le | Ult), _ ->
             assert false
       in
       res, []
@@ -2031,7 +2054,7 @@ let init () =
     ; "caml_int32_of_int", "%identity"
     ; "caml_int32_to_int", "%identity"
     ; "caml_int32_of_float", "caml_int_of_float"
-    ; "caml_int32_to_float", "%identity"
+    ; "caml_int32_to_float", "caml_float_of_int"
     ; "caml_int32_format", "caml_format_int"
     ; "caml_int32_of_string", "caml_int_of_string"
     ; "caml_int32_compare", "caml_int_compare"
@@ -2050,7 +2073,7 @@ let init () =
     ; "caml_nativeint_of_int", "%identity"
     ; "caml_nativeint_to_int", "%identity"
     ; "caml_nativeint_of_float", "caml_int_of_float"
-    ; "caml_nativeint_to_float", "%identity"
+    ; "caml_nativeint_to_float", "caml_float_of_int"
     ; "caml_nativeint_of_int32", "%identity"
     ; "caml_nativeint_to_int32", "%identity"
     ; "caml_nativeint_format", "caml_format_int"
@@ -2061,7 +2084,6 @@ let init () =
     ; "caml_int64_to_int", "caml_int64_to_int32"
     ; "caml_int64_of_nativeint", "caml_int64_of_int32"
     ; "caml_int64_to_nativeint", "caml_int64_to_int32"
-    ; "caml_float_of_int", "%identity"
     ; "caml_array_get_float", "caml_array_get"
     ; "caml_floatarray_get", "caml_array_get"
     ; "caml_array_get_addr", "caml_array_get"

compiler/lib/global_flow.ml

@@ -150,8 +150,9 @@ let possibly_mutable st x = Var.ISet.add st.variable_possibly_mutable x
 
 let expr_deps blocks st x e =
   match e with
-  | Constant _ | Prim ((Vectlength | Not | IsInt | Eq | Neq | Lt | Le | Ult), _) | Block _
-    -> ()
+  | Constant _
+  | Prim ((Vectlength | Not | IsInt | Eq _ | Neq _ | Lt | Le | Ult), _)
+  | Block _ -> ()
   | Special _ -> ()
   | Prim
       ( ( Extern
@@ -480,7 +481,7 @@ let propagate st ~update approx x =
                   known
             | Top -> Top)
       | Prim (Array_get, _) -> Domain.others
-      | Prim ((Vectlength | Not | IsInt | Eq | Neq | Lt | Le | Ult), _) ->
+      | Prim ((Vectlength | Not | IsInt | Eq _ | Neq _ | Lt | Le | Ult), _) ->
           (* The result of these primitive is neither a function nor a
              block *)
           Domain.bot

compiler/lib/parse_bytecode.ml

@@ -2207,7 +2207,7 @@ and compile infos pc state instrs =
           infos
           (pc + 1)
           (State.pop 1 state)
-          ((Let (x, Prim (Eq, [ Pv y; Pv z ])), loc) :: instrs)
+          ((Let (x, Prim (Eq Unknown, [ Pv y; Pv z ])), loc) :: instrs)
     | NEQ ->
         let y, _ = State.accu state in
         let z, _ = State.peek 0 state in
@@ -2219,7 +2219,7 @@ and compile infos pc state instrs =
           infos
           (pc + 1)
           (State.pop 1 state)
-          ((Let (x, Prim (Neq, [ Pv y; Pv z ])), loc) :: instrs)
+          ((Let (x, Prim (Neq Unknown, [ Pv y; Pv z ])), loc) :: instrs)
     | LTINT ->
         let y, _ = State.accu state in
         let z, _ = State.peek 0 state in
@@ -2303,7 +2303,8 @@ and compile infos pc state instrs =
         let x, _ = State.accu state in
         let y = Var.fresh () in
 
-        ( (Let (y, Prim (Eq, [ Pc (Int (Targetint.of_int32_exn n)); Pv x ])), loc)
+        ( ( Let (y, Prim (Eq Not_float, [ Pc (Int (Targetint.of_int32_exn n)); Pv x ]))
+          , loc )
           :: instrs
         , (Cond (y, (pc + offset + 2, []), (pc + 3, [])), loc)
         , state )
@@ -2313,7 +2314,8 @@ and compile infos pc state instrs =
         let x, _ = State.accu state in
         let y = Var.fresh () in
 
-        ( (Let (y, Prim (Eq, [ Pc (Int (Targetint.of_int32_exn n)); Pv x ])), loc)
+        ( ( Let (y, Prim (Eq Not_float, [ Pc (Int (Targetint.of_int32_exn n)); Pv x ]))
+          , loc )
           :: instrs
         , (Cond (y, (pc + 3, []), (pc + offset + 2, [])), loc)
         , state )

compiler/lib/specialize_js.ml

@@ -294,6 +294,26 @@ let specialize_instrs ~target info l =
                 instr (Pv y') :: (Let (y', Prim (Extern check, [ y; z ])), noloc) :: acc
               in
               aux info ((y, idx) :: checks) r acc
+        | Let (x, Prim (Eq Unknown, [ a; b ])) ->
+            let i =
+              match Flow.the_float_or_not_of info a, Flow.the_float_or_not_of info b with
+              | Not_float, (Not_float | Unknown | Float) | (Float | Unknown), Not_float ->
+                  Let (x, Prim (Eq Not_float, [ a; b ]))
+              | Float, Float -> Let (x, Prim (Eq Float, [ a; b ]))
+              | Unknown, _ | _, Unknown -> i
+            in
+
+            aux info checks r ((i, loc) :: acc)
+        | Let (x, Prim (Neq Unknown, [ a; b ])) ->
+            let i =
+              match Flow.the_float_or_not_of info a, Flow.the_float_or_not_of info b with
+              | Not_float, (Not_float | Unknown | Float) | (Float | Unknown), Not_float ->
+                  Let (x, Prim (Neq Not_float, [ a; b ]))
+              | Float, Float -> Let (x, Prim (Neq Float, [ a; b ]))
+              | Unknown, _ | _, Unknown -> i
+            in
+
+            aux info checks r ((i, loc) :: acc)
         | _ ->
             let i = specialize_instr ~target info i in
             aux info checks r ((i, loc) :: acc))

compiler/tests-compiler/compact.ml

@@ -53,4 +53,5 @@ let rec f x y z =
        return;
       }
       (globalThis));
-    //end |}]
+    //end
+    |}]

compiler/tests-compiler/effects.ml

@@ -60,4 +60,5 @@ let fff () =
                         function(_c_){return caml_cps_call2(_c_, _b_, cont);});
               });
     }
-    //end |}]
+    //end
+    |}]

compiler/tests-compiler/effects_continuations.ml

@@ -101,12 +101,11 @@ let%expect_test "test-compiler/lib-effects/test1.ml" =
   print_fun_decl code (Some "loop3");
   [%expect
     {|
-
     function exceptions(s, cont){
      try{var _t_ = runtime.caml_int_of_string(s), n = _t_;}
      catch(_x_){
       var _p_ = caml_wrap_exception(_x_);
-      if(_p_[1] !== Stdlib[7]){
+      if(! Object.is(_p_[1], Stdlib[7])){
        var raise$1 = caml_pop_trap();
        return raise$1(caml_maybe_attach_backtrace(_p_, 0));
       }
@@ -119,15 +118,15 @@ let%expect_test "test-compiler/lib-effects/test1.ml" =
      }
      catch(_w_){
       var _q_ = caml_wrap_exception(_w_);
-      if(_q_ !== Stdlib[8]){
+      if(! Object.is(_q_, Stdlib[8])){
        var raise$0 = caml_pop_trap();
        return raise$0(caml_maybe_attach_backtrace(_q_, 0));
       }
       var m = 0;
      }
      runtime.caml_push_trap
       (function(_v_){
-        if(_v_ === Stdlib[8]) return cont(0);
+        if(Object.is(_v_, Stdlib[8])) return cont(0);
         var raise = caml_pop_trap();
         return raise(caml_maybe_attach_backtrace(_v_, 0));
        });
@@ -209,4 +208,5 @@ let%expect_test "test-compiler/lib-effects/test1.ml" =
                return _f_(l);
               });
     }
-    //end |}]
+    //end
+    |}]