lazy a la Tolmach

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@4291 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

11 files changed, 69 insertions, 22 deletions

diff --git a/byterun/compare.c b/byterun/compare.c
index 6b95269144..14bec7b4f1 100644
--- a/byterun/compare.c
+++ b/byterun/compare.c
@@ -84,6 +84,8 @@ static long compare_val(value v1, value v2)
 
   sp = compare_stack;
   while (1) {
+    while (Is_block (v1) && Tag_val (v1) == Forward_tag) v1 = Forward_val (v1);
+    while (Is_block (v2) && Tag_val (v2) == Forward_tag) v2 = Forward_val (v2);
     if (v1 == v2) goto next_item;
     if (Is_long(v1)) {
       if (Is_long(v2))
diff --git a/byterun/extern.c b/byterun/extern.c
index eae5530aa6..c03e1ea955 100644
--- a/byterun/extern.c
+++ b/byterun/extern.c
@@ -317,6 +317,9 @@ static void extern_rec(value v)
       writecode32(CODE_INFIXPOINTER, Infix_offset_hd(hd));
       extern_rec(v - Infix_offset_hd(hd));
       break;
+    case Forward_tag:
+      v = Forward_val (v);
+      goto tailcall;
     case Object_tag:
       extern_invalid_argument("output_value: object value");
       break;
diff --git a/byterun/hash.c b/byterun/hash.c
index 0138669734..24cd96df12 100644
--- a/byterun/hash.c
+++ b/byterun/hash.c
@@ -49,6 +49,7 @@ static void hash_aux(value obj)
   hash_univ_limit--;
   if (hash_univ_count < 0 || hash_univ_limit < 0) return;
 
+ again:
   if (Is_long(obj)) {
     hash_univ_count--;
     Combine(Long_val(obj));
@@ -57,7 +58,8 @@ static void hash_aux(value obj)
 
   /* Pointers into the heap are well-structured blocks. So are atoms.
      We can inspect the block contents. */
-  
+
+  Assert (Is_block (obj));  
   if (Is_atom(obj) || Is_young(obj) || Is_in_heap(obj)) {
     tag = Tag_val(obj);
     switch (tag) {
@@ -104,6 +106,9 @@ static void hash_aux(value obj)
     case Infix_tag:
       hash_aux(obj - Infix_offset_val(obj));
       break;
+    case Forward_tag:
+      obj = Forward_val (obj);
+      goto again;
     case Object_tag:
       hash_univ_count--;
       Combine(Oid_val(obj));
diff --git a/byterun/major_gc.c b/byterun/major_gc.c
index 8196eb0cd1..8cb65eb322 100644
--- a/byterun/major_gc.c
+++ b/byterun/major_gc.c
@@ -119,8 +119,14 @@ static void mark_slice (long work)
       if (Tag_hd (hd) < No_scan_tag){
         for (i = 0; i < size; i++){
           child = Field (v, i);
+        again:
           if (Is_block (child) && Is_in_heap (child)) {
             hd = Hd_val(child);
+            if (Tag_hd (hd) == Forward_tag){
+              child = Forward_val (child);
+              Field (v, i) = child;
+              goto again;
+            }
             if (Tag_hd(hd) == Infix_tag) {
               child -= Infix_offset_val(child);
               hd = Hd_val(child);
diff --git a/byterun/major_gc.h b/byterun/major_gc.h
index 69142e4c78..2d516ca270 100644
--- a/byterun/major_gc.h
+++ b/byterun/major_gc.h
@@ -58,7 +58,8 @@ extern char *gc_sweep_hp;
 #define Not_in_heap 0
 #define Page(p) ((unsigned long) (p) >> Page_log)
 #define Is_in_heap(p) \
-  ((addr)(p) >= (addr)heap_start && (addr)(p) < (addr)heap_end \
+  (Assert (Is_block (p)), \
+   (addr)(p) >= (addr)heap_start && (addr)(p) < (addr)heap_end \
    && page_table [Page (p)])
 
 void init_major_heap (asize_t);
diff --git a/byterun/minor_gc.c b/byterun/minor_gc.c
index 915053c08e..d04dcd6c34 100644
--- a/byterun/minor_gc.c
+++ b/byterun/minor_gc.c
@@ -69,6 +69,9 @@ void set_minor_heap_size (asize_t size)
 
 static value oldify_todo_list = NULL;
 
+/* Note that the tests on the tag depend on the fact that Infix_tag,
+   Forward_tag, and No_scan_tag are contiguous. */
+
 void oldify_one (value v, value *p)
 {
   value result, field0;
@@ -84,18 +87,7 @@ void oldify_one (value v, value *p)
       *p = Field (v, 0);  /*  then forward pointer is first field. */
     }else{
       tag = Tag_hd (hd);
-      if (tag >= No_scan_tag){
-        sz = Wosize_hd (hd);
-        result = alloc_shr (sz, tag);
-        for (i = 0; i < sz; i++) Field (result, i) = Field (v, i);
-        Hd_val (v) = 0;            /* Set forward flag */
-        Field (v, 0) = result;     /*  and forward pointer. */
-        *p = result;
-      }else if (tag == Infix_tag){
-        mlsize_t offset = Infix_offset_hd (hd);
-        oldify_one (v - offset, p);   /* This cannot recurse deeper than 1. */
-        *p += offset;
-      }else{
+      if (tag < Infix_tag){
         sz = Wosize_hd (hd);
         result = alloc_shr (sz, tag);
         *p = result;
@@ -112,6 +104,21 @@ void oldify_one (value v, value *p)
 	  v = field0;
           goto tail_call;
 	}
+      }else if (tag >= No_scan_tag){
+        sz = Wosize_hd (hd);
+        result = alloc_shr (sz, tag);
+        for (i = 0; i < sz; i++) Field (result, i) = Field (v, i);
+        Hd_val (v) = 0;            /* Set forward flag */
+        Field (v, 0) = result;     /*  and forward pointer. */
+        *p = result;
+      }else if (tag == Infix_tag){
+        mlsize_t offset = Infix_offset_hd (hd);
+        oldify_one (v - offset, p);   /* This cannot recurse deeper than 1. */
+        *p += offset;
+      }else{
+        Assert (tag == Forward_tag);
+        v = Forward_val (v);          /* Follow the forwarding */
+        goto tail_call;               /*  then oldify. */
       }
     }
   }else{
diff --git a/byterun/minor_gc.h b/byterun/minor_gc.h
index d520d98c72..7e7d894ac1 100644
--- a/byterun/minor_gc.h
+++ b/byterun/minor_gc.h
@@ -25,7 +25,8 @@ extern asize_t minor_heap_size;
 extern int in_minor_collection;
 
 #define Is_young(val) \
-  ((addr)(val) < (addr)young_end && (addr)(val) > (addr)young_start)
+  (Assert (Is_block (val)), \
+   (addr)(val) < (addr)young_end && (addr)(val) > (addr)young_start)
 
 extern void set_minor_heap_size (asize_t);
 extern void empty_minor_heap (void);
diff --git a/byterun/misc.c b/byterun/misc.c
index c73c9b5f05..536bd1b4a8 100644
--- a/byterun/misc.c
+++ b/byterun/misc.c
@@ -23,12 +23,13 @@
 
 #ifdef DEBUG
 
-void caml_failed_assert (char * expr, char * file, int line)
+int caml_failed_assert (char * expr, char * file, int line)
 {
   fprintf (stderr, "file %s; line %d ### Assertion failed: %s\n",
            file, line, expr);
   fflush (stderr);
   exit (100);
+  return 1; /* not reached */
 }
 
 #endif
diff --git a/byterun/misc.h b/byterun/misc.h
index 139abe7619..37bc31a864 100644
--- a/byterun/misc.h
+++ b/byterun/misc.h
@@ -62,10 +62,10 @@ typedef char * addr;
 /* Assertions */
 
 #ifdef DEBUG
-#define CAMLassert(x) if (!(x)) caml_failed_assert ( #x , __FILE__, __LINE__)
-void caml_failed_assert (char *, char *, int) Noreturn;
+#define CAMLassert(x) ((x) ? 0 : caml_failed_assert ( #x , __FILE__, __LINE__))
+int caml_failed_assert (char *, char *, int) Noreturn;
 #else
-#define CAMLassert(x)
+#define CAMLassert(x) 0
 #endif
 
 void fatal_error (char *msg) Noreturn;
diff --git a/byterun/mlvalues.h b/byterun/mlvalues.h
index 5e61035694..2c3b6a0ac7 100644
--- a/byterun/mlvalues.h
+++ b/byterun/mlvalues.h
@@ -158,10 +158,17 @@ bits  63    10 9     8 7   0
 typedef int32 opcode_t;
 typedef opcode_t * code_t;
 
-/* Special case of tuples of fields: closures */
+/* NOTE: [Forward_tag] and [Infix_tag] must be just under
+   [No_scan_tag], with [Infix_tag] the lower one.
+   See [oldify_one] in minor_gc.c for more details.
 
-#define Closure_tag 250
-#define Code_val(val) (((code_t *) (val)) [0])     /* Also an l-value. */
+   NOTE: Update stdlib/obj.ml whenever you change the tags.
+ */
+
+/* Forward_tag: forwarding pointer that the GC may silently shortcut.
+   See stdlib/lazy.ml. */
+#define Forward_tag 250
+#define Forward_val(v) Field(v, 0)
 
 /* If tag == Infix_tag : an infix header inside a closure */
 /* Infix_tag must be odd so that the infix header is scanned as an integer */
@@ -177,6 +184,14 @@ typedef opcode_t * code_t;
 #define Class_val(val) Field((val), 0)
 #define Oid_val(val) Long_val(Field((val), 1))
 
+/* Special case of tuples of fields: closures */
+#define Closure_tag 247
+#define Code_val(val) (((code_t *) (val)) [0])     /* Also an l-value. */
+
+/* This tag is not special for the runtime, but it must not be used
+   for any constructor.  See stdlib/lazy.ml. */
+#define Lazy_tag 246
+
 /* Another special case: variants */
 CAMLextern value hash_variant(char * tag);
 
diff --git a/byterun/obj.c b/byterun/obj.c
index 8b531f0d0f..d7ce07f641 100644
--- a/byterun/obj.c
+++ b/byterun/obj.c
@@ -51,6 +51,12 @@ CAMLprim value obj_tag(value arg)
   return Val_int(Tag_val(arg));
 }
 
+CAMLprim value obj_set_tag (value arg, value new_tag)
+{
+  Tag_val (arg) = Int_val (new_tag);
+  return Val_unit;
+}
+
 CAMLprim value obj_block(value tag, value size)
 {
   value res;