Make optimized compilation terminate sooner

CHANGES.md

@@ -24,6 +24,7 @@
 * 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)
+* Compiler: faster compilation by stopping sooner when optimizations become unproductive (#1939)
 
 ## Bug fixes
 * Compiler: fix stack overflow issues with double translation (#1869)

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)

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
@@ -434,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)
@@ -782,19 +788,13 @@ let fold_closures_outermost_first { start; blocks; _ } f accu =
 
 let eq p1 p2 =
   p1.start = p2.start
-  && Addr.Map.cardinal p1.blocks = Addr.Map.cardinal p2.blocks
-  && Addr.Map.fold
-       (fun pc block1 b ->
-         b
-         &&
-         try
-           let block2 = Addr.Map.find pc p2.blocks in
-           Poly.equal block1.params block2.params
-           && Poly.equal block1.branch block2.branch
-           && Poly.equal block1.body block2.body
-         with Not_found -> false)
+  && Addr.Map.equal
+       (fun { params; body; branch } b ->
+         List.equal ~eq:Var.equal params b.params
+         && Poly.equal branch b.branch
+         && List.equal ~eq:Poly.equal body b.body)
        p1.blocks
-       true
+       p2.blocks
 
 let with_invariant = Debug.find "invariant"
 

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

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

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 ->

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))
 

compiler/lib/inline.ml

@@ -171,7 +171,7 @@ let rec args_equal xs ys =
   | x :: xs, Pv y :: ys -> Code.Var.compare x y = 0 && args_equal xs ys
   | _ -> false
 
-let inline ~first_class_primitives live_vars closures name pc (outer, p) =
+let inline ~first_class_primitives live_vars closures pc (outer, p) =
   let block = Addr.Map.find pc p.blocks in
   let body, (outer, branch, p) =
     List.fold_right
@@ -245,11 +245,7 @@ let inline ~first_class_primitives live_vars closures name pc (outer, p) =
                           Var.Map.mem farg_tc closures && live_vars.(Var.idx farg_tc) = 1)
                         tc_params
                      || f_size <= 1)
-                     && ((not recursive)
-                        ||
-                        match name with
-                        | None -> true
-                        | Some f' -> not (Var.equal f f')) ->
+                     && not recursive ->
                   let () =
                     (* Update live_vars *)
                     Var.Map.iter
@@ -345,7 +341,7 @@ let f p live_vars =
         let traverse outer =
           Code.traverse
             { fold = Code.fold_children }
-            (inline ~first_class_primitives live_vars closures name)
+            (inline ~first_class_primitives live_vars closures)
             pc
             p.blocks
             (outer, p)

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

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