fix PR#5436

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

5 files changed, 54 insertions, 2 deletions

diff --git a/Changes b/Changes
index 1f8095a3d..7352e5975 100644
--- a/Changes
+++ b/Changes
@@ -42,6 +42,7 @@ Bug Fixes:
 - PR#5330: thread tag with '.top' and '.inferred.mli' targets
 - PR#5343: ocaml -rectypes is unsound wrt module subtyping
 - PR#5416: (Windows) Unix.(set|clear)_close_on_exec now preserves blocking mode
+- PR#5436: update object ids on unmarshaling
 - emacs mode: colorization of comments and strings now works correctly
 
 Feature wishes:
diff --git a/byterun/intern.c b/byterun/intern.c
index 9fa403ad6..35d293b60 100644
--- a/byterun/intern.c
+++ b/byterun/intern.c
@@ -19,6 +19,7 @@
 
 #include <string.h>
 #include "alloc.h"
+#include "callback.h"
 #include "custom.h"
 #include "fail.h"
 #include "gc.h"
@@ -63,6 +64,10 @@ static value intern_block;
 /* Point to the heap block allocated as destination block.
    Meaningful only if intern_extra_block is NULL. */
 
+static value * camlinternaloo_last_id = NULL;
+/* Pointer to a reference holding the last object id.
+   -1 means not available (CamlinternalOO not loaded). */
+
 #define Sign_extend_shift ((sizeof(intnat) - 1) * 8)
 #define Sign_extend(x) (((intnat)(x) << Sign_extend_shift) >> Sign_extend_shift)
 
@@ -139,6 +144,22 @@ static void intern_rec(value *dest)
         dest = (value *) (intern_dest + 1);
         *intern_dest = Make_header(size, tag, intern_color);
         intern_dest += 1 + size;
+        /* For objects, we need to freshen the oid */
+        if (tag == Object_tag && camlinternaloo_last_id != (value*)-1) {
+          intern_rec(dest++);
+          intern_rec(dest++);
+          if (camlinternaloo_last_id == NULL)
+            camlinternaloo_last_id = caml_named_value("CamlinternalOO.last_id");
+          if (camlinternaloo_last_id == NULL)
+            camlinternaloo_last_id = (value*)-1;
+          else {
+            value id = Field(*camlinternaloo_last_id,0);
+            Field(dest,-1) = id;
+            Field(*camlinternaloo_last_id,0) = id + 2;
+          }
+          size -= 2;
+          if (size == 0) return;
+        }
         for(/*nothing*/; size > 1; size--, dest++)
           intern_rec(dest);
         goto tailcall;
@@ -328,6 +349,8 @@ static void intern_alloc(mlsize_t whsize, mlsize_t num_objects)
 {
   mlsize_t wosize;
 
+  if (camlinternaloo_last_id == (value*)-1)
+    camlinternaloo_last_id = NULL; /* Reset ignore flag */
   if (whsize == 0) {
     intern_obj_table = NULL;
     intern_extra_block = NULL;
diff --git a/stdlib/camlinternalOO.ml b/stdlib/camlinternalOO.ml
index db3aef73d..6d7871465 100644
--- a/stdlib/camlinternalOO.ml
+++ b/stdlib/camlinternalOO.ml
@@ -18,8 +18,7 @@ open Obj
 (**** Object representation ****)
 
 let last_id = ref 0
-let new_id () =
-  let id = !last_id in incr last_id; id
+let () = Callback.register "CamlinternalOO.last_id" last_id
 
 let set_id o id =
   let id0 = !id in
diff --git a/testsuite/tests/typing-objects/Tests.ml b/testsuite/tests/typing-objects/Tests.ml
index 19d20d882..c7a5cb3d1 100644
--- a/testsuite/tests/typing-objects/Tests.ml
+++ b/testsuite/tests/typing-objects/Tests.ml
@@ -302,3 +302,26 @@ end;;
 let x = new d () in x#n, x#o;;
 
 class c () = object method virtual m : int method private m = 1 end;;
+
+(* Marshaling (cf. PR#5436) *)
+
+Oo.id (object end);;
+Oo.id (object end);;
+Oo.id (object end);;
+let o = object end in
+  let s = Marshal.to_string o [] in
+  let o' : < > = Marshal.from_string s 0 in
+  let o'' : < > = Marshal.from_string s 0 in
+  (Oo.id o, Oo.id o', Oo.id o'');;
+
+let o = object val x = 33 method m = x end in
+  let s = Marshal.to_string o [Marshal.Closures] in
+  let o' : <m:int> = Marshal.from_string s 0 in
+  let o'' : <m:int> = Marshal.from_string s 0 in
+  (Oo.id o, Oo.id o', Oo.id o'', o#m, o'#m);;
+
+let o = object val x = 33 val y = 44 method m = x end in
+  let s = Marshal.to_string o [Marshal.Closures] in
+  let o' : <m:int> = Marshal.from_string s 0 in
+  let o'' : <m:int> = Marshal.from_string s 0 in
+  (Oo.id o, Oo.id o', Oo.id o'', o#m, o'#m);;
diff --git a/testsuite/tests/typing-objects/Tests.ml.reference b/testsuite/tests/typing-objects/Tests.ml.reference
index a78367fdf..4df231692 100644
--- a/testsuite/tests/typing-objects/Tests.ml.reference
+++ b/testsuite/tests/typing-objects/Tests.ml.reference
@@ -292,4 +292,10 @@ Warning 10: this expression should have type unit.
   unit -> object method private m : int method n : int method o : int end
 #   - : int * int = (1, 1)
 #   class c : unit -> object method m : int end
+#       - : int = 15
+# - : int = 16
+# - : int = 17
+#         - : int * int * int = (18, 19, 20)
+#           - : int * int * int * int * int = (21, 22, 23, 33, 33)
+#           - : int * int * int * int * int = (24, 25, 26, 33, 33)
 #