Make specialized compare unboxed

    - float
    - int32
    - int64
    - nativeint

  Not for int because the comparison is done directly on the untagged version.
  Useful mainly for floats since they can be stored unboxed in records or arrays.

6 files changed, 66 insertions, 24 deletions

diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index bf810f32f3..4c67e684a7 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -103,18 +103,21 @@ let comparisons_table = create_hashtable 11 [
        Pbintcomp(Pint64, Cge),
        false);
   "%compare",
+      let unboxed_compare name native_repr =
+        Pccall( Primitive.make ~name ~alloc:false
+                  ~native_name:(name^"_unboxed")
+                  ~native_repr_args:[native_repr;native_repr]
+                  ~native_repr_res:Untagged_int
+              ) in
       (Pccall(Primitive.simple ~name:"caml_compare" ~arity:2 ~alloc:true),
+       (* Not unboxed since the comparison is done directly on tagged int *)
        Pccall(Primitive.simple ~name:"caml_int_compare" ~arity:2 ~alloc:false),
-       Pccall(Primitive.simple ~name:"caml_float_compare" ~arity:2
-                ~alloc:false),
+       unboxed_compare "caml_float_compare" Unboxed_float,
        Pccall(Primitive.simple ~name:"caml_string_compare" ~arity:2
                 ~alloc:false),
-       Pccall(Primitive.simple ~name:"caml_nativeint_compare" ~arity:2
-                ~alloc:false),
-       Pccall(Primitive.simple ~name:"caml_int32_compare" ~arity:2
-                ~alloc:false),
-       Pccall(Primitive.simple ~name:"caml_int64_compare" ~arity:2
-                ~alloc:false),
+       unboxed_compare "caml_nativeint_compare" (Unboxed_integer Pnativeint),
+       unboxed_compare "caml_int32_compare" (Unboxed_integer Pint32),
+       unboxed_compare "caml_int64_compare" (Unboxed_integer Pint64),
        false)
 ]
 
diff --git a/byterun/floats.c b/byterun/floats.c
index 3320414da6..69af1d8761 100644
--- a/byterun/floats.c
+++ b/byterun/floats.c
@@ -438,15 +438,18 @@ CAMLprim value caml_gt_float(value f, value g)
   return Val_bool(Double_val(f) > Double_val(g));
 }
 
-CAMLprim value caml_float_compare(value vf, value vg)
+intnat caml_float_compare_unboxed(double f, double g)
 {
-  double f = Double_val(vf);
-  double g = Double_val(vg);
   /* If one or both of f and g is NaN, order according to the convention
      NaN = NaN and NaN < x for all other floats x. */
   /* This branchless implementation is from GPR#164.
      Note that [f == f] if and only if f is not NaN. */
-  return Val_int((f > g) - (f < g) + (f == f) - (g == g));
+  return (f > g) - (f < g) + (f == f) - (g == g);
+}
+
+CAMLprim value caml_float_compare(value vf, value vg)
+{
+  return Val_int(caml_float_compare_unboxed(Double_val(vf),Double_val(vg)));
 }
 
 enum { FP_normal, FP_subnormal, FP_zero, FP_infinite, FP_nan };
diff --git a/byterun/ints.c b/byterun/ints.c
index d0842cb542..8f96e55248 100644
--- a/byterun/ints.c
+++ b/byterun/ints.c
@@ -305,12 +305,14 @@ double caml_int32_to_float_unboxed(int32_t x)
 CAMLprim value caml_int32_to_float(value v)
 { return caml_copy_double((double)(Int32_val(v))); }
 
+intnat caml_int32_compare_unboxed(int32_t i1, int32_t i2)
+{
+  return (i1 > i2) - (i1 < i2);
+}
+
 CAMLprim value caml_int32_compare(value v1, value v2)
 {
-  int32_t i1 = Int32_val(v1);
-  int32_t i2 = Int32_val(v2);
-  int res = (i1 > i2) - (i1 < i2);
-  return Val_int(res);
+  return Val_int(caml_int32_compare_unboxed(Int32_val(v1),Int32_val(v2)));
 }
 
 CAMLprim value caml_int32_format(value fmt, value arg)
@@ -539,11 +541,14 @@ CAMLprim value caml_int64_of_nativeint(value v)
 CAMLprim value caml_int64_to_nativeint(value v)
 { return caml_copy_nativeint((intnat) (Int64_val(v))); }
 
