Switch to a bit representation of floats

vouillon · hhugo · commit 74db48029cf4 · 2025-04-17T22:56:55.000+02:00
diff --git a/compiler/lib-wasm/gc_target.ml b/compiler/lib-wasm/gc_target.ml
@@ -1025,12 +1025,15 @@ module Constant = struct
           return (Const_named ("str_" ^ s), W.ArrayNewFixed (ty, l))
     | Float f ->
         let* ty = Type.float_type in
-        return (Const, W.StructNew (ty, [ Const (F64 f) ]))
+        return (Const, W.StructNew (ty, [ Const (F64 (Int64.float_of_bits f)) ]))
     | Float_array l ->
         let l = Array.to_list l in
         let* ty = Type.float_array_type in
         (*ZZZ Boxed array? *)
-        return (Const, W.ArrayNewFixed (ty, List.map ~f:(fun f -> W.Const (F64 f)) l))
+        return
+          ( Const
+          , W.ArrayNewFixed
+              (ty, List.map ~f:(fun f -> W.Const (F64 (Int64.float_of_bits f))) l) )
     | Int64 i ->
         let* e = Memory.make_int64 (return (W.Const (I64 i))) in
         return (Const, e)
diff --git a/compiler/lib/code.ml b/compiler/lib/code.ml
@@ -268,8 +268,8 @@ end
 type constant =
   | String of string
   | NativeString of Native_string.t
-  | Float of float
-  | Float_array of float array
+  | Float of Int64.t
+  | Float_array of Int64.t array
   | Int of Targetint.t
   | Int32 of Int32.t
   | Int64 of Int64.t
@@ -299,8 +299,14 @@ module Constant = struct
     | Int32 a, Int32 b -> Some (Int32.equal a b)
     | Int64 a, Int64 b -> Some (Int64.equal a b)
     | NativeInt a, NativeInt b -> Some (Int32.equal a b)
-    | Float_array a, Float_array b -> Some (Array.equal Float.ieee_equal a b)
-    | Float a, Float b -> Some (Float.ieee_equal a b)
+    | Float_array a, Float_array b ->
+        Some
+          (Array.equal
+             (fun f g -> Float.ieee_equal (Int64.float_of_bits f) (Int64.float_of_bits g))
+             a
+             b)
+    | Float a, Float b ->
+        Some (Float.ieee_equal (Int64.float_of_bits a) (Int64.float_of_bits b))
     | String _, NativeString _ | NativeString _, String _ -> None
     | Int _, Float _ | Float _, Int _ -> None
     | Tuple ((0 | 254), _, _), Float_array _ -> None
@@ -349,33 +355,6 @@ module Constant = struct
     | NativeInt _, (Int _ | Int32 _)
     | (Int32 _ | NativeInt _), Float _
     | Float _, (Int32 _ | NativeInt _) -> None
-
-  let rec equal c c' =
-    match c, c' with
-    | String s, String s' -> String.equal s s'
-    | NativeString s, NativeString s' -> Native_string.equal s s'
-    | Float f, Float f' -> Float.bitwise_equal f f'
-    | Float_array a, Float_array a' -> Array.equal Float.bitwise_equal a a'
-    | Int i, Int i' -> Targetint.equal i i'
-    | Int32 i, Int32 i' | NativeInt i, NativeInt i' -> Int32.equal i i'
-    | Int64 i, Int64 i' -> Int64.equal i i'
-    | Tuple (t, a, kind), Tuple (t', a', kind') -> (
-        t = t'
-        && Array.equal equal a a'
-        &&
-        match kind, kind' with
-        | Array, Array | NotArray, NotArray | Unknown, Unknown -> true
-        | (Array | NotArray | Unknown), _ -> false)
-    | ( ( String _
-        | NativeString _
-        | Float _
-        | Float_array _
-        | Int _
-        | Int32 _
-        | NativeInt _
-        | Int64 _
-        | Tuple _ )
-      , _ ) -> false
 end
 
 type loc =
@@ -461,12 +440,12 @@ module Print = struct
     | String s -> Format.fprintf f "%S" s
     | NativeString (Byte s) -> Format.fprintf f "%Sj" s
     | NativeString (Utf (Utf8 s)) -> Format.fprintf f "%Sj" s
