From 0f6f367ad4c2210bdf393ac60dbc0b6f7b8c796d Mon Sep 17 00:00:00 2001 From: Alain Frisch Date: Oct 23 2013 14:28:31 +0000 Subject: 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 --- diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml index 30bb13f..5842f44 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 648f488..463c842 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 84db405..46f9496 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 24c3ac4..db263b6 100755 Binary files a/boot/ocamlc and b/boot/ocamlc differ diff --git a/boot/ocamldep b/boot/ocamldep index 9987e82..2e31e4c 100755 Binary files a/boot/ocamldep and b/boot/ocamldep differ diff --git a/boot/ocamllex b/boot/ocamllex index 6d8d7c2..88da8ba 100755 Binary files a/boot/ocamllex and b/boot/ocamllex differ diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml index 9c94c90..baff51c 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 c9e28e4..d633816 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 842ed78..70f700f 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 e3f07fc..5780c98 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 bfe18b1..92cd90b 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 cbb1c7b..268bcfe 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 8e00282..1fe8b22 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 b32109c..6e70d52 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 c9cf062..6e4f948 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 78e02fd..c085096 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 3324f6c..db22ce3 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 5ed3b07..c37b288 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