Change the representation of exception slots: instead of being represented as 'string ref', they are now blocks

of size 2, with tag = Object_tag, the first field being the pointer to the string, and second one being a unique id, generated
from the same sequence as for object values.  Special case for predefined exceptions, represented with a negative id.

The unique id generator is moved from camlinternalOO to the C runtime system.

Also fix some bugs.



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

18 files changed, 72 insertions, 56 deletions

diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml
index 30bb13f638..5842f44eb4 100644
--- a/asmcomp/asmlink.ml
+++ b/asmcomp/asmlink.ml
@@ -206,8 +206,8 @@ let make_startup_file ppf filename units_list =
   compile_phrase (Cmmgen.entry_point name_list);
   let units = List.map (fun (info,_,_) -> info) units_list in
   List.iter compile_phrase (Cmmgen.generic_functions false units);
-  Array.iter
-    (fun name -> compile_phrase (Cmmgen.predef_exception name))
+  Array.iteri
+    (fun i name -> compile_phrase (Cmmgen.predef_exception i name))
     Runtimedef.builtin_exceptions;
   compile_phrase (Cmmgen.global_table name_list);
   compile_phrase
diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml
index 648f488b3f..463c842d59 100644
--- a/asmcomp/cmmgen.ml
+++ b/asmcomp/cmmgen.ml
@@ -2502,11 +2502,14 @@ let code_segment_table namelist =
 
 (* Initialize a predefined exception *)
 
-let predef_exception name =
+let predef_exception i name =
   let symname = "caml_exn_" ^ name in
   Cdata(Cglobal_symbol symname ::
         emit_constant symname
-          (Const_block(0,[Const_base(Const_string (name, None))])) [])
+          (Const_block(Obj.object_tag,
+                       [Const_base(Const_string (name, None));
+                        Const_base(Const_int (-i-1))
+                       ])) [])
 
 (* Header for a plugin *)
 
diff --git a/asmcomp/cmmgen.mli b/asmcomp/cmmgen.mli
index 84db405f84..46f9496655 100644
--- a/asmcomp/cmmgen.mli
+++ b/asmcomp/cmmgen.mli
@@ -26,5 +26,5 @@ val globals_map: (string * Digest.t * Digest.t * string list) list ->
 val frame_table: string list -> Cmm.phrase
 val data_segment_table: string list -> Cmm.phrase
 val code_segment_table: string list -> Cmm.phrase
-val predef_exception: string -> Cmm.phrase
+val predef_exception: int -> string -> Cmm.phrase
 val plugin_header: (Cmx_format.unit_infos * Digest.t) list -> Cmm.phrase
diff --git a/boot/ocamlc b/boot/ocamlc
index 24c3ac4ef0..db263b6850 100755
--- a/boot/ocamlc
+++ b/boot/ocamlc
diff --git a/boot/ocamldep b/boot/ocamldep
index 9987e82500..2e31e4c6e4 100755
--- a/boot/ocamldep
+++ b/boot/ocamldep
diff --git a/boot/ocamllex b/boot/ocamllex
index 6d8d7c25cc..88da8bab4c 100755
--- a/boot/ocamllex
+++ b/boot/ocamllex
diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml
index 9c94c90466..baff51c486 100644
--- a/bytecomp/symtable.ml
+++ b/bytecomp/symtable.ml
@@ -134,13 +134,17 @@ let output_primitive_table outchan =
 
 let init () =
   (* Enter the predefined exceptions *)
-  Array.iter
-    (fun name ->
+  Array.iteri
+    (fun i name ->
       let id =
         try List.assoc name Predef.builtin_values
         with Not_found -> fatal_error "Symtable.init" in
       let c = slot_for_setglobal id in
-      let cst = Const_block(0, [Const_base(Const_string (name, None))]) in
+      let cst = Const_block(Obj.object_tag,
+                            [Const_base(Const_string (name, None));
+                             Const_base(Const_int (-i-1))
+                            ])
+      in
       literal_table := (c, cst) :: !literal_table)
     Runtimedef.builtin_exceptions;
   (* Initialize the known C primitives *)
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index c9e28e4289..d63381631c 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -1124,16 +1124,6 @@ let transl_let rec_flag pat_expr_list body =
         (transl_let rec_flag pat_expr_list) body
 *)
 
-(* Compile an exception definition *)
-
-let transl_exception path decl =
-  let name =
-    match path with
-      None -> Ident.name decl.cd_id
-    | Some p -> Path.name p in
-  Lprim(Pmakeblock(0, Immutable),
-        [Lconst(Const_base(Const_string (name,None)))])
-
 (* Error report *)
 
 open Format
diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli
index 842ed78dcc..70f700fcee 100644
--- a/bytecomp/translcore.mli
+++ b/bytecomp/translcore.mli
@@ -22,8 +22,6 @@ val transl_apply: lambda -> (label * expression option * optional) list
                   -> Location.t -> lambda
 val transl_let: rec_flag -> value_binding list -> lambda -> lambda
 val transl_primitive: Location.t -> Primitive.description -> lambda
-val transl_exception:
-      Path.t option -> constructor_declaration -> lambda
 
 val check_recursive_lambda: Ident.t list -> lambda -> bool
 
diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml
index e3f07fc316..5780c98a71 100644
--- a/bytecomp/translmod.ml
+++ b/bytecomp/translmod.ml
@@ -27,8 +27,32 @@ open Translclass
 type error =
   Circular_dependency of Ident.t
 
+
 exception Error of Location.t * error
 
+(* Compile an exception definition *)
+
+let prim_set_oo_id =
+  Pccall {Primitive.prim_name = "caml_set_oo_id"; prim_arity = 1;
+          prim_alloc = false; prim_native_name = "";
+          prim_native_float = false}
+
+let transl_exception path decl =
+  let name =
+    match path with
+      None -> Ident.name decl.cd_id
+    | Some p -> Path.name p
+  in
+  Lprim(prim_set_oo_id,
+        [Lprim(Pmakeblock(Obj.object_tag, Immutable),
+              [Lconst(Const_base(Const_string (name,None)));
+               Lconst(Const_base(Const_int 0))])])
+(*
+  Lapply(oo_prim "create_exn",
+         [Lconst(Const_base(Const_string (name,None)))],
+         Location.none)
+*)
+
 (* Compile a coercion *)
 
 let rec apply_coercion restr arg =
diff --git a/byterun/intern.c b/byterun/intern.c
index bfe18b1a13..92cd90b2f8 100644
--- a/byterun/intern.c
+++ b/byterun/intern.c
@@ -64,10 +64,6 @@ 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). */
-
 static char * intern_resolve_code_pointer(unsigned char digest[16],
                                           asize_t offset);
 static void intern_bad_code_pointer(unsigned char digest[16]) Noreturn;
@@ -290,16 +286,9 @@ static void intern_rec(value *dest)
   switch (sp->op) {
   case OFreshOID:
     /* Refresh the object ID */
-    if (camlinternaloo_last_id == NULL) {
-      camlinternaloo_last_id = caml_named_value("CamlinternalOO.last_id");
-      if (camlinternaloo_last_id == NULL)
-        camlinternaloo_last_id = (value*) (-1);
-    }
-    if (camlinternaloo_last_id != (value*) (-1)) {
-      value id = Field(*camlinternaloo_last_id,0);
-      Field(dest, 0) = id;
-      Field(*camlinternaloo_last_id,0) = id + 2;
-    }
+    /* but do not do it for predefined exception slots */
+    if (Int_val(Field(dest, 1)) >= 0)
+      caml_set_oo_id((value)dest);
     /* Pop item and iterate */
     sp--;
     break;
@@ -336,7 +325,7 @@ static void intern_rec(value *dest)
           /* Request freshing OID */
           PushItem();
           sp->op = OFreshOID;
-          sp->dest = &Field(v, 1);
+          sp->dest = v;
           sp->arg = 1;
           /* Finally read first two block elements: method table and old OID */
           ReadItems(&Field(v, 0), 2);
@@ -503,8 +492,6 @@ 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/byterun/mlvalues.h b/byterun/mlvalues.h
index cbb1c7bfa3..268bcfe9ff 100644
--- a/byterun/mlvalues.h
+++ b/byterun/mlvalues.h
@@ -300,5 +300,6 @@ extern value caml_global_data;
 }
 #endif
 
+CAMLextern value caml_set_oo_id(value obj);
 
 #endif /* CAML_MLVALUES_H */
diff --git a/byterun/obj.c b/byterun/obj.c
index 8e00282e56..1fe8b22803 100644
--- a/byterun/obj.c
+++ b/byterun/obj.c
@@ -24,6 +24,7 @@
 #include "misc.h"
 #include "mlvalues.h"
 #include "prims.h"
+#include "stdio.h"
 
 CAMLprim value caml_static_alloc(value size)
 {
@@ -247,3 +248,11 @@ value caml_cache_public_method2 (value *meths, value tag, value *cache)
   }
 }
 #endif /*CAML_JIT*/
