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