Preserve backtraces in match ... with exception e -> ...

When translating into Lambda we treat the case of exception
handlers in match forms in the same way as exception handler in
try .. with in order to preserve backtraces.

A small test is included as well.

Changes

@@ -334,6 +334,10 @@ Compilers:
   `-no-rectypes`, `-no-strict-formats`
   (Demi Obenour)
 
+- GPR#545: use reraise to preserve backtrace on
+  `match .. with exception e -> raise e`
+  (Nicolas Ojeda Bar, review by Gabriel Scherer)
+
 Runtime system:
 ===============
 

bytecomp/translcore.ml

@@ -1344,7 +1344,7 @@ and transl_record env all_labels repres lbl_expr_list opt_init_expr =
 and transl_match e arg pat_expr_list exn_pat_expr_list partial =
   let id = name_pattern "exn" exn_pat_expr_list
   and cases = transl_cases pat_expr_list
-  and exn_cases = transl_cases exn_pat_expr_list in
+  and exn_cases = transl_cases_try exn_pat_expr_list in
   let static_catch body val_ids handler =
     let static_exception_id = next_negative_raise_count () in
     Lstaticcatch

testsuite/tests/backtrace/Makefile

@@ -17,7 +17,7 @@ BASEDIR=../..
 EXECNAME=program$(EXE)
 
 ABCDFILES=backtrace.ml
-OTHERFILES=backtrace2.ml raw_backtrace.ml \
+OTHERFILES=backtrace2.ml backtrace3.ml raw_backtrace.ml \
            backtrace_deprecated.ml backtrace_slots.ml
 OTHERFILESNOINLINING=pr6920_why_at.ml pr6920_why_swallow.ml
 OTHERFILESNOINLINING_NATIVE=backtraces_and_finalizers.ml

testsuite/tests/backtrace/backtrace3.ml

@@ -0,0 +1,39 @@
+
+(* A test for stack backtraces *)
+
+exception Error of string
+
+let rec f msg n =
+  if n = 0 then raise(Error msg) else 1 + f msg (n-1)
+
+let g msg =
+  match
+    f msg 5
+  with
+  | _ ->
+     (* value return does not happen *)
+     assert false
+  | exception (Error "a") ->
+      print_string "a"; print_newline(); 0
+  | exception (Error "b" as exn) ->
+      (* this should Re-raise, appending to the current backtrace *)
+      print_string "b"; print_newline(); raise exn
+  | exception (Error "c") ->
+      (* according to the current re-raise policy (a static condition),
+         this does not re-raise *)
+      raise (Error "c")
+
+let run args =
+  try
+    ignore (g args.(0)); print_string "No exception\n"
+  with exn ->
+    Printf.printf "Uncaught exception %s\n" (Printexc.to_string exn);
+    Printexc.print_backtrace stdout
+
+let _ =
+  Printexc.record_backtrace true;
+  run [| "a" |];
+  run [| "b" |];
+  run [| "c" |];
+  run [| "d" |];
+  run [| |]

testsuite/tests/backtrace/backtrace3.reference

@@ -0,0 +1,27 @@
+a
+No exception
+b
+Uncaught exception Backtrace3.Error("b")
+Raised at file "backtrace3.ml", line 7, characters 21-32
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 11, characters 4-11
+Re-raised at file "backtrace3.ml", line 20, characters 47-50
+Called from file "backtrace3.ml", line 28, characters 11-23
+Uncaught exception Backtrace3.Error("c")
+Raised at file "backtrace3.ml", line 24, characters 12-23
+Called from file "backtrace3.ml", line 28, characters 11-23
+Uncaught exception Backtrace3.Error("d")
+Raised at file "backtrace3.ml", line 7, characters 21-32
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 11, characters 4-11
+Called from file "backtrace3.ml", line 28, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "backtrace3.ml", line 28, characters 14-22