cycle_detection.diff

diff --git src/runtime/compare.c src/runtime/compare.c
index 7137e64..4f2503f 100644
--- src/runtime/compare.c
+++ src/runtime/compare.c
@@ -5,14 +5,153 @@
 #include "str.h"
 
 /* Structural comparison on trees.
-   May loop on cyclic structures. */
+   循環構造は検出される
+   ただしそれぞれで循環を何回か回った後で結果が出るような場合は
+   この実装では例外が出て比較不能 */
+/* たどってきたパスで訪れたvalueを登録しておく
+   depth は循環の周期を求めるのに使う */
+typedef struct{
+  value obj;
+  unsigned long depth;
+} visited_obj;
+visited_obj * visited_table[2];
+unsigned long visited_table_size[2], visited_table_used[2];
+unsigned long cycle_min[2];
+unsigned long current_depth;
 
-static long compare_val(v1, v2)
+
+#ifdef CAML_SIXTYFOUR
+#define Hash(v,x) (((unsigned long) ((v) >> 3)) % visited_table_size[x])
+#else
+#define Hash(v,x) (((unsigned long) ((v) >> 2)) % visited_table_size[x])
+#endif
+
+#define INITIAL_VISITED_TABLE_SIZE 2039
+
+static void alloc_visited_table(int x)
+{
+  asize_t i;
+
+  visited_table[x] = (visited_obj *) stat_alloc(visited_table_size[x] * sizeof(visited_obj));
+  for (i = 0; i < visited_table_size[x]; i++)
+    visited_table[x][i].obj = 0;
+}
+
+static void resize_visited_table(int x)
+{
+  asize_t oldsize;
+  visited_obj * oldtable;
+  asize_t i, h;
+
+  oldsize = visited_table_size[x];
+  oldtable = visited_table[x];
+  visited_table_size[x] = 2 * oldsize;
+  alloc_visited_table(x);
+  for (i = 0; i < oldsize; i++) {
+    h = Hash(oldtable[i].obj, x);
+    while (visited_table[x][h].obj != 0) {
+      h++;
+      if (h >= visited_table_size[x]) h = 0;
+    }
+    visited_table[x][h].obj = oldtable[i].obj;
+    visited_table[x][h].depth = oldtable[i].depth;
+  }
+  stat_free((char *) oldtable);
+}
+
+/* v を visited_table に追加する
+   すでに v が存在するときにはその cycle length が返る */
+static unsigned long add_value(value v, int x)
+{
+  asize_t h;
+
+  if (2 * visited_table_used[x] >= visited_table_size[x]) resize_visited_table(x);
+  h = Hash(v, x);
+  while (visited_table[x][h].obj != 0) {
+    if (visited_table[x][h].obj == v)
+      return current_depth - visited_table[x][h].depth;
+    h++;
+    if (h >= visited_table_size[x]) h = 0;
+  }
+  visited_table[x][h].obj = v;
+  visited_table[x][h].depth = current_depth;
+  visited_table_used[x]++;
+  return 0;
+}
+
+/* v を visited_table から取り除く */
+static void remove_value(value v, int x)
+{
+  asize_t h = Hash(v, x);
+  while (visited_table[x][h].obj != 0 && visited_table[x][h].obj != v) {
+    h++;
+    if (h >= visited_table_size[x]) h = 0;
+  }
+  visited_table[x][h].obj = 0;
+}
+
+static void init_cycle_check()
+{
+  int x;
+  for (x = 0; x < 2; x++)
+  {
+    visited_table_size[x] = INITIAL_VISITED_TABLE_SIZE;
+    alloc_visited_table(x);
+    visited_table_used[x] = 0;
+    cycle_min[x] = 0;
+    current_depth = 0;
+  }
+}
+
+static void finalize_cycle_check()
+{
+  int x;
+  for (x = 0; x < 2; x++)
+    stat_free((char *) visited_table[x]);
+}
+
+static void begin_cycle_check(value v1, value v2)
+{
+  unsigned long cycle[2];
+  int x;
+  
+  cycle[0] = add_value(v1, 0);
+  cycle[1] = add_value(v2, 1);
+  // 最小循環長さ
+  for (x = 0; x < 2; x++)
+    if(!cycle_min[x])
+      cycle_min[x] = cycle[x];
+
+  // 左右どちらの値も循環した場合
+  if(cycle[0] && cycle[1])
+  {
+    int ahead, behind;
+
+    ahead = cycle[0] >= cycle[1] ? 0 : 1; // 先に循環に突入した方
+    behind = ahead ? 0 : 1; //後に循環に突入した方
+    // 後に循環した方の循環長さが先に循環した方の最小循環長さの倍数の時
+    // 循環長さだけ遡ったときと同じ状況が発生しているので例外を出して終了
+    if(! (cycle[behind] % cycle_min[ahead]))
+    {
+      finalize_cycle_check();
+      invalid_argument("equal: cyclic value");
+    }
+  }
+  current_depth++;
+}
+
+static void end_cycle_check(value v1, value v2)
+{
+  remove_value(v1, 0); remove_value(v2, 1);
+  cycle_min[0] = 0; cycle_min[1] = 0;
+  current_depth--;
+}
+
+static long _compare_val(v1, v2)
      value v1,v2;
 {
   tag_t t1, t2;
 
- tailcall:
   if (v1 == v2) return 0;
   if (Is_long(v1) || Is_long(v2)) return Long_val(v1) - Long_val(v2);
   /* If one of the objects is outside the heap (but is not an atom),
@@ -53,19 +192,30 @@ static long compare_val(v1, v2)
     value * p1, * p2;
     long res;
     if (sz1 != sz2) return sz1 - sz2;
+
+    // 循環構造を検出
+    begin_cycle_check(v1, v2);
     for(p1 = Op_val(v1), p2 = Op_val(v2);
-        sz1 > 1;
+        sz1 > 0;
         sz1--, p1++, p2++) {
-      res = compare_val(*p1, *p2);
-      if (res != 0) return res;
+      res = _compare_val(*p1, *p2);
+      if (res != 0) break;
     }
-    v1 = *p1;
-    v2 = *p2;
-    goto tailcall;
+    end_cycle_check(v1, v2);
+    return res;
   }
   }
 }
 
+static long compare_val(v1, v2)
+     value v1,v2;
+{
+  init_cycle_check();
+  long res = _compare_val(v1, v2);
+  finalize_cycle_check();
+  return res;
+}
+
 value compare(v1, v2)           /* ML */
      value v1, v2;
 {