Merge pull request #272 from alainfrisch/unbox_classify_float

Avoid boxing floats when calling classify_float

6 files changed, 47 insertions, 20 deletions

diff --git a/Changes b/Changes
index 4db7d425d7..594bddae80 100644
--- a/Changes
+++ b/Changes
@@ -144,6 +144,7 @@ Standard library:
   (report and fix by Jeremy Yallop)
 - GPR#265: new implementation of Queue avoiding Obj.magic
   (Jérémie Dimino)
+- GPR#272: Switch classify_float to [@@unboxed] (Alain Frisch)
 - GPR#277: Switch the following externals to [@@unboxed]:
   * {Nativeint,Int32,Int64}.{of,to}_float
   * Int{32,64}.float_of_bits
diff --git a/byterun/floats.c b/byterun/floats.c
index 983833659d..3320414da6 100644
--- a/byterun/floats.c
+++ b/byterun/floats.c
@@ -451,12 +451,18 @@ CAMLprim value caml_float_compare(value vf, value vg)
 
 enum { FP_normal, FP_subnormal, FP_zero, FP_infinite, FP_nan };
 
-CAMLprim value caml_classify_float(value vd)
+value caml_classify_float_unboxed(double vd)
 {
   /* Cygwin 1.3 has problems with fpclassify (PR#1293), so don't use it */
   /* FIXME Cygwin 1.3 is ancient! Revisit this decision. */
+
+  /* Informal benchmarking (see GPR#272) suggests that the emulation
+     version is faster than calling the libc.  We could switch to it,
+     and also provide an even faster version for 64-bit systems as
+     suggested by XL.  -- AF */
+
 #if defined(fpclassify) && !defined(__CYGWIN__) && !defined(__MINGW32__)
-  switch (fpclassify(Double_val(vd))) {
+  switch (fpclassify(vd)) {
   case FP_NAN:
     return Val_int(FP_nan);
   case FP_INFINITE:
@@ -472,7 +478,7 @@ CAMLprim value caml_classify_float(value vd)
   union double_as_two_int32 u;
   uint32_t h, l;
 
-  u.d = Double_val(vd);
+  u.d = vd;
   h = u.i.h;  l = u.i.l;
   l = l | (h & 0xFFFFF);
   h = h & 0x7FF00000;
@@ -490,6 +496,11 @@ CAMLprim value caml_classify_float(value vd)
 #endif
 }
 
+CAMLprim value caml_classify_float(value vd)
+{
+  return caml_classify_float_unboxed(Double_val(vd));
+}
+
 /* The [caml_init_ieee_float] function should initialize floating-point hardware
    so that it behaves as much as possible like the IEEE standard.
    In particular, return special numbers like Infinity and NaN instead
diff --git a/otherlibs/threads/pervasives.ml b/otherlibs/threads/pervasives.ml
index 8f70e310a7..abea182ff8 100644
--- a/otherlibs/threads/pervasives.ml
+++ b/otherlibs/threads/pervasives.ml
@@ -180,7 +180,8 @@ type fpclass =
   | FP_zero
   | FP_infinite
   | FP_nan
-external classify_float : float -> fpclass = "caml_classify_float"
+external classify_float : (float [@unboxed]) -> fpclass =
+  "caml_classify_float" "caml_classify_float_unboxed" [@@noalloc]
 
 (* String and byte sequence operations -- more in modules String and Bytes *)
 
diff --git a/stdlib/pervasives.ml b/stdlib/pervasives.ml
index ebfa3b4a83..15a1af3ff4 100644
--- a/stdlib/pervasives.ml
+++ b/stdlib/pervasives.ml
@@ -176,7 +176,8 @@ type fpclass =
   | FP_zero
   | FP_infinite
   | FP_nan
-external classify_float : float -> fpclass = "caml_classify_float"
+external classify_float : (float [@unboxed]) -> fpclass =
+  "caml_classify_float" "caml_classify_float_unboxed" [@@noalloc]
 
 (* String and byte sequence operations -- more in modules String and Bytes *)
 
diff --git a/stdlib/pervasives.mli b/stdlib/pervasives.mli
index c557612050..c66a0f1901 100644
--- a/stdlib/pervasives.mli
+++ b/stdlib/pervasives.mli
@@ -508,7 +508,8 @@ type fpclass =
 (** The five classes of floating-point numbers, as determined by
    the {!Pervasives.classify_float} function. *)
 
-external classify_float : float -> fpclass = "caml_classify_float"
+external classify_float : (float [@unboxed]) -> fpclass =
+  "caml_classify_float" "caml_classify_float_unboxed" [@@noalloc]
 (** Return the class of the given floating-point number:
    normal, subnormal, zero, infinite, or not a number. *)
 
diff --git a/testsuite/tests/float-unboxing/float_subst_boxed_number.ml b/testsuite/tests/float-unboxing/float_subst_boxed_number.ml
index 2b5d511738..cfa00468e0 100644
--- a/testsuite/tests/float-unboxing/float_subst_boxed_number.ml
+++ b/testsuite/tests/float-unboxing/float_subst_boxed_number.ml
@@ -38,6 +38,20 @@ module PR_6770 = struct
 end
 
 
+let check_noalloc name f =
+  let a0 = Gc.allocated_bytes () in
+  let a1 = Gc.allocated_bytes () in
+  let _x = f () in
+  let a2 = Gc.allocated_bytes () in
+  let alloc = (a2 -. 2. *. a1 +. a0) in
+
+  (* is there a better to test whether we run in native code? *)
+  match Filename.basename Sys.argv.(0) with
+  | "program.byte" | "program.byte.exe" -> ()
+  | "program.native" | "program.native.exe" ->
+    if alloc > 100. then failwith name
+  | _ -> assert false
+
 module GPR_109 = struct
 
   let f () =
@@ -49,18 +63,16 @@ module GPR_109 = struct
     done;
     !r
 
-  let test () =
-    let a0 = Gc.allocated_bytes () in
-    let a1 = Gc.allocated_bytes () in
-    let _x = f () in
-    let a2 = Gc.allocated_bytes () in
-    let alloc = (a2 -. 2. *. a1 +. a0) in
-    assert(alloc < 100.)
-
-    let () =
-      (* is there a better to test whether we run in native code? *)
-      match Filename.basename Sys.argv.(0) with
-      | "program.byte" | "program.byte.exe" -> ()
-      | "program.native" | "program.native.exe" -> test ()
-      | _ -> assert false
+  let () = check_noalloc "gpr 1O9" f
 end
+
+
+let unbox_classify_float () =
+  let x = ref 100. in
+  for i = 1 to 1000 do
+    assert (classify_float !x = FP_normal);
+    x := !x +. 1.
+  done
+
+let () =
+  check_noalloc "classify float" unbox_classify_float