PR#1878

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

10 files changed, 77 insertions, 30 deletions

diff --git a/boot/ocamlc b/boot/ocamlc
index db6172aac..6864ba286 100755
--- a/boot/ocamlc
+++ b/boot/ocamlc
diff --git a/boot/ocamllex b/boot/ocamllex
index 3164862a0..3c22d3e0c 100755
--- a/boot/ocamllex
+++ b/boot/ocamllex
diff --git a/byterun/extern.c b/byterun/extern.c
index 4d5888002..7e29d0ccd 100644
--- a/byterun/extern.c
+++ b/byterun/extern.c
@@ -246,8 +246,15 @@ static void extern_rec(value v)
     asize_t h;
 
     if (tag == Forward_tag) {
-      v = Forward_val (v);
-      goto tailcall;
+      value f = Forward_val (v);
+      if (Is_block (f) && (Is_young (f) || Is_in_heap (f))
+          && (Tag_val (f) == Forward_tag || Tag_val (f) == Lazy_tag
+              || Tag_val (f) == Double_tag)){
+        /* Do not short-circuit the pointer. */
+      }else{
+        v = f;
+        goto tailcall;
+      }
     }
     /* Atoms are treated specially for two reasons: they are not allocated
        in the externed block, and they are automatically shared. */
@@ -347,9 +354,6 @@ static void extern_rec(value v)
       size_64 += 2 + ((sz_64 + 7) >> 3);
       break;
     }