-    | Float fl -> Format.fprintf f "%.12g" fl
+    | Float fl -> Format.fprintf f "%.12g" (Int64.float_of_bits fl)
     | Float_array a ->
         Format.fprintf f "[|";
         for i = 0 to Array.length a - 1 do
           if i > 0 then Format.fprintf f ", ";
-          Format.fprintf f "%.12g" a.(i)
+          Format.fprintf f "%.12g" (Int64.float_of_bits a.(i))
         done;
         Format.fprintf f "|]"
     | Int i -> Format.fprintf f "%s" (Targetint.to_string i)
@@ -819,24 +798,7 @@ let eq p1 p2 =
          | block2 ->
              List.equal ~eq:Var.equal block1.params block2.params
              && Poly.equal block1.branch block2.branch
-             && List.equal
-                  ~eq:(fun i i' ->
-                    match i, i' with
-                    | Let (x, Constant c), Let (x', Constant c') ->
-                        Var.equal x x' && Constant.equal c c'
-                    | Let (x, Prim (prim, args)), Let (x', Prim (prim', args')) ->
-                        Var.equal x x'
-                        && Poly.equal prim prim'
-                        && List.equal
-                             ~eq:(fun a a' ->
-                               match a, a' with
-                               | Pc c, Pc c' -> Constant.equal c c'
-                               | _ -> Poly.equal a a')
-                             args
-                             args'
-                    | _ -> Poly.equal i i')
-                  block1.body
-                  block2.body)
+             && List.equal ~eq:Poly.equal block1.body block2.body)
        p1.blocks
        true
 
diff --git a/compiler/lib/code.mli b/compiler/lib/code.mli
@@ -157,8 +157,8 @@ end
 type constant =
   | String of string
   | NativeString of Native_string.t
-  | Float of float
-  | Float_array of float array
+  | Float of Int64.t
+  | Float_array of Int64.t array
   | Int of Targetint.t
   | Int32 of Int32.t  (** Only produced when compiling to WebAssembly. *)
   | Int64 of Int64.t
diff --git a/compiler/lib/eval.ml b/compiler/lib/eval.ml
@@ -45,10 +45,12 @@ let shift_op l f =
   | [ Int i; Int j ] -> Some (Int (f i (Targetint.to_int_exn j)))
   | _ -> None
 
+let float f : constant = Float (Int64.bits_of_float f)
+
 let float_binop_aux (l : constant list) (f : float -> float -> 'a) : 'a option =
   let args =
     match l with
-    | [ Float i; Float j ] -> Some (i, j)
+    | [ Float i; Float j ] -> Some (Int64.float_of_bits i, Int64.float_of_bits j)
     | _ -> None
   in
   match args with
@@ -57,12 +59,12 @@ let float_binop_aux (l : constant list) (f : float -> float -> 'a) : 'a option =
 
 let float_binop (l : constant list) (f : float -> float -> float) : constant option =
   match float_binop_aux l f with
-  | Some x -> Some (Float x)
+  | Some x -> Some (float x)
   | None -> None
 
 let float_unop (l : constant list) (f : float -> float) : constant option =
   match l with
-  | [ Float i ] -> Some (Float (f i))
+  | [ Float i ] -> Some (float (f (Int64.float_of_bits i)))
   | _ -> None
 
 let bool' b = Int Targetint.(if b then one else zero)
@@ -71,7 +73,7 @@ let bool b = Some (bool' b)
 
 let float_unop_bool (l : constant list) (f : float -> bool) =
   match l with
-  | [ Float i ] -> bool (f i)
+  | [ Float i ] -> bool (f (Int64.float_of_bits i))
   | _ -> None
 
 let float_binop_bool l f =
@@ -168,10 +170,10 @@ let eval_prim x =
       | "caml_div_float", _ -> float_binop l ( /. )
       | "caml_fmod_float", _ -> float_binop l mod_float
       | "caml_int_of_float", [ Float f ] -> (
-          match Targetint.of_float_opt f with
+          match Targetint.of_float_opt (Int64.float_of_bits f) with
           | None -> None
           | Some f -> Some (Int f))
-      | "caml_float_of_int", [ Int i ] -> Some (Float (Targetint.to_float i))
+      | "caml_float_of_int", [ Int i ] -> Some (float (Targetint.to_float i))
       (* Math *)
       | "caml_neg_float", _ -> float_unop l ( ~-. )
       | "caml_abs_float", _ -> float_unop l abs_float
@@ -209,16 +211,19 @@ let eval_prim x =
       | "caml_erfc_float", _ -> float_unop l Float.erfc
       | "caml_nextafter_float", _ -> float_binop l Float.next_after
       | "caml_float_compare", [ Float i; Float j ] ->
-          Some (Int (Targetint.of_int_exn (Float.compare i j)))
+          Some
+            (Int
+               (Targetint.of_int_exn
+                  (Float.compare (Int64.float_of_bits i) (Int64.float_of_bits j))))
       | "caml_ldexp_float", [ Float f; Int i ] ->
-          Some (Float (ldexp f (Targetint.to_int_exn i)))
+          Some (float (ldexp (Int64.float_of_bits f) (Targetint.to_int_exn i)))
       (* int32 *)
-      | "caml_int32_bits_of_float", [ Float f ] -> int32 (Int32.bits_of_float f)
-      | "caml_int32_float_of_bits", [ Int i ] ->
-          Some (Float (Int32.float_of_bits (Targetint.to_int32 i)))
-      | "caml_int32_float_of_bits", [ Int32 i ] -> Some (Float (Int32.float_of_bits i))
-      | "caml_int32_of_float", [ Float f ] -> int32 (Int32.of_float f)
-      | "caml_int32_to_float", [ Int32 i ] -> Some (Float (Int32.to_float i))
+      | "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_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))
       | "caml_int32_neg", _ -> int32_unop l Int32.neg
       | "caml_int32_add", _ -> int32_binop l Int32.add
       | "caml_int32_sub", _ -> int32_binop l Int32.sub
@@ -240,13 +245,13 @@ let eval_prim x =
       | "caml_nativeint_of_int32", [ Int32 i ] -> Some (NativeInt i)
       | "caml_nativeint_to_int32", [ NativeInt i ] -> Some (Int32 i)
       (* nativeint *)
-      | "caml_nativeint_bits_of_float", [ Float f ] -> nativeint (Int32.bits_of_float f)
-      | "caml_nativeint_float_of_bits", [ Int i ] ->
-          Some (Float (Int32.float_of_bits (Targetint.to_int32 i)))
+      | "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_of_float", [ Float f ] -> nativeint (Int32.of_float f)
-      | "caml_nativeint_to_float", [ NativeInt i ] -> Some (Float (Int32.to_float i))
+          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))
       | "caml_nativeint_neg", _ -> nativeint_unop l Int32.neg
       | "caml_nativeint_add", _ -> nativeint_binop l Int32.add
       | "caml_nativeint_sub", _ -> nativeint_binop l Int32.sub
@@ -267,10 +272,11 @@ let eval_prim x =
       | "caml_nativeint_to_int", [ Int32 i ] -> Some (Int (Targetint.of_int32_truncate i))
       | "caml_nativeint_of_int", [ Int i ] -> nativeint (Targetint.to_int32 i)
       (* int64 *)
-      | "caml_int64_bits_of_float", [ Float f ] -> int64 (Int64.bits_of_float f)
-      | "caml_int64_float_of_bits", [ Int64 i ] -> Some (Float (Int64.float_of_bits i))
-      | "caml_int64_of_float", [ Float f ] -> int64 (Int64.of_float f)
-      | "caml_int64_to_float", [ Int64 i ] -> Some (Float (Int64.to_float i))
+      | "caml_int64_bits_of_float", [ Float f ] -> int64 f
+      | "caml_int64_float_of_bits", [ Int64 i ] -> 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))
       | "caml_int64_neg", _ -> int64_unop l Int64.neg
       | "caml_int64_add", _ -> int64_binop l Int64.add
       | "caml_int64_sub", _ -> int64_binop l Int64.sub
