ocaml#6203, ocaml#5935: variants of raise. 'reraise' is currently only inserted by the compiler when an handler does not catch the exception. The default 'raise' always start with a fresh backtrace. There is also 'raise_nostack' which does not trigger the stack trace recording. Bytecode only for now.

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

Author: alainfrisch

Makefile

@@ -199,6 +199,10 @@ coldstart:
 	if test -d stdlib/caml; then :; else \
 	  ln -s ../byterun stdlib/caml; fi
 
+bootlib:
+	cd stdlib; $(MAKE) all
+	cd stdlib; cp $(LIBFILES) ../boot
+
 # Build the core system: the minimum needed to make depend and bootstrap
 core:
 	$(MAKE) coldstart
@@ -782,7 +786,7 @@ camlp4opt: ocamlopt otherlibrariesopt ocamlbuild-mixed-boot ocamlbuild.native
 
 # Ocamlbuild
 #ifeq ($(OCAMLBUILD_NOBOOT),"yes")
-#ocamlbuild.byte: ocamlc
+#ocamlbuild.byte: ocamlc	
 #	$(MAKE) -C ocamlbuild -f Makefile.noboot
 #else
 ocamlbuild.byte: ocamlc ocamlbuild-mixed-boot

boot/myocamlbuild.boot

@@ -74,7 +74,7 @@ let make_branch cont =
   match cont with
     (Kbranch _ as branch) :: _ -> (branch, cont)
   | (Kreturn _ as return) :: _ -> (return, cont)
-  | Kraise :: _ -> (Kraise, cont)
+  | Kraise k :: _ -> (Kraise k, cont)
   | Klabel lbl :: _ -> make_branch_2 (Some lbl) 0 cont cont
   | _ ->  make_branch_2 (None) 0 cont cont
 
@@ -108,7 +108,7 @@ let rec add_pop n cont =
     match cont with
       Kpop m :: cont -> add_pop (n + m) cont
     | Kreturn m :: cont -> Kreturn(n + m) :: cont
-    | Kraise :: _ -> cont
+    | Kraise _ :: _ -> cont
     | _ -> Kpop n :: cont
 
 (* Add the constant "unit" in front of a continuation *)
@@ -584,8 +584,8 @@ let rec comp_expr env exp sz cont =
           comp_expr env exp1 sz (Kstrictbranchif lbl ::
             comp_expr env exp2 sz cont1)
       end
-  | Lprim(Praise, [arg]) ->
-      comp_expr env arg sz (Kraise :: discard_dead_code cont)
+  | Lprim(Praise k, [arg]) ->
+      comp_expr env arg sz (Kraise k :: discard_dead_code cont)
   | Lprim(Paddint, [arg; Lconst(Const_base(Const_int n))])
     when is_immed n ->
       comp_expr env arg sz (Koffsetint n :: cont)

boot/ocamlc

@@ -243,7 +243,9 @@ let emit_instr = function
   | Kboolnot -> out opBOOLNOT
   | Kpushtrap lbl -> out opPUSHTRAP; out_label lbl
   | Kpoptrap -> out opPOPTRAP
-  | Kraise -> out opRAISE
+  | Kraise Raise_regular -> out opRAISE
+  | Kraise Raise_reraise -> out opRERAISE
+  | Kraise Raise_nostack -> out opRAISE_NOSTACK
   | Kcheck_signals -> out opCHECK_SIGNALS
   | Kccall(name, n) ->
       if n <= 5

boot/ocamldep

@@ -85,7 +85,7 @@ type instruction =
   | Kboolnot
   | Kpushtrap of label
   | Kpoptrap
-  | Kraise
+  | Kraise of raise_kind
   | Kcheck_signals
   | Kccall of string * int
   | Knegint | Kaddint | Ksubint | Kmulint | Kdivint | Kmodint

boot/ocamllex

@@ -105,7 +105,7 @@ type instruction =
   | Kboolnot
   | Kpushtrap of label
   | Kpoptrap
-  | Kraise
+  | Kraise of raise_kind
   | Kcheck_signals
   | Kccall of string * int
   | Knegint | Kaddint | Ksubint | Kmulint | Kdivint | Kmodint

bytecomp/bytegen.ml

@@ -41,7 +41,7 @@ type primitive =
   (* External call *)
   | Pccall of Primitive.description
   (* Exceptions *)
-  | Praise
+  | Praise of raise_kind
   (* Boolean operations *)
   | Psequand | Psequor | Pnot
   (* Integer operations *)
@@ -137,6 +137,11 @@ and bigarray_layout =
   | Pbigarray_c_layout
   | Pbigarray_fortran_layout
 
+and raise_kind =
+  | Raise_regular
+  | Raise_reraise
+  | Raise_nostack
+
 type structured_constant =
     Const_base of constant
   | Const_pointer of int

