PR#1379

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

.cvsignore

@@ -5,4 +5,5 @@ ocaml
 ocamlopt
 ocamlopt.opt
 ocamlcomp.sh
-ocamlcompopt.sh
+ocamlcompopt.sh
+package-macosx

byterun/finalise.c

@@ -46,15 +46,17 @@ void final_update (void)
   Assert (young == old);
   Assert (young <= active);
   for (i = 0; i < old; i++){
+  again:
     Assert (Is_block (final_table[i].val));
     Assert (Is_in_heap (final_table[i].val));
-  again:
     if (Is_white_val (final_table[i].val)){
       struct final f;
 
       if (Tag_val (final_table[i].val) == Forward_tag){
         final_table[i].val = Forward_val (final_table[i].val);
-        goto again;
+        if (Is_block (final_table[i].val) && Is_in_heap (final_table[i].val)){
+          goto again;
+        }
       }
       f = final_table[i];
       final_table[i] = final_table[--old];

byterun/major_gc.c

@@ -122,14 +122,20 @@ static void mark_slice (long work)
       hd = Hd_val(v);
       Assert (Is_gray_hd (hd));
       Hd_val (v) = Blackhd_hd (hd);
-      size = Wosize_hd(hd);
+      size = Wosize_hd (hd);
       if (Tag_hd (hd) < No_scan_tag){
         for (i = 0; i < size; i++){
           child = Field (v, i);
           if (Is_block (child) && Is_in_heap (child)) {
-            hd = Hd_val(child);
+            hd = Hd_val (child);
             if (Tag_hd (hd) == Forward_tag){
-              Field (v, i) = Forward_val (child);
+              value f = Forward_val (child);
+              if (Is_block (f) && (Is_young (f) || Is_in_heap (f))
+                  && (Tag_val (f) == Forward_tag || Tag_val (f) == Lazy_tag)){
+                /* Do not short-circuit the pointer. */
+              }else{
+                Field (v, i) = f;
+              }
             }
             else if (Tag_hd(hd) == Infix_tag) {
               child -= Infix_offset_val(child);
@@ -192,10 +198,14 @@ static void mark_slice (long work)
            weak_again:
             if (curfield != 0 && Is_block (curfield) && Is_in_heap (curfield)){
               if (Tag_val (curfield) == Forward_tag){
-                value v = Forward_val (curfield);
-                if (Is_block (v) && Is_in_heap (v)){
-                  Field (cur, i) = curfield = v;
-                  goto weak_again;
+                value f = Forward_val (curfield);
+                if (Is_block (f) && (Is_young (f) || Is_in_heap (f))){
+                  if (Tag_val (f) == Forward_tag || Tag_val (f) == Lazy_tag){
+                    /* Do not short-circuit the pointer. */
+                  }else{
+                    Field (cur, i) = curfield = f;
+                    goto weak_again;
+                  }
                 }
               }
               if (Is_white_val (curfield)){

byterun/minor_gc.c

@@ -74,7 +74,7 @@ static value oldify_todo_list = 0;
 
 void oldify_one (value v, value *p)
 {
-  value result, field0;
+  value result;
   header_t hd;
   mlsize_t sz, i;
   tag_t tag;
@@ -88,6 +88,8 @@ void oldify_one (value v, value *p)
     }else{
       tag = Tag_hd (hd);
       if (tag < Infix_tag){
+        value field0;
+
         sz = Wosize_hd (hd);
         result = alloc_shr (sz, tag);
         *p = result;
@@ -116,9 +118,28 @@ void oldify_one (value v, value *p)
         oldify_one (v - offset, p);   /* This cannot recurse deeper than 1. */
         *p += offset;
       }else{
+        value f = Forward_val (v);
+        tag_t ft = 0;
+
         Assert (tag == Forward_tag);
-        v = Forward_val (v);          /* Follow the forwarding */
-        goto tail_call;               /*  then oldify. */
+        if (Is_block (f) && (Is_young (f) || Is_in_heap (f))){
+          ft = Tag_val (Hd_val (f) == 0 ? Field (f, 0) : f);
+        }
+        if (ft == Forward_tag || ft == Lazy_tag){
+          /* Keep the forward block; copy it as a normal block
+             (no short-circuit). */
+          Assert (Wosize_hd (hd) == 1);
+          result = alloc_shr (1, Forward_tag);
+          *p = result;
+          Hd_val (v) = 0;             /* Set (GC) forward flag */
+          Field (v, 0) = result;      /*  and forward pointer. */
+          p = &Field (result, 0);
+          v = f;
+          goto tail_call;
+        }else{
+          v = f;                        /* Follow the forwarding */
+          goto tail_call;               /*  then oldify. */
+        }
       }
     }
   }else{

byterun/mlvalues.h

@@ -188,8 +188,8 @@ typedef opcode_t * code_t;
 #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. */
+/* This tag is used (with Forward_tag) to implement lazy values.
+   See major_gc.c and stdlib/lazy.ml. */
 #define Lazy_tag 246
 
 /* Another special case: variants */

byterun/obj.c

@@ -132,3 +132,23 @@ CAMLprim value obj_truncate (value v, value newsize)
   Hd_val (v) = Make_header (new_wosize, tag, color);
   return Val_unit;
 }
+
+
+/* [lazy_is_forward] and [lazy_follow_forward] are used in stdlib/lazy.ml.
+   They are not written in O'Caml because they must be atomic with respect
+   to the GC.
+ */
+
+CAMLprim value lazy_is_forward (value v)
+{
+  return Val_bool (Is_block (v) && Tag_val (v) == Forward_tag);
+}
+
+CAMLprim value lazy_follow_forward (value v)
+{
+  if (Is_block (v) && Tag_val (v) == Forward_tag){
+    return Forward_val (v);
+  }else{
+    return v;
+  }
+}

stdlib/lazy.ml

@@ -45,10 +45,13 @@ exception Undefined;;
 
 let raise_undefined = Obj.repr (fun () -> raise Undefined);;
 
+external is_forward : Obj.t -> bool = "lazy_is_forward";;
+external follow_forward : Obj.t -> 'a = "lazy_follow_forward";;
+
 let force (l : 'arg t) =
   let x = Obj.repr l in
-  if Obj.is_int x then (Obj.obj x : 'arg)
-  else if Obj.tag x = Obj.forward_tag then (Obj.obj (Obj.field x 0) : 'arg)
+  if is_forward x then (follow_forward x : 'arg)
+  else if Obj.is_int x then (Obj.obj x : 'arg)
   else if Obj.tag x <> Obj.lazy_tag then (Obj.obj x : 'arg)
   else begin
     let closure = (Obj.obj (Obj.field x 0) : unit -> 'arg) in
@@ -66,8 +69,8 @@ let force (l : 'arg t) =
 
 let force_val (l : 'arg t) =
   let x = Obj.repr l in
-  if Obj.is_int x then (Obj.obj x : 'arg)
-  else if Obj.tag x = Obj.forward_tag then (Obj.obj (Obj.field x 0) : 'arg)
+  if is_forward x then (follow_forward x : 'arg)
+  else if Obj.is_int x then (Obj.obj x : 'arg)
   else if Obj.tag x <> Obj.lazy_tag then (Obj.obj x : 'arg)
   else begin
     let closure = (Obj.obj (Obj.field x 0) : unit -> 'arg) in
@@ -89,5 +92,5 @@ let lazy_from_val (v : 'arg) = (Obj.magic v : 'arg t);;
 
 let lazy_is_val (l : 'arg t) =
   let x = Obj.repr l in
-  Obj.is_int x || Obj.tag x <> Obj.lazy_tag
+  is_forward x || Obj.is_int x || Obj.tag x <> Obj.lazy_tag
 ;;

stdlib/sys.ml

@@ -78,4 +78,4 @@ let catch_break on =
 (* OCaml version string, moved from utils/config.mlp.
    Must be in the format described in sys.mli. *)
 
-let ocaml_version = "3.06+2 (2002-09-17)"
+let ocaml_version = "3.06+3 (2002-09-18)"