summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorXavier Leroy <xavier.leroy@inria.fr>2003-04-01 08:46:39 +0000
committerXavier Leroy <xavier.leroy@inria.fr>2003-04-01 08:46:39 +0000
commit5c7accd134d1d5dfdaeea3a45952781db71fa1b4 (patch)
treea0b4f879e0d84f27af3f90f2211eeb436b4febcd
parent4299f0e028125183c4765388745d0e09ecc07d82 (diff)
Optimisation de Pervasives.compare par strength reduction
git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@5474 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
Diffstat
-rwxr-xr-xboot/ocamlcbin887060 -> 886131 bytes
-rwxr-xr-xboot/ocamllexbin136603 -> 136756 bytes
-rw-r--r--bytecomp/translcore.ml43
-rw-r--r--byterun/floats.c7
-rw-r--r--byterun/int64_native.h2
-rw-r--r--byterun/ints.c45
-rw-r--r--byterun/str.c44
-rw-r--r--otherlibs/threads/pervasives.ml2
-rw-r--r--stdlib/pervasives.ml2
-rw-r--r--stdlib/pervasives.mli2
-rw-r--r--test/Moretest/boxedints.ml36
11 files changed, 136 insertions, 47 deletions
diff --git a/boot/ocamlc b/boot/ocamlc
index 73aed25b8..74913684b 100755
--- a/boot/ocamlc
+++ b/boot/ocamlc
Binary files differ
diff --git a/boot/ocamllex b/boot/ocamllex
index d45b80456..5d30fceb3 100755
--- a/boot/ocamllex
+++ b/boot/ocamllex
Binary files differ
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index 1384dd2d0..bff8a5dcc 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -65,8 +65,9 @@ let comparisons_table = create_hashtable 11 [
prim_native_name = ""; prim_native_float = false},
Pintcomp Clt,
Pfloatcomp Clt,
- Pccall{prim_name = "lessthan"; prim_arity = 2; prim_alloc = false;
- prim_native_name = ""; prim_native_float = false},
+ Pccall{prim_name = "string_lessthan"; prim_arity = 2;
+ prim_alloc = false; prim_native_name = "";
+ prim_native_float = false},
Pbintcomp(Pnativeint, Clt),
Pbintcomp(Pint32, Clt),
Pbintcomp(Pint64, Clt));
@@ -75,8 +76,9 @@ let comparisons_table = create_hashtable 11 [
prim_native_name = ""; prim_native_float = false},
Pintcomp Cgt,
Pfloatcomp Cgt,
- Pccall{prim_name = "greaterthan"; prim_arity = 2; prim_alloc = false;
- prim_native_name = ""; prim_native_float = false},
+ Pccall{prim_name = "string_greaterthan"; prim_arity = 2;
+ prim_alloc = false; prim_native_name = "";
+ prim_native_float = false},
Pbintcomp(Pnativeint, Cgt),
Pbintcomp(Pint32, Cgt),
Pbintcomp(Pint64, Cgt));
@@ -85,8 +87,9 @@ let comparisons_table = create_hashtable 11 [
prim_native_name = ""; prim_native_float = false},
Pintcomp Cle,
Pfloatcomp Cle,
- Pccall{prim_name = "lessequal"; prim_arity = 2; prim_alloc = false;
- prim_native_name = ""; prim_native_float = false},
+ Pccall{prim_name = "string_lessequal"; prim_arity = 2;
+ prim_alloc = false; prim_native_name = "";
+ prim_native_float = false},
Pbintcomp(Pnativeint, Cle),
Pbintcomp(Pint32, Cle),
Pbintcomp(Pint64, Cle));
@@ -95,11 +98,33 @@ let comparisons_table = create_hashtable 11 [
prim_native_name = ""; prim_native_float = false},
Pintcomp Cge,
Pfloatcomp Cge,
- Pccall{prim_name = "greaterequal"; prim_arity = 2; prim_alloc = false;
- prim_native_name = ""; prim_native_float = false},
+ Pccall{prim_name = "string_greaterequal"; prim_arity = 2;
+ prim_alloc = false; prim_native_name = "";
+ prim_native_float = false},
Pbintcomp(Pnativeint, Cge),
Pbintcomp(Pint32, Cge),
- Pbintcomp(Pint64, Cge))
+ Pbintcomp(Pint64, Cge));
+ "%compare",
+ (Pccall{prim_name = "compare"; prim_arity = 2; prim_alloc = true;
+ prim_native_name = ""; prim_native_float = false},
+ Pccall{prim_name = "int_compare"; prim_arity = 2;
+ prim_alloc = false; prim_native_name = "";
+ prim_native_float = false},
+ Pccall{prim_name = "float_compare"; prim_arity = 2;
+ prim_alloc = false; prim_native_name = "";
+ prim_native_float = false},
+ Pccall{prim_name = "string_compare"; prim_arity = 2;
+ prim_alloc = false; prim_native_name = "";
+ prim_native_float = false},
+ Pccall{prim_name = "nativeint_compare"; prim_arity = 2;
+ prim_alloc = false; prim_native_name = "";
+ prim_native_float = false},
+ Pccall{prim_name = "int32_compare"; prim_arity = 2;
+ prim_alloc = false; prim_native_name = "";
+ prim_native_float = false},
+ Pccall{prim_name = "int64_compare"; prim_arity = 2;
+ prim_alloc = false; prim_native_name = "";
+ prim_native_float = false})
]
let primitives_table = create_hashtable 57 [
diff --git a/byterun/floats.c b/byterun/floats.c
index 8b4d8dfb2..e5324c6ed 100644
--- a/byterun/floats.c
+++ b/byterun/floats.c
@@ -322,6 +322,13 @@ CAMLprim value gt_float(value f, value g)
return Val_bool(Double_val(f) > Double_val(g));
}
+CAMLprim value float_compare(value vf, value vg)
+{
+ double f = Double_val(vf);
+ double g = Double_val(vg);
+ return f < g ? Val_int(-1) : f > g ? Val_int(1) : Val_int(0);
+}
+
CAMLprim value float_of_bytes(value s)
{
value d = copy_double(0.0);
diff --git a/byterun/int64_native.h b/byterun/int64_native.h
index cf71b3041..2704411a6 100644
--- a/byterun/int64_native.h
+++ b/byterun/int64_native.h
@@ -17,7 +17,7 @@
so that it has the same interface as the software emulation
provided in int64_emul.h */
-#define I64_compare(x,y) ((x) == (y) ? 0 : (x) < (y) ? -1 : 1)
+#define I64_compare(x,y) (((x) > (y)) - ((x) < (y)))
#define I64_neg(x) (-(x))
#define I64_add(x,y) ((x) + (y))
#define I64_sub(x,y) ((x) - (y))
diff --git a/byterun/ints.c b/byterun/ints.c
index 26c8c9322..fe397c0ee 100644
--- a/byterun/ints.c
+++ b/byterun/ints.c
@@ -97,6 +97,12 @@ long caml_safe_mod(long p, long q)
/* Tagged integers */
+CAMLprim value int_compare(value v1, value v2)
+{
+ int res = (v1 > v2) - (v1 < v2);
+ return Val_int(res);
+}
+
CAMLprim value int_of_string(value s)
{
return Val_long(parse_long(String_val(s)));
@@ -168,11 +174,11 @@ CAMLprim value format_int(value fmt, value arg)
/* 32-bit integers */
-static int int32_compare(value v1, value v2)
+static int int32_cmp(value v1, value v2)
{
int32 i1 = Int32_val(v1);
int32 i2 = Int32_val(v2);
- return i1 == i2 ? 0 : i1 < i2 ? -1 : 1;
+ return (i1 > i2) - (i1 < i2);
}
static long int32_hash(value v)
@@ -196,7 +202,7 @@ static unsigned long int32_deserialize(void * dst)
CAMLexport struct custom_operations int32_ops = {
"_i",
custom_finalize_default,
- int32_compare,
+ int32_cmp,
int32_hash,
int32_serialize,
int32_deserialize
@@ -273,6 +279,14 @@ CAMLprim value int32_of_float(value v)
CAMLprim value int32_to_float(value v)
{ return copy_double((double)(Int32_val(v))); }
+CAMLprim value int32_compare(value v1, value v2)
+{
+ int32 i1 = Int32_val(v1);
+ int32 i2 = Int32_val(v2);
+ int res = (i1 > i2) - (i1 < i2);
+ return Val_int(res);
+}
+
CAMLprim value int32_format(value fmt, value arg)
{
char format_string[FORMAT_BUFFER_SIZE];
@@ -313,7 +327,7 @@ CAMLexport int64 Int64_val(value v)
#endif
-static int int64_compare(value v1, value v2)
+static int int64_cmp(value v1, value v2)
{
int64 i1 = Int64_val(v1);
int64 i2 = Int64_val(v2);
@@ -348,7 +362,7 @@ static unsigned long int64_deserialize(void * dst)
CAMLexport struct custom_operations int64_ops = {
"_j",
custom_finalize_default,
- int64_compare,
+ int64_cmp,
int64_hash,
int64_serialize,
int64_deserialize
@@ -439,6 +453,13 @@ CAMLprim value int64_of_nativeint(value v)
CAMLprim value int64_to_nativeint(value v)
{ return copy_nativeint(I64_to_long(Int64_val(v))); }
+CAMLprim value int64_compare(value v1, value v2)
+{
+ int64 i1 = Int64_val(v1);
+ int64 i2 = Int64_val(v2);
+ return Val_int(I64_compare(i1, i2));
+}
+
#ifdef ARCH_INT64_PRINTF_FORMAT
#define I64_format(buf,fmt,x) sprintf(buf,fmt,x)
#else
@@ -500,11 +521,11 @@ CAMLprim value int64_float_of_bits(value vi)
/* Native integers */
-static int nativeint_compare(value v1, value v2)
+static int nativeint_cmp(value v1, value v2)
{
long i1 = Nativeint_val(v1);
long i2 = Nativeint_val(v2);
- return i1 == i2 ? 0 : i1 < i2 ? -1 : 1;
+ return (i1 > i2) - (i1 < i2);
}
static long nativeint_hash(value v)
@@ -554,7 +575,7 @@ static unsigned long nativeint_deserialize(void * dst)
CAMLexport struct custom_operations nativeint_ops = {
"_n",
custom_finalize_default,
- nativeint_compare,
+ nativeint_cmp,
nativeint_hash,
nativeint_serialize,
nativeint_deserialize
@@ -637,6 +658,14 @@ CAMLprim value nativeint_of_int32(value v)
CAMLprim value nativeint_to_int32(value v)
{ return copy_int32(Nativeint_val(v)); }
+CAMLprim value nativeint_compare(value v1, value v2)
+{
+ long i1 = Nativeint_val(v1);
+ long i2 = Nativeint_val(v2);
+ int res = (i1 > i2) - (i1 < i2);
+ return Val_int(res);
+}
+
CAMLprim value nativeint_format(value fmt, value arg)
{
char format_string[FORMAT_BUFFER_SIZE];
diff --git a/byterun/str.c b/byterun/str.c
index 289a159ff..6f7b7e02d 100644
--- a/byterun/str.c
+++ b/byterun/str.c
@@ -78,6 +78,41 @@ CAMLprim value string_notequal(value s1, value s2)
{
return Val_not(string_equal(s1, s2));
}
+
+CAMLprim value string_compare(value s1, value s2)
+{
+ mlsize_t len1, len2, len;
+ int res;
+
+ len1 = string_length(s1);
+ len2 = string_length(s2);
+ res = memcmp(String_val(s1), String_val(s2), len1 <= len2 ? len1 : len2);
+ if (res < 0) return Val_int(-1);
+ if (res > 0) return Val_int(1);
+ if (len1 < len2) return Val_int(-1);
+ if (len1 > len2) return Val_int(1);
+ return Val_int(0);
+}
+
+CAMLprim value string_lessthan(value s1, value s2)
+{
+ return string_compare(s1, s2) <= Val_int(0) ? Val_true : Val_false;
+}
+
+CAMLprim value string_lessequal(value s1, value s2)
+{
+ return string_compare(s1, s2) < Val_int(0) ? Val_true : Val_false;
+}
+
+CAMLprim value string_greaterthan(value s1, value s2)
+{
+ return string_compare(s1, s2) >= Val_int(0) ? Val_true : Val_false;
+}
+
+CAMLprim value string_greaterequal(value s1, value s2)
+{
+ return string_compare(s1, s2) > Val_int(0) ? Val_true : Val_false;
+}
CAMLprim value blit_string(value s1, value ofs1, value s2, value ofs2, value n)
{
@@ -87,14 +122,7 @@ CAMLprim value blit_string(value s1, value ofs1, value s2, value ofs2, value n)
CAMLprim value fill_string(value s, value offset, value len, value init)
{
- register char * p;
- register mlsize_t n;
- register char c;
-
- c = Long_val(init);
- for(p = &Byte(s, Long_val(offset)), n = Long_val(len);
- n > 0; n--, p++)
- *p = c;
+ memset(&Byte(s, Long_val(offset)), Int_val(init), Long_val(len));
return Val_unit;
}
diff --git a/otherlibs/threads/pervasives.ml b/otherlibs/threads/pervasives.ml
index 007626c26..ec9f40440 100644
--- a/otherlibs/threads/pervasives.ml
+++ b/otherlibs/threads/pervasives.ml
@@ -37,7 +37,7 @@ external (<) : 'a -> 'a -> bool = "%lessthan"
external (>) : 'a -> 'a -> bool = "%greaterthan"
external (<=) : 'a -> 'a -> bool = "%lessequal"
external (>=) : 'a -> 'a -> bool = "%greaterequal"
-external compare: 'a -> 'a -> int = "compare"
+external compare: 'a -> 'a -> int = "%compare"
let min x y = if x <= y then x else y
let max x y = if x >= y then x else y
diff --git a/stdlib/pervasives.ml b/stdlib/pervasives.ml
index 0772aee63..588761e89 100644
--- a/stdlib/pervasives.ml
+++ b/stdlib/pervasives.ml
@@ -32,7 +32,7 @@ external (<) : 'a -> 'a -> bool = "%lessthan"
external (>) : 'a -> 'a -> bool = "%greaterthan"
external (<=) : 'a -> 'a -> bool = "%lessequal"
external (>=) : 'a -> 'a -> bool = "%greaterequal"
-external compare: 'a -> 'a -> int = "compare"
+external compare: 'a -> 'a -> int = "%compare"
let min x y = if x <= y then x else y
let max x y = if x >= y then x else y
diff --git a/stdlib/pervasives.mli b/stdlib/pervasives.mli
index 903dd0db2..00a5cb776 100644
--- a/stdlib/pervasives.mli
+++ b/stdlib/pervasives.mli
@@ -73,7 +73,7 @@ external ( >= ) : 'a -> 'a -> bool = "%greaterequal"
Comparison between functional values may raise [Invalid_argument].
Comparison between cyclic structures may not terminate. *)
-external compare : 'a -> 'a -> int = "compare"
+external compare : 'a -> 'a -> int = "%compare"
(** [compare x y] returns [0] if [x=y], a negative integer if
[x<y], and a positive integer if [x>y]. The same restrictions
as for [=] apply. [compare] can be used as the comparison function
diff --git a/test/Moretest/boxedints.ml b/test/Moretest/boxedints.ml
index 9c4861297..d5a1d5ba7 100644
--- a/test/Moretest/boxedints.ml
+++ b/test/Moretest/boxedints.ml
@@ -53,7 +53,7 @@ module type TESTSIG = sig
val to_string: t -> string
val of_string: string -> t
end
- val testcomp: t -> t -> bool*bool*bool*bool*bool*bool
+ val testcomp: t -> t -> bool*bool*bool*bool*bool*bool*int
end
module Test32(M: TESTSIG) =
@@ -264,19 +264,19 @@ struct
testing_function "Comparisons";
test 1 (testcomp (of_int 0) (of_int 0))
- (true,false,false,false,true,true);
+ (true,false,false,false,true,true,0);
test 2 (testcomp (of_int 1234567) (of_int 1234567))
- (true,false,false,false,true,true);
+ (true,false,false,false,true,true,0);
test 3 (testcomp (of_int 0) (of_int 1))
- (false,true,true,false,true,false);
+ (false,true,true,false,true,false,-1);
test 4 (testcomp (of_int (-1)) (of_int 0))
- (false,true,true,false,true,false);
+ (false,true,true,false,true,false,-1);
test 5 (testcomp (of_int 1) (of_int 0))
- (false,true,false,true,false,true);
+ (false,true,false,true,false,true,1);
test 6 (testcomp (of_int 0) (of_int (-1)))
- (false,true,false,true,false,true);
+ (false,true,false,true,false,true,1);
test 7 (testcomp max_int min_int)
- (false,true,false,true,false,true);
+ (false,true,false,true,false,true,1);
()
end
@@ -480,19 +480,19 @@ struct
testing_function "Comparisons";
test 1 (testcomp (of_int 0) (of_int 0))
- (true,false,false,false,true,true);
+ (true,false,false,false,true,true,0);
test 2 (testcomp (of_int 1234567) (of_int 1234567))
- (true,false,false,false,true,true);
+ (true,false,false,false,true,true,0);
test 3 (testcomp (of_int 0) (of_int 1))
- (false,true,true,false,true,false);
+ (false,true,true,false,true,false,-1);
test 4 (testcomp (of_int (-1)) (of_int 0))
- (false,true,true,false,true,false);
+ (false,true,true,false,true,false,-1);
test 5 (testcomp (of_int 1) (of_int 0))
- (false,true,false,true,false,true);
+ (false,true,false,true,false,true,1);
test 6 (testcomp (of_int 0) (of_int (-1)))
- (false,true,false,true,false,true);
+ (false,true,false,true,false,true,1);
test 7 (testcomp max_int min_int)
- (false,true,false,true,false,true);
+ (false,true,false,true,false,true,1);
()
end
@@ -500,11 +500,11 @@ end
(******** The test proper **********)
let testcomp_int32 (a : int32) (b : int32) =
- (a = b, a <> b, a < b, a > b, a <= b, a >= b)
+ (a = b, a <> b, a < b, a > b, a <= b, a >= b, compare a b)
let testcomp_int64 (a : int64) (b : int64) =
- (a = b, a <> b, a < b, a > b, a <= b, a >= b)
+ (a = b, a <> b, a < b, a > b, a <= b, a >= b, compare a b)
let testcomp_nativeint (a : nativeint) (b : nativeint) =
- (a = b, a <> b, a < b, a > b, a <= b, a >= b)
+ (a = b, a <> b, a < b, a > b, a <= b, a >= b, compare a b)
let _ =
testing_function "-------- Int32 --------";
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-21 19:14:23 +0000