+intnat caml_int64_compare_unboxed(int64_t i1, int64_t i2)
+{
+  return (i1 > i2) - (i1 < i2);
+}
+
 CAMLprim value caml_int64_compare(value v1, value v2)
 {
-  int64_t i1 = Int64_val(v1);
-  int64_t i2 = Int64_val(v2);
-  return Val_int((i1 > i2) - (i1 < i2));
+  return Val_int(caml_int64_compare_unboxed(Int64_val(v1),Int64_val(v2)));
 }
 
 CAMLprim value caml_int64_format(value fmt, value arg)
@@ -796,12 +801,15 @@ CAMLprim value caml_nativeint_of_int32(value v)
 CAMLprim value caml_nativeint_to_int32(value v)
 { return caml_copy_int32(Nativeint_val(v)); }
 
+intnat caml_nativeint_compare_unboxed(intnat i1, intnat i2)
+{
+  return (i1 > i2) - (i1 < i2);
+}
+
 CAMLprim value caml_nativeint_compare(value v1, value v2)
 {
-  intnat i1 = Nativeint_val(v1);
-  intnat i2 = Nativeint_val(v2);
-  int res = (i1 > i2) - (i1 < i2);
-  return Val_int(res);
+  return Val_int(caml_nativeint_compare_unboxed(Nativeint_val(v1),
+                                                Nativeint_val(v2)));
 }
 
 CAMLprim value caml_nativeint_format(value fmt, value arg)
diff --git a/testsuite/tests/float-unboxing/float_subst_boxed_number.ml b/testsuite/tests/float-unboxing/float_subst_boxed_number.ml
index cfa00468e0..598bda81c6 100644
--- a/testsuite/tests/float-unboxing/float_subst_boxed_number.ml
+++ b/testsuite/tests/float-unboxing/float_subst_boxed_number.ml
@@ -74,5 +74,15 @@ let unbox_classify_float () =
     x := !x +. 1.
   done
 
+let unbox_compare_float () =
+  let module M = struct type sf = { mutable x: float; y: float; } end in
+  let x = { M.x=100. ; y=1. } in
+  for i = 1 to 1000 do
+    assert (compare x.M.x x.M.y >= 0);
+    x.M.x <- x.M.x +. 1.
+  done
+
 let () =
-  check_noalloc "classify float" unbox_classify_float
+  check_noalloc "classify float" unbox_classify_float;
+  check_noalloc "compare float" unbox_compare_float;
+  ()
diff --git a/typing/primitive.ml b/typing/primitive.ml
index 05c4ccfe8b..efe55b1387 100644
--- a/typing/primitive.ml
+++ b/typing/primitive.ml
@@ -69,6 +69,14 @@ let simple ~name ~arity ~alloc =
    prim_native_repr_args = make_native_repr_args arity Same_as_ocaml_repr;
    prim_native_repr_res = Same_as_ocaml_repr}
 
+let make ~name ~alloc ~native_name ~native_repr_args ~native_repr_res =
+  {prim_name = name;
+   prim_arity = List.length native_repr_args;
+   prim_alloc = alloc;
+   prim_native_name = native_name;
+   prim_native_repr_args = native_repr_args;
+   prim_native_repr_res = native_repr_res}
+
 let parse_declaration valdecl ~native_repr_args ~native_repr_res =
   let arity = List.length native_repr_args in
   let name, native_name, old_style_noalloc, old_style_float =
diff --git a/typing/primitive.mli b/typing/primitive.mli
index 4872985767..4d2e890189 100644
--- a/typing/primitive.mli
+++ b/typing/primitive.mli
@@ -30,12 +30,22 @@ type description = private
     prim_native_repr_args: native_repr list;
     prim_native_repr_res: native_repr }
 
+(* Invariant [List.length d.prim_native_repr_args = d.prim_arity] *)
+
 val simple
   :  name:string
   -> arity:int
   -> alloc:bool
   -> description
 
+val make
+  :  name:string
+  -> alloc:bool
+  -> native_name:string
+  -> native_repr_args: native_repr list
+  -> native_repr_res: native_repr
+  -> description
+
 val parse_declaration
   :  Parsetree.value_description
   -> native_repr_args:native_repr list