1 files changed, 173 insertions, 78 deletions
diff --git a/byterun/compare.c b/byterun/compare.c
index a75e37e1f..58f4fe361 100644
--- a/byterun/compare.c
+++ b/byterun/compare.c
@@ -12,100 +12,183 @@
 
 /* $Id$ */
 
+#include <string.h>
+#include <stdlib.h>
 #include "custom.h"
 #include "fail.h"
 #include "memory.h"
 #include "misc.h"
 #include "mlvalues.h"
 
-/* Structural comparison on trees.
-   May loop on cyclic structures. */
+/* Structural comparison on trees. */
+
+struct compare_item { value * v1, * v2; mlsize_t count; };
+
+#define COMPARE_STACK_INIT_SIZE 256
+#define COMPARE_STACK_MAX_SIZE 1024*1024
+
+static struct compare_item compare_stack_init[COMPARE_STACK_INIT_SIZE];
+
+static struct compare_item * compare_stack = compare_stack_init;
+static struct compare_item * compare_stack_limit = compare_stack_init
+                                                   + COMPARE_STACK_INIT_SIZE;
+
+/* Free the compare stack if needed */
+static void compare_free_stack(void)
+{
+  if (compare_stack != compare_stack_init) {
+    stat_free(compare_stack);
+    /* Reinitialize the globals for next time around */
+    compare_stack = compare_stack_init;
+    compare_stack_limit = compare_stack + COMPARE_STACK_INIT_SIZE;
+  }
+}
+
+/* Same, then raise Stack_overflow */
+static void compare_stack_overflow(void)
+{
+  compare_free_stack();
+#if 0
+  raise_stack_overflow();
+#else
+  raise_out_of_memory();
+#endif
+}
+
+/* Grow the compare stack */
+static struct compare_item * compare_resize_stack(struct compare_item * sp)
+{
+  asize_t newsize = 2 * (compare_stack_limit - compare_stack);
+  asize_t sp_offset = sp - compare_stack;
+  struct compare_item * newstack;
+
+  if (newsize >= COMPARE_STACK_MAX_SIZE) compare_stack_overflow();
+  if (compare_stack == compare_stack_init) {
+    newstack = malloc(sizeof(struct compare_item) * newsize);
+    if (newstack == NULL) compare_stack_overflow();
+    memcpy(newstack, compare_stack_init,
+           sizeof(struct compare_item) * COMPARE_STACK_INIT_SIZE);
+  } else {
+    newstack =
+      realloc(compare_stack, sizeof(struct compare_item) * newsize);
+    if (newstack == NULL) compare_stack_overflow();
+  }
+  compare_stack = newstack;
+  compare_stack_limit = newstack + newsize;
+  return newstack + sp_offset;
+}
+
+/* Structural comparison */
 
 static long compare_val(value v1, value v2)
 {
+  struct compare_item * sp;
   tag_t t1, t2;
 
- tailcall:
-  if (v1 == v2) return 0;
-  if (Is_long(v1)) {
-    if (Is_long(v2))
-      return Long_val(v1) - Long_val(v2);
-    else
-      return -1;
-  }
-  if (Is_long(v2)) return 1;
-  /* If one of the objects is outside the heap (but is not an atom),
-     use address comparison. Since both addresses are 2-aligned,
-     shift lsb off to avoid overflow in subtraction. */
-  if ((!Is_atom(v1) && !Is_young(v1) && !Is_in_heap(v1)) ||
-      (!Is_atom(v2) && !Is_young(v2) && !Is_in_heap(v2)))
+  sp = compare_stack;
+  while (1) {
+    if (v1 == v2) goto next_item;
+    if (Is_long(v1)) {
+      if (Is_long(v2))
+        return Long_val(v1) - Long_val(v2);
+      else
+        return -1;
+    }
+    if (Is_long(v2)) return 1;
+    /* If one of the objects is outside the heap (but is not an atom),
+       use address comparison. Since both addresses are 2-aligned,
+       shift lsb off to avoid overflow in subtraction. */
+    if ((!Is_atom(v1) && !Is_young(v1) && !Is_in_heap(v1)) ||
+        (!Is_atom(v2) && !Is_young(v2) && !Is_in_heap(v2)))
       return (v1 >> 1) - (v2 >> 1);
-  t1 = Tag_val(v1);
-  t2 = Tag_val(v2);
-  if (t1 != t2) return (long)t1 - (long)t2;
-  switch(t1) {
-  case String_tag: {
-    mlsize_t len1, len2, len;
-    unsigned char * p1, * p2;
-    len1 = string_length(v1);
-    len2 = string_length(v2);
-    for (len = (len1 <= len2 ? len1 : len2),
-         p1 = (unsigned char *) String_val(v1),
-         p2 = (unsigned char *) String_val(v2);
-         len > 0;
-         len--, p1++, p2++)
-      if (*p1 != *p2) return (long)*p1 - (long)*p2;
-    return len1 - len2;
-  }
-  case Double_tag: {
-    double d1 = Double_val(v1);
-    double d2 = Double_val(v2);
-    if (d1 < d2) return -1; else if (d1 > d2) return 1; else return 0;
-  }
-  case Double_array_tag: {
-    mlsize_t sz1 = Wosize_val(v1) / Double_wosize;
-    mlsize_t sz2 = Wosize_val(v2) / Double_wosize;
-    mlsize_t i;
-    if (sz1 != sz2) return sz1 - sz2;
-    for (i = 0; i < sz1; i++) {
-      double d1 = Double_field(v1, i);
-      double d2 = Double_field(v2, i);
+    t1 = Tag_val(v1);
+    t2 = Tag_val(v2);
+    if (t1 != t2) return (long)t1 - (long)t2;
+    switch(t1) {
+    case String_tag: {
+      mlsize_t len1, len2, len;
+      unsigned char * p1, * p2;
+      len1 = string_length(v1);
+      len2 = string_length(v2);
+      for (len = (len1 <= len2 ? len1 : len2),
+             p1 = (unsigned char *) String_val(v1),
+             p2 = (unsigned char *) String_val(v2);
+           len > 0;
+           len--, p1++, p2++)
+        if (*p1 != *p2) return (long)*p1 - (long)*p2;
+      if (len1 != len2) return len1 - len2;
+      break;
+    }
+    case Double_tag: {
+      double d1 = Double_val(v1);
+      double d2 = Double_val(v2);
       if (d1 < d2) return -1; else if (d1 > d2) return 1;
+      break;
     }
-    return 0;
-  }
-  case Abstract_tag:
-    invalid_argument("equal: abstract value");
-  case Closure_tag:
-  case Infix_tag:
-    invalid_argument("equal: functional value");
-  case Object_tag:
-    return (Oid_val(v1) - Oid_val(v2));
-  case Custom_tag:
-    return Custom_ops_val(v1)->compare(v1, v2);
-  default: {
-    mlsize_t sz1 = Wosize_val(v1);
-    mlsize_t sz2 = Wosize_val(v2);
-    value * p1, * p2;
-    long res;
-    if (sz1 != sz2) return sz1 - sz2;
-    if (sz1 == 0) return 0;
-    for(p1 = Op_val(v1), p2 = Op_val(v2);
-        sz1 > 1;
-        sz1--, p1++, p2++) {
-      res = compare_val(*p1, *p2);
+    case Double_array_tag: {
+      mlsize_t sz1 = Wosize_val(v1) / Double_wosize;
+      mlsize_t sz2 = Wosize_val(v2) / Double_wosize;
+      mlsize_t i;
+      if (sz1 != sz2) return sz1 - sz2;
+      for (i = 0; i < sz1; i++) {
+        double d1 = Double_field(v1, i);
+        double d2 = Double_field(v2, i);
+        if (d1 < d2) return -1; else if (d1 > d2) return 1;
+      }
+      break;
+    }
+    case Abstract_tag:
+      compare_free_stack();
+      invalid_argument("equal: abstract value");
+    case Closure_tag:
+    case Infix_tag:
+      compare_free_stack();
+      invalid_argument("equal: functional value");
+    case Object_tag: {
+      long oid1 = Oid_val(v1);
+      long oid2 = Oid_val(v2);
+      if (oid1 != oid2) return oid1 - oid2;
+      break;
+    }
+    case Custom_tag: {
+      int res = Custom_ops_val(v1)->compare(v1, v2);
       if (res != 0) return res;
+      break;
     }
-    v1 = *p1;
-    v2 = *p2;
-    goto tailcall;
-  }
+    default: {
+      mlsize_t sz1 = Wosize_val(v1);
+      mlsize_t sz2 = Wosize_val(v2);
+      /* Compare sizes first for speed */
+      if (sz1 != sz2) return sz1 - sz2;
+      if (sz1 == 0) break;
+      /* Remember that we still have to compare fields 1 ... sz - 1 */
+      if (sz1 > 1) {
+        sp++;
+        if (sp >= compare_stack_limit) sp = compare_resize_stack(sp);
+        sp->v1 = &Field(v1, 1);
+        sp->v2 = &Field(v2, 1);
+        sp->count = sz1 - 1;
+      }
+      /* Continue comparison with first field */
+      v1 = Field(v1, 0);
+      v2 = Field(v2, 0);
+      continue;
+    }
+    }
+  next_item:
+    /* Pop one more item to compare, if any */
+    if (sp == compare_stack) return 0; /* we're done */
+    v1 = *(sp->v1)++;
+    v2 = *(sp->v2)++;
+    if (--(sp->count) == 0) sp--;
   }
 }
 
 value compare(value v1, value v2)           /* ML */
 {
   long res = compare_val(v1, v2);
+  /* Free stack if needed */
+  if (compare_stack != compare_stack_init) compare_free_stack();
   if (res < 0) 
     return Val_int(-1);
   else if (res > 0)
@@ -116,30 +199,42 @@ value compare(value v1, value v2)           /* ML */
 
 value equal(value v1, value v2)            /* ML */
 {
-  return Val_int(compare_val(v1, v2) == 0);
+  long res = compare_val(v1, v2);
+  if (compare_stack != compare_stack_init) compare_free_stack();
+  return Val_int(res == 0);
 }
 
 value notequal(value v1, value v2)            /* ML */
 {
-  return Val_int(compare_val(v1, v2) != 0);
+  long res = compare_val(v1, v2);
+  if (compare_stack != compare_stack_init) compare_free_stack();
+  return Val_int(res != 0);
 }
 
 value lessthan(value v1, value v2)            /* ML */
 {
-  return Val_int(compare_val(v1, v2) < 0);
+  long res = compare_val(v1, v2);
+  if (compare_stack != compare_stack_init) compare_free_stack();
+  return Val_int(res < 0);
 }
 
 value lessequal(value v1, value v2)          /* ML */
 {
-  return Val_int(compare_val(v1, v2) <= 0);
+  long res = compare_val(v1, v2);
+  if (compare_stack != compare_stack_init) compare_free_stack();
+  return Val_int(res <= 0);
 }
 
 value greaterthan(value v1, value v2)        /* ML */
 {
-  return Val_int(compare_val(v1, v2) > 0);
+  long res = compare_val(v1, v2);
+  if (compare_stack != compare_stack_init) compare_free_stack();
+  return Val_int(res > 0);
 }
 
 value greaterequal(value v1, value v2)       /* ML */
 {
-  return Val_int(compare_val(v1, v2) >= 0);
+  long res = compare_val(v1, v2);
+  if (compare_stack != compare_stack_init) compare_free_stack();
+  return Val_int(res >= 0);
 }