bytecomp/emitcode.ml

@@ -41,7 +41,7 @@ type primitive =
   (* External call *)
   | Pccall of Primitive.description
   (* Exceptions *)
-  | Praise
+  | Praise of raise_kind
   (* Boolean operations *)
   | Psequand | Psequor | Pnot
   (* Integer operations *)
@@ -137,6 +137,11 @@ and bigarray_layout =
   | Pbigarray_c_layout
   | Pbigarray_fortran_layout
 
+and raise_kind =
+  | Raise_regular
+  | Raise_reraise
+  | Raise_nostack
+
 type structured_constant =
     Const_base of constant
   | Const_pointer of int

bytecomp/instruct.ml

@@ -1678,7 +1678,7 @@ let rec do_tests_nofail tst arg = function
 
 let make_test_sequence fail tst lt_tst arg const_lambda_list =
   let rec make_test_sequence const_lambda_list =
-    if List.length const_lambda_list >= 4 && lt_tst <> Praise then
+    if List.length const_lambda_list >= 4 && lt_tst <> Pignore then
       split_sequence const_lambda_list
     else match fail with
     | None -> do_tests_nofail tst arg const_lambda_list
@@ -2098,7 +2098,7 @@ let combine_constant arg cst partial ctx def
           fail arg 0 255 int_lambda_list
     | Const_string _ ->
         make_test_sequence
-          fail prim_string_notequal Praise arg const_lambda_list
+          fail prim_string_notequal Pignore arg const_lambda_list
     | Const_float _ ->
         make_test_sequence
           fail
@@ -2728,7 +2728,7 @@ let compile_matching loc repr handler_fun arg pat_act_list partial =
 let partial_function loc () =
   (* [Location.get_pos_info] is too expensive *)
   let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in
