1 /**************************************************************************/
2 /* */
3 /* OCaml */
4 /* */
5 /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
6 /* */
7 /* Copyright 1996 Institut National de Recherche en Informatique et */
8 /* en Automatique. */
9 /* */
10 /* All rights reserved. This file is distributed under the terms of */
11 /* the GNU Lesser General Public License version 2.1, with the */
12 /* special exception on linking described in the file LICENSE. */
13 /* */
14 /**************************************************************************/
15
16 #define CAML_INTERNALS
17
18 #include <string.h>
19 #include <stdlib.h>
20 #include "caml/custom.h"
21 #include "caml/fail.h"
22 #include "caml/memory.h"
23 #include "caml/misc.h"
24 #include "caml/mlvalues.h"
25
26 #if defined(LACKS_SANE_NAN) && !defined(isnan)
27 #define isnan _isnan
28 #endif
29
30 /* Structural comparison on trees. */
31
32 struct compare_item { value * v1, * v2; mlsize_t count; };
33
34 #define COMPARE_STACK_INIT_SIZE 256
35 #define COMPARE_STACK_MAX_SIZE (1024*1024)
36
37 static struct compare_item compare_stack_init[COMPARE_STACK_INIT_SIZE];
38
39 static struct compare_item * compare_stack = compare_stack_init;
40 static struct compare_item * compare_stack_limit = compare_stack_init
41 + COMPARE_STACK_INIT_SIZE;
42
43 CAMLexport int caml_compare_unordered;
44
45 /* Free the compare stack if needed */
compare_free_stack(void)46 static void compare_free_stack(void)
47 {
48 if (compare_stack != compare_stack_init) {
49 free(compare_stack);
50 /* Reinitialize the globals for next time around */
51 compare_stack = compare_stack_init;
52 compare_stack_limit = compare_stack + COMPARE_STACK_INIT_SIZE;
53 }
54 }
55
56 /* Same, then raise Out_of_memory */
compare_stack_overflow(void)57 static void compare_stack_overflow(void)
58 {
59 caml_gc_message (0x04, "Stack overflow in structural comparison\n", 0);
60 compare_free_stack();
61 caml_raise_out_of_memory();
62 }
63
64 /* Grow the compare stack */
compare_resize_stack(struct compare_item * sp)65 static struct compare_item * compare_resize_stack(struct compare_item * sp)
66 {
67 asize_t newsize = 2 * (compare_stack_limit - compare_stack);
68 asize_t sp_offset = sp - compare_stack;
69 struct compare_item * newstack;
70
71 if (newsize >= COMPARE_STACK_MAX_SIZE) compare_stack_overflow();
72 if (compare_stack == compare_stack_init) {
73 newstack = malloc(sizeof(struct compare_item) * newsize);
74 if (newstack == NULL) compare_stack_overflow();
75 memcpy(newstack, compare_stack_init,
76 sizeof(struct compare_item) * COMPARE_STACK_INIT_SIZE);
77 } else {
78 newstack =
79 realloc(compare_stack, sizeof(struct compare_item) * newsize);
80 if (newstack == NULL) compare_stack_overflow();
81 }
82 compare_stack = newstack;
83 compare_stack_limit = newstack + newsize;
84 return newstack + sp_offset;
85 }
86
87 /* Structural comparison */
88
89 #define LESS -1
90 #define EQUAL 0
91 #define GREATER 1
92 #define UNORDERED ((intnat)1 << (8 * sizeof(value) - 1))
93
94 /* The return value of compare_val is as follows:
95 > 0 v1 is greater than v2
96 0 v1 is equal to v2
97 < 0 and > UNORDERED v1 is less than v2
98 UNORDERED v1 and v2 cannot be compared */
99
compare_val(value v1,value v2,int total)100 static intnat compare_val(value v1, value v2, int total)
101 {
102 struct compare_item * sp;
103 tag_t t1, t2;
104
105 sp = compare_stack;
106 while (1) {
107 if (v1 == v2 && total) goto next_item;
108 if (Is_long(v1)) {
109 if (v1 == v2) goto next_item;
110 if (Is_long(v2))
111 return Long_val(v1) - Long_val(v2);
112 /* Subtraction above cannot overflow and cannot result in UNORDERED */
113 if (Is_in_value_area(v2)) {
114 switch (Tag_val(v2)) {
115 case Forward_tag:
116 v2 = Forward_val(v2);
117 continue;
118 case Custom_tag: {
119 int res;
120 int (*compare)(value v1, value v2) = Custom_ops_val(v2)->compare_ext;
121 if (compare == NULL) break; /* for backward compatibility */
122 caml_compare_unordered = 0;
123 res = compare(v1, v2);
124 if (caml_compare_unordered && !total) return UNORDERED;
125 if (res != 0) return res;
126 goto next_item;
127 }
128 default: /*fallthrough*/;
129 }
130 }
131 return LESS; /* v1 long < v2 block */
132 }
133 if (Is_long(v2)) {
134 if (Is_in_value_area(v1)) {
135 switch (Tag_val(v1)) {
136 case Forward_tag:
137 v1 = Forward_val(v1);
138 continue;
139 case Custom_tag: {
140 int res;
141 int (*compare)(value v1, value v2) = Custom_ops_val(v1)->compare_ext;
142 if (compare == NULL) break; /* for backward compatibility */
143 caml_compare_unordered = 0;
144 res = compare(v1, v2);
145 if (caml_compare_unordered && !total) return UNORDERED;
146 if (res != 0) return res;
147 goto next_item;
148 }
149 default: /*fallthrough*/;
150 }
151 }
152 return GREATER; /* v1 block > v2 long */
153 }
154 /* If one of the objects is outside the heap (but is not an atom),
155 use address comparison. Since both addresses are 2-aligned,
156 shift lsb off to avoid overflow in subtraction. */
157 if (! Is_in_value_area(v1) || ! Is_in_value_area(v2)) {
158 if (v1 == v2) goto next_item;
159 return (v1 >> 1) - (v2 >> 1);
160 /* Subtraction above cannot result in UNORDERED */
161 }
162 t1 = Tag_val(v1);
163 t2 = Tag_val(v2);
164 if (t1 == Forward_tag) { v1 = Forward_val (v1); continue; }
165 if (t2 == Forward_tag) { v2 = Forward_val (v2); continue; }
166 if (t1 != t2) return (intnat)t1 - (intnat)t2;
167 switch(t1) {
168 case String_tag: {
169 mlsize_t len1, len2;
170 int res;
171 if (v1 == v2) break;
172 len1 = caml_string_length(v1);
173 len2 = caml_string_length(v2);
174 res = memcmp(String_val(v1), String_val(v2), len1 <= len2 ? len1 : len2);
175 if (res < 0) return LESS;
176 if (res > 0) return GREATER;
177 if (len1 != len2) return len1 - len2;
178 break;
179 }
180 case Double_tag: {
181 double d1 = Double_val(v1);
182 double d2 = Double_val(v2);
183 #ifdef LACKS_SANE_NAN
184 if (isnan(d2)) {
185 if (! total) return UNORDERED;
186 if (isnan(d1)) break;
187 return GREATER;
188 } else if (isnan(d1)) {
189 if (! total) return UNORDERED;
190 return LESS;
191 }
192 #endif
193 if (d1 < d2) return LESS;
194 if (d1 > d2) return GREATER;
195 #ifndef LACKS_SANE_NAN
196 if (d1 != d2) {
197 if (! total) return UNORDERED;
198 /* One or both of d1 and d2 is NaN. Order according to the
199 convention NaN = NaN and NaN < f for all other floats f. */
200 if (d1 == d1) return GREATER; /* d1 is not NaN, d2 is NaN */
201 if (d2 == d2) return LESS; /* d2 is not NaN, d1 is NaN */
202 /* d1 and d2 are both NaN, thus equal: continue comparison */
203 }
204 #endif
205 break;
206 }
207 case Double_array_tag: {
208 mlsize_t sz1 = Wosize_val(v1) / Double_wosize;
209 mlsize_t sz2 = Wosize_val(v2) / Double_wosize;
210 mlsize_t i;
211 if (sz1 != sz2) return sz1 - sz2;
212 for (i = 0; i < sz1; i++) {
213 double d1 = Double_field(v1, i);
214 double d2 = Double_field(v2, i);
215 #ifdef LACKS_SANE_NAN
216 if (isnan(d2)) {
217 if (! total) return UNORDERED;
218 if (isnan(d1)) break;
219 return GREATER;
220 } else if (isnan(d1)) {
221 if (! total) return UNORDERED;
222 return LESS;
223 }
224 #endif
225 if (d1 < d2) return LESS;
226 if (d1 > d2) return GREATER;
227 #ifndef LACKS_SANE_NAN
228 if (d1 != d2) {
229 if (! total) return UNORDERED;
230 /* See comment for Double_tag case */
231 if (d1 == d1) return GREATER;
232 if (d2 == d2) return LESS;
233 }
234 #endif
235 }
236 break;
237 }
238 case Abstract_tag:
239 compare_free_stack();
240 caml_invalid_argument("compare: abstract value");
241 case Closure_tag:
242 case Infix_tag:
243 compare_free_stack();
244 caml_invalid_argument("compare: functional value");
245 case Object_tag: {
246 intnat oid1 = Oid_val(v1);
247 intnat oid2 = Oid_val(v2);
248 if (oid1 != oid2) return oid1 - oid2;
249 break;
250 }
251 case Custom_tag: {
252 int res;
253 int (*compare)(value v1, value v2) = Custom_ops_val(v1)->compare;
254 /* Hardening against comparisons between different types */
255 if (compare != Custom_ops_val(v2)->compare) {
256 return strcmp(Custom_ops_val(v1)->identifier,
257 Custom_ops_val(v2)->identifier) < 0
258 ? LESS : GREATER;
259 }
260 if (compare == NULL) {
261 compare_free_stack();
262 caml_invalid_argument("compare: abstract value");
263 }
264 caml_compare_unordered = 0;
265 res = compare(v1, v2);
266 if (caml_compare_unordered && !total) return UNORDERED;
267 if (res != 0) return res;
268 break;
269 }
270 default: {
271 mlsize_t sz1 = Wosize_val(v1);
272 mlsize_t sz2 = Wosize_val(v2);
273 /* Compare sizes first for speed */
274 if (sz1 != sz2) return sz1 - sz2;
275 if (sz1 == 0) break;
276 /* Remember that we still have to compare fields 1 ... sz - 1 */
277 if (sz1 > 1) {
278 sp++;
279 if (sp >= compare_stack_limit) sp = compare_resize_stack(sp);
280 sp->v1 = &Field(v1, 1);
281 sp->v2 = &Field(v2, 1);
282 sp->count = sz1 - 1;
283 }
284 /* Continue comparison with first field */
285 v1 = Field(v1, 0);
286 v2 = Field(v2, 0);
287 continue;
288 }
289 }
290 next_item:
291 /* Pop one more item to compare, if any */
292 if (sp == compare_stack) return EQUAL; /* we're done */
293 v1 = *((sp->v1)++);
294 v2 = *((sp->v2)++);
295 if (--(sp->count) == 0) sp--;
296 }
297 }
298
caml_compare(value v1,value v2)299 CAMLprim value caml_compare(value v1, value v2)
300 {
301 intnat res = compare_val(v1, v2, 1);
302 /* Free stack if needed */
303 if (compare_stack != compare_stack_init) compare_free_stack();
304 if (res < 0)
305 return Val_int(LESS);
306 else if (res > 0)
307 return Val_int(GREATER);
308 else
309 return Val_int(EQUAL);
310 }
311
caml_equal(value v1,value v2)312 CAMLprim value caml_equal(value v1, value v2)
313 {
314 intnat res = compare_val(v1, v2, 0);
315 if (compare_stack != compare_stack_init) compare_free_stack();
316 return Val_int(res == 0);
317 }
318
caml_notequal(value v1,value v2)319 CAMLprim value caml_notequal(value v1, value v2)
320 {
321 intnat res = compare_val(v1, v2, 0);
322 if (compare_stack != compare_stack_init) compare_free_stack();
323 return Val_int(res != 0);
324 }
325
caml_lessthan(value v1,value v2)326 CAMLprim value caml_lessthan(value v1, value v2)
327 {
328 intnat res = compare_val(v1, v2, 0);
329 if (compare_stack != compare_stack_init) compare_free_stack();
330 return Val_int(res < 0 && res != UNORDERED);
331 }
332
caml_lessequal(value v1,value v2)333 CAMLprim value caml_lessequal(value v1, value v2)
334 {
335 intnat res = compare_val(v1, v2, 0);
336 if (compare_stack != compare_stack_init) compare_free_stack();
337 return Val_int(res <= 0 && res != UNORDERED);
338 }
339
caml_greaterthan(value v1,value v2)340 CAMLprim value caml_greaterthan(value v1, value v2)
341 {
342 intnat res = compare_val(v1, v2, 0);
343 if (compare_stack != compare_stack_init) compare_free_stack();
344 return Val_int(res > 0);
345 }
346
caml_greaterequal(value v1,value v2)347 CAMLprim value caml_greaterequal(value v1, value v2)
348 {
349 intnat res = compare_val(v1, v2, 0);
350 if (compare_stack != compare_stack_init) compare_free_stack();
351 return Val_int(res >= 0);
352 }
353