@@ -289,8 +295,7 @@ let eval_prim x =
           Some (Int (Targetint.of_int_exn (Int64.compare i j)))
       | "caml_int64_to_int", [ Int64 i ] ->
           Some (Int (Targetint.of_int32_truncate (Int64.to_int32 i)))
-      | ( ("caml_int64_of_int" | "caml_int64_of_int32" | "caml_int64_of_nativeint")
-        , [ Int i ] ) -> int64 (Int64.of_int32 (Targetint.to_int32 i))
+      | "caml_int64_of_int", [ Int i ] -> int64 (Int64.of_int32 (Targetint.to_int32 i))
       | "caml_int64_to_int32", [ Int64 i ] -> int32 (Int64.to_int32 i)
       | "caml_int64_of_int32", [ Int32 i ] -> int64 (Int64.of_int32 i)
       | "caml_int64_to_nativeint", [ Int64 i ] -> nativeint (Int64.to_int32 i)
@@ -435,7 +440,8 @@ let rec int_predicate deep info pred x (i : Targetint.t) =
 let constant_js_equal a b =
   match a, b with
   | Int i, Int j -> Some (Targetint.equal i j)
-  | Float a, Float b -> Some (Float.ieee_equal a b)
+  | Float a, Float b ->
+      Some (Float.ieee_equal (Int64.float_of_bits a) (Int64.float_of_bits b))
   | NativeString a, NativeString b -> Some (Native_string.equal a b)
   | String a, String b when Config.Flag.use_js_string () -> Some (String.equal a b)
   | Int _, Float _ | Float _, Int _ -> None