+
+static value oo_last_id = Val_int(0);
+
+CAMLprim value caml_set_oo_id (value obj) {
+  Field(obj, 1) = oo_last_id;
+  oo_last_id += 2;
+  return obj;
+}
diff --git a/byterun/printexc.c b/byterun/printexc.c
index b32109cc4d..6e70d524c8 100644
--- a/byterun/printexc.c
+++ b/byterun/printexc.c
@@ -53,7 +53,7 @@ CAMLexport char * caml_format_exception(value exn)
 
   buf.ptr = buf.data;
   buf.end = buf.data + sizeof(buf.data) - 1;
-  if (Wosize_val(exn) >= 2) {
+  if (Tag_val(exn) == 0) {
     add_string(&buf, String_val(Field(Field(exn, 0), 0)));
     /* Check for exceptions in the style of Match_failure and Assert_failure */
     if (Wosize_val(exn) == 2 &&
diff --git a/stdlib/callback.ml b/stdlib/callback.ml
index c9cf062bf7..6e4f9481e1 100644
--- a/stdlib/callback.ml
+++ b/stdlib/callback.ml
@@ -21,5 +21,5 @@ let register name v =
 
 let register_exception name (exn : exn) =
   let exn = Obj.repr exn in
-  let slot = if Obj.size exn = 1 then exn else Obj.field exn 1 in
+  let slot = if Obj.tag exn = Obj.object_tag then exn else Obj.field exn 0 in
   register_named_value name slot
diff --git a/stdlib/camlinternalOO.ml b/stdlib/camlinternalOO.ml
index 78e02fd4d6..c085096668 100644
--- a/stdlib/camlinternalOO.ml
+++ b/stdlib/camlinternalOO.ml
@@ -15,20 +15,13 @@ open Obj
 
 (**** Object representation ****)
 
-let last_id = ref 0
-let () = Callback.register "CamlinternalOO.last_id" last_id
-
-let set_id o id =
-  let id0 = !id in
-  Array.unsafe_set (Obj.magic o : int array) 1 id0;
-  id := id0 + 1
+external set_id: 'a -> 'a = "caml_set_oo_id" "noalloc"
 
 (**** Object copy ****)
 
 let copy o =
   let o = (Obj.obj (Obj.dup (Obj.repr o))) in
-  set_id o last_id;
-  o
+  set_id o
 
 (**** Compression options ****)
 (* Parameters *)
@@ -359,8 +352,7 @@ let create_object table =
   let obj = Obj.new_block Obj.object_tag table.size in
   (* XXX Appel de [caml_modify] *)
   Obj.set_field obj 0 (Obj.repr table.methods);
-  set_id obj last_id;
-  (Obj.obj obj)
+  Obj.obj (set_id obj)
 
 let create_object_opt obj_0 table =
   if (Obj.magic obj_0 : bool) then obj_0 else begin
@@ -368,8 +360,7 @@ let create_object_opt obj_0 table =
     let obj = Obj.new_block Obj.object_tag table.size in
     (* XXX Appel de [caml_modify] *)
     Obj.set_field obj 0 (Obj.repr table.methods);
-    set_id obj last_id;
-    (Obj.obj obj)
+    Obj.obj (set_id obj)
   end
 
 let rec iter_f obj =
diff --git a/stdlib/printexc.ml b/stdlib/printexc.ml
index 3324f6c4fa..db22ce357c 100644
--- a/stdlib/printexc.ml
+++ b/stdlib/printexc.ml
@@ -58,9 +58,12 @@ let to_string x =
             sprintf locfmt file line char (char+6) "Undefined recursive module"
         | _ ->
             let x = Obj.repr x in
-            let constructor =
-              (Obj.magic (Obj.field (Obj.field x 0) 0) : string) in
-            constructor ^ (fields x) in
+            if Obj.tag x <> 0 then
+              (Obj.magic (Obj.field x 0) : string)
+            else
+              let constructor =
+                (Obj.magic (Obj.field (Obj.field x 0) 0) : string) in
+              constructor ^ (fields x) in
   conv !printers
 
 let print fct arg =
diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml
index 5ed3b073cd..c37b2884cd 100644
--- a/toplevel/genprintval.ml
+++ b/toplevel/genprintval.ml
@@ -79,6 +79,9 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
       else []
 
     let outval_of_untyped_exception bucket =
+      if O.tag bucket <> 0 then
+        Oval_constr (Oide_ident (O.obj (O.field bucket 0) : string), [])
+      else
       let name = (O.obj(O.field(O.field bucket 0) 0) : string) in
       let args =
         if (name = "Match_failure"
@@ -349,7 +352,10 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
         Oval_constr (lid, args)
 
     and tree_of_exception depth bucket =
-      let slot = if O.size bucket = 1 then bucket else O.field bucket 1 in
+      let slot =
+        if O.tag bucket <> 0 then bucket
+        else O.field bucket 0
+      in
       let name = (O.obj(O.field slot 0) : string) in
       let lid = Longident.parse name in
       try