-  Lprim(Praise, [Lprim(Pmakeblock(0, Immutable),
+  Lprim(Praise Raise_regular, [Lprim(Pmakeblock(0, Immutable),
           [transl_path Predef.path_match_failure;
            Lconst(Const_block(0,
               [Const_base(Const_string (fname, None));
@@ -2740,7 +2740,8 @@ let for_function loc repr param pat_act_list partial =
 
 (* In the following two cases, exhaustiveness info is not available! *)
 let for_trywith param pat_act_list =
-  compile_matching Location.none None (fun () -> Lprim(Praise, [param]))
+  compile_matching Location.none None
+    (fun () -> Lprim(Praise Raise_reraise, [param]))
     param pat_act_list Partial
 
 let for_let loc param pat body =

bytecomp/instruct.mli

@@ -67,7 +67,9 @@ let instruction ppf = function
   | Kboolnot -> fprintf ppf "\tboolnot"
   | Kpushtrap lbl -> fprintf ppf "\tpushtrap L%i" lbl
   | Kpoptrap -> fprintf ppf "\tpoptrap"
-  | Kraise -> fprintf ppf "\traise"
+  | Kraise Raise_regular-> fprintf ppf "\traise"
+  | Kraise Raise_reraise-> fprintf ppf "\treraise"
+  | Kraise Raise_nostack-> fprintf ppf "\traise_nostack"
   | Kcheck_signals -> fprintf ppf "\tcheck_signals"
   | Kccall(s, n) ->
       fprintf ppf "\tccall %s, %i" s n

bytecomp/lambda.ml

@@ -105,7 +105,9 @@ let primitive ppf = function
   | Pduprecord (rep, size) -> fprintf ppf "duprecord %a %i" record_rep rep size
   | Plazyforce -> fprintf ppf "force"
   | Pccall p -> fprintf ppf "%s" p.prim_name
-  | Praise -> fprintf ppf "raise"
+  | Praise Raise_regular -> fprintf ppf "raise"
+  | Praise Raise_reraise -> fprintf ppf "re-raise"
+  | Praise Raise_nostack -> fprintf ppf "raise-no-stack"
   | Psequand -> fprintf ppf "&&"
   | Psequor -> fprintf ppf "||"
   | Pnot -> fprintf ppf "not"

bytecomp/lambda.mli

@@ -146,7 +146,9 @@ let primitives_table = create_hashtable 57 [
   "%setfield0", Psetfield(0, true);
   "%makeblock", Pmakeblock(0, Immutable);
   "%makemutable", Pmakeblock(0, Mutable);
-  "%raise", Praise;
+  "%raise", Praise Raise_regular;
+  "%reraise", Praise Raise_reraise;
+  "%raise_nostack", Praise Raise_nostack;
   "%sequand", Psequand;
   "%sequor", Psequor;
   "%boolnot", Pnot;
@@ -585,7 +587,7 @@ let primitive_is_ccall = function
 let assert_failed exp =
   let (fname, line, char) =
     Location.get_pos_info exp.exp_loc.Location.loc_start in
-  Lprim(Praise, [event_after exp
+  Lprim(Praise Raise_regular, [event_after exp
     (Lprim(Pmakeblock(0, Immutable),
           [transl_path Predef.path_assert_failure;
            Lconst(Const_block(0,
@@ -679,8 +681,8 @@ and transl_exp0 e =
             (Warnings.Deprecated "operator (or); you should use (||) instead");
         let prim = transl_prim e.exp_loc p args in
         match (prim, args) with
-          (Praise, [arg1]) ->
-            wrap0 (Lprim(Praise, [event_after arg1 (List.hd argl)]))
+          (Praise k, [arg1]) ->
+            wrap0 (Lprim(Praise k, [event_after arg1 (List.hd argl)]))
         | (_, _) ->
             begin match (prim, argl) with
             | (Plazyforce, [a]) ->

bytecomp/matching.ml

@@ -93,11 +93,11 @@ CAMLprim value caml_backtrace_status(value vunit)
 /* Store the return addresses contained in the given stack fragment
    into the backtrace array */
 
-void caml_stash_backtrace(value exn, code_t pc, value * sp)
+void caml_stash_backtrace(value exn, code_t pc, value * sp, int reraise)
 {
   code_t end_code = (code_t) ((char *) caml_start_code + caml_code_size);
   if (pc != NULL) pc = pc - 1;
-  if (exn != caml_backtrace_last_exn) {
+  if (exn != caml_backtrace_last_exn || !reraise) {
     caml_backtrace_pos = 0;
     caml_backtrace_last_exn = exn;
   }

bytecomp/printinstr.ml

@@ -24,7 +24,7 @@ CAMLextern char * caml_cds_file;
 
 CAMLprim value caml_record_backtrace(value vflag);
 #ifndef NATIVE_CODE
-extern void caml_stash_backtrace(value exn, code_t pc, value * sp);
+extern void caml_stash_backtrace(value exn, code_t pc, value * sp, int reraise);
 #endif
 CAMLextern void caml_print_exception_backtrace(void);
 

bytecomp/printlambda.ml

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

bytecomp/translcore.ml

@@ -39,7 +39,9 @@ enum instructions {
   VECTLENGTH, GETVECTITEM, SETVECTITEM,
   GETSTRINGCHAR, SETSTRINGCHAR,
   BRANCH, BRANCHIF, BRANCHIFNOT, SWITCH, BOOLNOT,
-  PUSHTRAP, POPTRAP, RAISE, CHECK_SIGNALS,
+  PUSHTRAP, POPTRAP, RAISE,
+  RERAISE, RAISE_NOSTACK,
+  CHECK_SIGNALS,
   C_CALL1, C_CALL2, C_CALL3, C_CALL4, C_CALL5, C_CALLN,
   CONST0, CONST1, CONST2, CONST3, CONSTINT,
   PUSHCONST0, PUSHCONST1, PUSHCONST2, PUSHCONST3, PUSHCONSTINT,

byterun/backtrace.c

@@ -820,10 +820,23 @@ value caml_interprete(code_t prog, asize_t prog_size)
       sp += 4;
       Next;
 
+    Instruct(RAISE_NOSTACK):
+      /*printf("raise_nostack\n"); fflush(stdout);*/
+      if (caml_trapsp >= caml_trap_barrier) caml_debugger(TRAP_BARRIER);
+      goto raise_nostack;
+
+    Instruct(RERAISE):
+      /*printf("reraise\n"); fflush(stdout);*/
+      if (caml_trapsp >= caml_trap_barrier) caml_debugger(TRAP_BARRIER);
+      if (caml_backtrace_active) caml_stash_backtrace(accu, pc, sp, 1);
+      goto raise_nostack;
+
     Instruct(RAISE):
+      /*printf("raise\n"); fflush(stdout);*/
     raise_exception:
       if (caml_trapsp >= caml_trap_barrier) caml_debugger(TRAP_BARRIER);
-      if (caml_backtrace_active) caml_stash_backtrace(accu, pc, sp);
+      if (caml_backtrace_active) caml_stash_backtrace(accu, pc, sp, 0);
+    raise_nostack:
       if ((char *) caml_trapsp
           >= (char *) caml_stack_high - initial_sp_offset) {
         caml_external_raise = initial_external_raise;

byterun/backtrace.h

@@ -48,7 +48,7 @@ let mkdll = "%%MKDLL%%"
 let mkexe = "%%MKEXE%%"
 let mkmaindll = "%%MKMAINDLL%%"
 
-let exec_magic_number = "Caml1999X008"
+let exec_magic_number = "Caml1999X009"
 and cmi_magic_number = "Caml1999I015"
 and cmo_magic_number = "Caml1999O007"
 and cma_magic_number = "Caml1999A008"