l4/pkg/ocaml/contrib/byterun/compare.c

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