diff --git a/compiler/lib/flow.ml b/compiler/lib/flow.ml
@@ -362,7 +362,7 @@ let the_def_of info x =
 let constant_identical ~(target : [ `JavaScript | `Wasm ]) a b =
   match a, b, target with
   | Int i, Int j, _ -> Targetint.equal i j
-  | Float a, Float b, `JavaScript -> Float.bitwise_equal a b
+  | Float a, Float b, `JavaScript -> Int64.equal a b
   | Float _, Float _, `Wasm -> false
   | NativeString a, NativeString b, `JavaScript -> Native_string.equal a b
   | NativeString _, NativeString _, `Wasm ->
diff --git a/compiler/lib/generate.ml b/compiler/lib/generate.ml
@@ -386,7 +386,7 @@ let source_location ctx position pc =
 
 (****)
 
-let float_const f = J.ENum (J.Num.of_float f)
+let float_const f = J.ENum (J.Num.of_float (Int64.float_of_bits f))
 
 let s_var name = J.EVar (J.ident (Utf8_string.of_string_exn name))
 
diff --git a/compiler/lib/ocaml_compiler.ml b/compiler/lib/ocaml_compiler.ml
@@ -25,13 +25,13 @@ let rec constant_of_const c : Code.constant =
   | Const_base (Const_int i) -> Int (Targetint.of_int_warning_on_overflow i)
   | Const_base (Const_char c) -> Int (Targetint.of_int_exn (Char.code c))
   | Const_base (Const_string (s, _, _)) -> String s
-  | Const_base (Const_float s) -> Float (float_of_string s)
+  | Const_base (Const_float s) -> Float (Int64.bits_of_float (float_of_string s))
   | Const_base (Const_int32 i) -> Int32 i
   | Const_base (Const_int64 i) -> Int64 i
   | Const_base (Const_nativeint i) -> NativeInt (Int32.of_nativeint_warning_on_overflow i)
   | Const_immstring s -> String s
   | Const_float_array sl ->
-      let l = List.map ~f:(fun f -> float_of_string f) sl in
+      let l = List.map ~f:(fun f -> Int64.bits_of_float (float_of_string f)) sl in
       Float_array (Array.of_list l)
   | Const_block (tag, l) ->
       let l = Array.of_list (List.map l ~f:constant_of_const) in
diff --git a/compiler/lib/parse_bytecode.ml b/compiler/lib/parse_bytecode.ml
@@ -442,9 +442,12 @@ end = struct
       if tag = Obj.string_tag
       then String (Obj.magic x : string)
       else if tag = Obj.double_tag
-      then Float (Obj.magic x : float)
+      then Float (Int64.bits_of_float (Obj.magic x : float))
       else if tag = Obj.double_array_tag
-      then Float_array (Array.init (Obj.size x) ~f:(fun i -> Obj.double_field x i))
+      then
+        Float_array
+          (Array.init (Obj.size x) ~f:(fun i ->
+               Int64.bits_of_float (Obj.double_field x i)))
       else if tag = Obj.custom_tag
       then
         match ident_of_custom x with