-    case Forward_tag:
-      Assert(0);
-      /*fallthrough*/
     default: {
       mlsize_t i;
       if (tag < 16 && sz < 8) {
diff --git a/byterun/finalise.c b/byterun/finalise.c
index 6fb533276..79e1e01fa 100644
--- a/byterun/finalise.c
+++ b/byterun/finalise.c
@@ -53,9 +53,16 @@ void final_update (void)
       struct final f;
 
       if (Tag_val (final_table[i].val) == Forward_tag){
-        final_table[i].val = Forward_val (final_table[i].val);
-        if (Is_block (final_table[i].val) && Is_in_heap (final_table[i].val)){
-          goto again;
+        value fv = Forward_val (final_table[i].val);
+        if (Is_block (fv) && (Is_young (fv) || Is_in_heap (fv))
+            && (Tag_val (fv) == Forward_tag || Tag_val (fv) == Lazy_tag
+                || Tag_val (fv) == Double_tag)){
+          /* Do not short-circuit the pointer. */
+        }else{
+          final_table[i].val = fv;
+          if (Is_block (final_table[i].val) && Is_in_heap (final_table[i].val)){
+            goto again;
+          }
         }
       }
       f = final_table[i];
diff --git a/byterun/major_gc.c b/byterun/major_gc.c
index a8f865925..ee0508207 100644
--- a/byterun/major_gc.c
+++ b/byterun/major_gc.c
@@ -131,7 +131,8 @@ static void mark_slice (long work)
             if (Tag_hd (hd) == Forward_tag){
               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)){
+                  && (Tag_val (f) == Forward_tag || Tag_val (f) == Lazy_tag
+                      || Tag_val (f) == Double_tag)){
                 /* Do not short-circuit the pointer. */
               }else{
                 Field (v, i) = f;
@@ -200,7 +201,8 @@ static void mark_slice (long work)
               if (Tag_val (curfield) == Forward_tag){
                 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){
+                  if (Tag_val (f) == Forward_tag || Tag_val (f) == Lazy_tag
+                      || Tag_val (f) == Double_tag){
                     /* Do not short-circuit the pointer. */
                   }else{
                     Field (cur, i) = curfield = f;
diff --git a/byterun/minor_gc.c b/byterun/minor_gc.c
index 7db685e41..e328ddd4c 100644
--- a/byterun/minor_gc.c
+++ b/byterun/minor_gc.c
@@ -125,9 +125,8 @@ void oldify_one (value v, value *p)
         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). */
+        if (ft == Forward_tag || ft == Lazy_tag || ft == Double_tag){
+          /* Do not short-circuit the pointer.  Copy as a normal block. */
           Assert (Wosize_hd (hd) == 1);
           result = alloc_shr (1, Forward_tag);
           *p = result;
diff --git a/byterun/obj.c b/byterun/obj.c
index 73572dceb..f6001fbc3 100644
--- a/byterun/obj.c
+++ b/byterun/obj.c
@@ -49,7 +49,13 @@ CAMLprim value obj_is_block(value arg)
 
 CAMLprim value obj_tag(value arg)
 {
-  return Val_int(Tag_val(arg));
+  if (Is_long (arg)){
+    return 1000;
+  }else if (Is_young (arg) || Is_in_heap (arg)){
+    return Val_int(Tag_val(arg));
+  }else{
+    return 1001;
+  }
 }
 
 CAMLprim value obj_set_tag (value arg, value new_tag)
@@ -140,11 +146,13 @@ CAMLprim value obj_truncate (value v, value newsize)
 }
 
 
-/* [lazy_is_forward] and [lazy_follow_forward] are used in stdlib/lazy.ml.
+/* The following functions are used in stdlib/lazy.ml.
    They are not written in O'Caml because they must be atomic with respect
    to the GC.
  */
 
+/* [lazy_is_forward] is obsolete.  Stays here to make bootstrapping
+   easier for patched versions of 3.07.  To be removed before 3.08. */
 CAMLprim value lazy_is_forward (value v)
 {
   return Val_bool (Is_block (v) && Tag_val (v) == Forward_tag);
@@ -152,9 +160,20 @@ CAMLprim value lazy_is_forward (value v)
 
 CAMLprim value lazy_follow_forward (value v)
 {
-  if (Is_block (v) && Tag_val (v) == Forward_tag){
+  if (Is_block (v) && (Is_young (v) || Is_in_heap (v))
+      && Tag_val (v) == Forward_tag){
     return Forward_val (v);
   }else{
     return v;
   }
 }
+
+CAMLprim value lazy_make_forward (value v)
+{
+  CAMLparam1 (v);
+  CAMLlocal1 (res);
+
+  res = alloc_small (1, Forward_tag);
+  Modify (&Field (res, 0), v);
+  CAMLreturn (res);
+}
diff --git a/stdlib/lazy.ml b/stdlib/lazy.ml
index 2af10859e..84158b257 100644
--- a/stdlib/lazy.ml
+++ b/stdlib/lazy.ml
@@ -30,11 +30,16 @@
       type [unit -> 'a] that computes the value.
    2. A block of size 1 with tag [forward_tag].  Its field is the value
       of type ['a] that was computed.
-   3. Anything else.  This has type ['a] and is the value that was computed.
+   3. Anything else except a float.  This has type ['a] and is the value
+      that was computed.
    Exceptions are stored in format (1).
    The GC will magically change things from (2) to (3) according to its
    fancy.
 
+   We cannot use representation (3) for a [float Lazy.t] because
+   [make_array] assumes that only a [float] value can have tag
+   [Double_tag].
+
    We have to use the built-in type constructor [lazy_t] to
    let the compiler implement the special typing and compilation
    rules for the [lazy] keyword.
@@ -45,21 +50,21 @@ 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";;
+external make_forward : 'a -> 'a lazy_t = "lazy_make_forward";;
 
 let force (l : 'arg t) =
   let x = Obj.repr l in
-  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)
+  let t = Obj.tag x in
+  if t = Obj.forward_tag then (follow_forward x : 'arg)
+  else if t <> Obj.lazy_tag then (Obj.obj x : 'arg)
   else begin
     let closure = (Obj.obj (Obj.field x 0) : unit -> 'arg) in
     Obj.set_field x 0 raise_undefined;
     try
       let result = closure () in
       Obj.set_field x 0 (Obj.repr result);  (* do set_field BEFORE set_tag *)
-      Obj.set_tag x (Obj.forward_tag);
+      Obj.set_tag x Obj.forward_tag;
       result
     with e ->
       Obj.set_field x 0 (Obj.repr (fun () -> raise e));
@@ -69,9 +74,9 @@ let force (l : 'arg t) =
 
 let force_val (l : 'arg t) =
   let x = Obj.repr l in
-  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)
+  let t = Obj.tag x in
+  if t = Obj.forward_tag then (follow_forward x : 'arg)
+  else if t <> Obj.lazy_tag then (Obj.obj x : 'arg)
   else begin
     let closure = (Obj.obj (Obj.field x 0) : unit -> 'arg) in
     Obj.set_field x 0 raise_undefined;
@@ -88,9 +93,13 @@ let lazy_from_fun (f : unit -> 'arg) =
   (Obj.obj x : 'arg t)
 ;;
 
-let lazy_from_val (v : 'arg) = (Obj.magic v : 'arg t);;
-
-let lazy_is_val (l : 'arg t) =
-  let x = Obj.repr l in
-  is_forward x || Obj.is_int x || Obj.tag x <> Obj.lazy_tag
+let lazy_from_val (v : 'arg) =
+  let t = Obj.tag (Obj.repr v) in
+  if t = Obj.forward_tag || t = Obj.lazy_tag || t = Obj.double_tag then begin
+    make_forward v
+  end else begin
+    (Obj.magic v : 'arg t)
+  end
 ;;
+
+let lazy_is_val (l : 'arg t) = Obj.tag (Obj.repr l) <> Obj.lazy_tag;;
diff --git a/stdlib/obj.ml b/stdlib/obj.ml
index 42df136f7..94e2e711d 100644
--- a/stdlib/obj.ml
+++ b/stdlib/obj.ml
@@ -50,3 +50,7 @@ let double_tag = 253
 let double_array_tag = 254
 let custom_tag = 255
 let final_tag = custom_tag
+
+
+let int_tag = 1000
+let out_of_heap_tag = 1001
diff --git a/stdlib/obj.mli b/stdlib/obj.mli
index 68670f51d..dd0a667aa 100644
--- a/stdlib/obj.mli
+++ b/stdlib/obj.mli
@@ -47,6 +47,9 @@ val double_array_tag : int
 val custom_tag : int
 val final_tag : int  (* DEPRECATED *)
 
+val int_tag : int
+val out_of_heap_tag : int
+
 (** The following two functions are deprecated.  Use module {!Marshal}
     instead. *)