#6203: change representation of exception values created with a constant constructor: the value is now equal to the exception slot. This avoids some allocation when the constructor is called and an extra indirection on matching against the constructor.

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

bytecomp/matching.ml

@@ -2155,10 +2155,15 @@ let combine_constructor arg ex_pat cstr partial ctx def
         | Some fail -> fail, tag_lambda_list in
       List.fold_right
         (fun (ex, act) rem ->
+           assert(ex = cstr.cstr_tag);
           match ex with
           | Cstr_exception (path, _) ->
+              let slot =
+                if cstr.cstr_arity = 0 then arg
+                else Lprim(Pfield 0, [arg])
+              in
               Lifthenelse(Lprim(Pintcomp Ceq,
-                                [Lprim(Pfield 0, [arg]); transl_path path]),
+                                [slot; transl_path path]),
                           act, rem)
           | _ -> assert false)
         tests default in

bytecomp/translcore.ml

@@ -734,7 +734,9 @@ and transl_exp0 e =
             Lprim(Pmakeblock(n, Immutable), ll)
           end
       | Cstr_exception (path, _) ->
-          Lprim(Pmakeblock(0, Immutable), transl_path path :: ll)
+          let slot = transl_path path in
+          if cstr.cstr_arity = 0 then slot
+          else Lprim(Pmakeblock(0, Immutable), slot :: ll)
       end
   | Texp_variant(l, arg) ->
       let tag = Btype.hash_variant l in

byterun/exec.h

@@ -54,7 +54,7 @@ struct exec_trailer {
 
 /* Magic number for this release */
 
-#define EXEC_MAGIC "Caml1999X009"
+#define EXEC_MAGIC "Caml1999X010"
 
 
 #endif /* CAML_EXEC_H */

byterun/fail.c

@@ -39,13 +39,7 @@ CAMLexport void caml_raise(value v)
 
 CAMLexport void caml_raise_constant(value tag)
 {
-  CAMLparam1 (tag);
-  CAMLlocal1 (bucket);
-
-  bucket = caml_alloc_small (1, 0);
-  Field(bucket, 0) = tag;
-  caml_raise(bucket);
-  CAMLnoreturn;
+  caml_raise(tag);
 }
 
 CAMLexport void caml_raise_with_arg(value tag, value arg)
@@ -111,21 +105,9 @@ CAMLexport void caml_array_bound_error(void)
   caml_invalid_argument("index out of bounds");
 }
 
-/* Problem: we can't use [caml_raise_constant], because it allocates and
-   we're out of memory... Here, we allocate statically the exn bucket
-   for [Out_of_memory]. */
-
-static struct {
-  header_t hdr;
-  value exn;
-} out_of_memory_bucket = { 0, 0 };
-
 CAMLexport void caml_raise_out_of_memory(void)
 {
-  if (out_of_memory_bucket.exn == 0)
-    caml_fatal_error
-      ("Fatal error: out of memory while raising Out_of_memory\n");
-  caml_raise((value) &(out_of_memory_bucket.exn));
+  caml_raise_constant(Field(caml_global_data, OUT_OF_MEMORY_EXN));
 }
 
 CAMLexport void caml_raise_stack_overflow(void)
@@ -162,9 +144,6 @@ CAMLexport void caml_raise_sys_blocked_io(void)
 
 void caml_init_exceptions(void)
 {
-  out_of_memory_bucket.hdr = Make_header(1, 0, Caml_white);
-  out_of_memory_bucket.exn = Field(caml_global_data, OUT_OF_MEMORY_EXN);
-  caml_register_global_root(&out_of_memory_bucket.exn);
 }
 
 int caml_is_special_exception(value exn) {

byterun/printexc.c

@@ -53,8 +53,8 @@ CAMLexport char * caml_format_exception(value exn)
 
   buf.ptr = buf.data;
   buf.end = buf.data + sizeof(buf.data) - 1;
-  add_string(&buf, String_val(Field(Field(exn, 0), 0)));
   if (Wosize_val(exn) >= 2) {
+    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 &&
         Is_block(Field(exn, 1)) &&
@@ -82,7 +82,9 @@ CAMLexport char * caml_format_exception(value exn)
       }
     }
     add_char(&buf, ')');
-  }
+  } else
+    add_string(&buf, String_val(Field(exn, 0)));
+
   *buf.ptr = 0;              /* Terminate string */
   i = buf.ptr - buf.data + 1;
   res = malloc(i);

stdlib/callback.ml

@@ -20,4 +20,6 @@ let register name v =
   register_named_value name (Obj.repr v)
 
 let register_exception name (exn : exn) =
-  register_named_value name (Obj.field (Obj.repr exn) 0)
+  let exn = Obj.repr exn in
+  let slot = if Obj.size exn = 1 then exn else Obj.field exn 1 in
+  register_named_value name slot

toplevel/genprintval.ml

@@ -349,7 +349,8 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
         Oval_constr (lid, args)
 
     and tree_of_exception depth bucket =
-      let name = (O.obj(O.field(O.field bucket 0) 0) : string) in
+      let slot = if O.size bucket = 1 then bucket else O.field bucket 1 in
+      let name = (O.obj(O.field slot 0) : string) in
       let lid = Longident.parse name in
       try
         (* Attempt to recover the constructor description for the exn
@@ -361,7 +362,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
         (* Make sure this is the right exception and not an homonym,
            by evaluating the exception found and comparing with the
            identifier contained in the exception bucket *)
-        if not (EVP.same_value (O.field bucket 0) (EVP.eval_path path))
+        if not (EVP.same_value slot (EVP.eval_path path))
         then raise Not_found;
         tree_of_constr_with_args
            (fun x -> Oide_ident x) name 1 depth bucket cstr.cstr_args

utils/config.mlbuild

@@ -60,10 +60,10 @@ let mkdll = C.mkdll
 let mkexe = C.mkexe
 let mkmaindll = C.mkmaindll
 
-let exec_magic_number = "Caml1999X008"
-and cmi_magic_number = "Caml1999I015"
-and cmo_magic_number = "Caml1999O007"
-and cma_magic_number = "Caml1999A008"
+let exec_magic_number = "Caml1999X010"
+and cmi_magic_number = "Caml1999I016"
+and cmo_magic_number = "Caml1999O008"
+and cma_magic_number = "Caml1999A009"
 and cmx_magic_number = "Caml1999Y011"
 and cmxa_magic_number = "Caml1999Z010"
 and ast_impl_magic_number = "Caml1999M016"

utils/config.mlp

@@ -48,10 +48,10 @@ let mkdll = "%%MKDLL%%"
 let mkexe = "%%MKEXE%%"
 let mkmaindll = "%%MKMAINDLL%%"
 
-let exec_magic_number = "Caml1999X009"
-and cmi_magic_number = "Caml1999I015"
-and cmo_magic_number = "Caml1999O007"
-and cma_magic_number = "Caml1999A008"
+let exec_magic_number = "Caml1999X010"
+and cmi_magic_number = "Caml1999I016"
+and cmo_magic_number = "Caml1999O008"
+and cma_magic_number = "Caml1999A009"
 and cmx_magic_number = "Caml1999Y011"
 and cmxa_magic_number = "Caml1999Z010"
 and ast_impl_magic_number = "Caml1999M016"