Better call stacks when a C call is involved in byte code mode.

The previous mechanism only worked in the case the C call in question
raises an exception.

Changes

@@ -26,6 +26,9 @@ Working version
   (Stephen Dolan, Xavier Leroy and David Allsopp,
    review by Xavier Leroy and Gabriel Scherer)
 
+- #8641: Better call stacks when a C call is involved in byte code mode
+  (Jacques-Henri Jourdan, review by Xavier Leroy)
+
 ### Standard library:
 
 - #8657: Optimization in [Array.make] when initializing with unboxed

runtime/backtrace_byt.c

@@ -229,9 +229,8 @@ int caml_alloc_backtrace_buffer(void){
 /* 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, int reraise)
+void caml_stash_backtrace(value exn, value * sp, int reraise)
 {
-  if (pc != NULL) pc = pc - 1;
   if (exn != caml_backtrace_last_exn || !reraise) {
     caml_backtrace_pos = 0;
     caml_backtrace_last_exn = exn;
@@ -240,11 +239,6 @@ void caml_stash_backtrace(value exn, code_t pc, value * sp, int reraise)
   if (caml_backtrace_buffer == NULL && caml_alloc_backtrace_buffer() == -1)
     return;
 
-  if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) return;
-  /* testing the code region is needed: PR#8026 */
-  if (find_debug_info(pc) != NULL)
-    caml_backtrace_buffer[caml_backtrace_pos++] = pc;
-
   /* Traverse the stack and put all values pointing into bytecode
      into the backtrace buffer. */
   for (/*nothing*/; sp < caml_trapsp; sp++) {

runtime/caml/backtrace.h

@@ -115,7 +115,7 @@ CAMLextern char_os * caml_cds_file;
 /* Primitive called _only_ by runtime to record unwinded frames to
  * backtrace.  A similar primitive exists for native code, but with a
  * different prototype. */
-extern void caml_stash_backtrace(value exn, code_t pc, value * sp, int reraise);
+extern void caml_stash_backtrace(value exn, value * sp, int reraise);
 
 #endif
 

runtime/interp.c

@@ -71,12 +71,19 @@ sp is a local copy of the global variable caml_extern_sp. */
   { sp -= 2; sp[0] = accu; sp[1] = env; caml_extern_sp = sp; }
 #define Restore_after_gc \
   { accu = sp[0]; env = sp[1]; sp += 2; }
+
+/* We store [pc+1] in the stack so that, in case of an exception, the
+   first backtrace slot points to the event following the C call
+   instruction. */
 #define Setup_for_c_call \
-  { saved_pc = pc; *--sp = env; caml_extern_sp = sp; }
+  { sp -= 2; sp[0] = env; sp[1] = (value)(pc + 1); caml_extern_sp = sp; }
 #define Restore_after_c_call \
-  { sp = caml_extern_sp; env = *sp++; saved_pc = NULL; }
+  { sp = caml_extern_sp; env = *sp; sp += 2; }
 
-/* An event frame must look like accu + a C_CALL frame + a RETURN 1 frame */
+/* For VM threads purposes, an event frame must look like accu + a
+   C_CALL frame + a RETURN 1 frame.
+   TODO: now that VM threads are gone, we could get rid of that. But
+   we need to make sure that this is not used elsewhere. */
 #define Setup_for_event \
   { sp -= 6; \
     sp[0] = accu; /* accu */ \
@@ -109,6 +116,9 @@ sp is a local copy of the global variable caml_extern_sp. */
   goto dispatch_instr
 #endif
 
+#define Check_trap_barrier \
+  if (caml_trapsp >= caml_trap_barrier) caml_debugger(TRAP_BARRIER)
+
 /* Register optimization.
    Some compilers underestimate the use of the local variables representing
    the abstract machine registers, and don't put them in hardware registers,
@@ -214,10 +224,9 @@ value caml_interprete(code_t prog, asize_t prog_size)
   intnat extra_args;
   struct longjmp_buffer * initial_external_raise;
   intnat initial_sp_offset;
-  /* volatile ensures that initial_local_roots and saved_pc
+  /* volatile ensures that initial_local_roots
      will keep correct value across longjmp */
   struct caml__roots_block * volatile initial_local_roots;
-  volatile code_t saved_pc = NULL;
   struct longjmp_buffer raise_buf;
 #ifndef THREADED_CODE
   opcode_t curr_instr;
@@ -244,16 +253,20 @@ value caml_interprete(code_t prog, asize_t prog_size)
   initial_sp_offset = (char *) caml_stack_high - (char *) caml_extern_sp;
   initial_external_raise = caml_external_raise;
   caml_callback_depth++;
-  saved_pc = NULL;
 
   if (sigsetjmp(raise_buf.buf, 0)) {
     caml_local_roots = initial_local_roots;
     sp = caml_extern_sp;
     accu = caml_exn_bucket;
-    pc = saved_pc; saved_pc = NULL;
-    if (pc != NULL) pc += 2;
-        /* +2 adjustment for the sole purpose of backtraces */
-    goto raise_exception;
+
+    Check_trap_barrier;
+    if (caml_backtrace_active) {
+      /* pc has already been pushed on the stack when calling the C
+         function that raised the exception. No need to push it again
+         here. */
+      caml_stash_backtrace(accu, sp, 0);
+    }
+    goto raise_notrace;
   }
   caml_external_raise = &raise_buf;
 
@@ -843,18 +856,23 @@ value caml_interprete(code_t prog, asize_t prog_size)
       Next;
 
     Instruct(RAISE_NOTRACE):
-      if (caml_trapsp >= caml_trap_barrier) caml_debugger(TRAP_BARRIER);
+      Check_trap_barrier;
       goto raise_notrace;
 
     Instruct(RERAISE):
-      if (caml_trapsp >= caml_trap_barrier) caml_debugger(TRAP_BARRIER);
-      if (caml_backtrace_active) caml_stash_backtrace(accu, pc, sp, 1);
+      Check_trap_barrier;
+      if (caml_backtrace_active) {
+        *--sp = (value)(pc - 1);
+        caml_stash_backtrace(accu, sp, 1);
+      }
       goto raise_notrace;
 
     Instruct(RAISE):
-    raise_exception:
-      if (caml_trapsp >= caml_trap_barrier) caml_debugger(TRAP_BARRIER);
-      if (caml_backtrace_active) caml_stash_backtrace(accu, pc, sp, 0);
+      Check_trap_barrier;
+      if (caml_backtrace_active) {
+        *--sp = (value)(pc - 1);
+        caml_stash_backtrace(accu, sp, 0);
+      }
     raise_notrace:
       if ((char *) caml_trapsp
           >= (char *) caml_stack_high - initial_sp_offset) {
@@ -905,28 +923,28 @@ value caml_interprete(code_t prog, asize_t prog_size)
       Next;
     Instruct(C_CALL2):
       Setup_for_c_call;
-      accu = Primitive(*pc)(accu, sp[1]);
+      accu = Primitive(*pc)(accu, sp[2]);
       Restore_after_c_call;
       sp += 1;
       pc++;
       Next;
     Instruct(C_CALL3):
       Setup_for_c_call;
-      accu = Primitive(*pc)(accu, sp[1], sp[2]);
+      accu = Primitive(*pc)(accu, sp[2], sp[3]);
       Restore_after_c_call;
       sp += 2;
       pc++;
       Next;
     Instruct(C_CALL4):
       Setup_for_c_call;
-      accu = Primitive(*pc)(accu, sp[1], sp[2], sp[3]);
+      accu = Primitive(*pc)(accu, sp[2], sp[3], sp[4]);
       Restore_after_c_call;
       sp += 3;
       pc++;
       Next;
     Instruct(C_CALL5):
       Setup_for_c_call;
-      accu = Primitive(*pc)(accu, sp[1], sp[2], sp[3], sp[4]);
+      accu = Primitive(*pc)(accu, sp[2], sp[3], sp[4], sp[5]);
       Restore_after_c_call;
       sp += 4;
       pc++;
@@ -935,7 +953,7 @@ value caml_interprete(code_t prog, asize_t prog_size)
       int nargs = *pc++;
       *--sp = accu;
       Setup_for_c_call;
-      accu = Primitive(*pc)(sp + 1, nargs);
+      accu = Primitive(*pc)(sp + 2, nargs);
       Restore_after_c_call;
       sp += nargs;
       pc++;

runtime/meta.c

@@ -214,6 +214,7 @@ CAMLprim value caml_invoke_traced_function(value codeptr, value env, value arg)
        arg1 to call_original_code (codeptr)
        arg3 to call_original_code (arg)
        arg2 to call_original_code (env)
+       saved pc
        saved env */
 
   /* Stack layout on exit:
@@ -223,11 +224,12 @@ CAMLprim value caml_invoke_traced_function(value codeptr, value env, value arg)
          extra_args = 0
          environment = env
          PC = codeptr
-       arg3 to call_original_code (arg)                   same 6 bottom words as
+       arg3 to call_original_code (arg)                   same 7 bottom words as
        arg2 to call_original_code (env)                   on entrance, but
        arg1 to call_original_code (codeptr)               shifted down 4 words
        arg3 to call_original_code (arg)
        arg2 to call_original_code (env)
+       saved pc
        saved env */
 
   value * osp, * nsp;
@@ -236,11 +238,11 @@ CAMLprim value caml_invoke_traced_function(value codeptr, value env, value arg)
   osp = caml_extern_sp;
   caml_extern_sp -= 4;
   nsp = caml_extern_sp;
-  for (i = 0; i < 6; i++) nsp[i] = osp[i];
-  nsp[6] = codeptr;
-  nsp[7] = env;
-  nsp[8] = Val_int(0);
-  nsp[9] = arg;
+  for (i = 0; i < 7; i++) nsp[i] = osp[i];
+  nsp[7] = codeptr;
+  nsp[8] = env;
+  nsp[9] = Val_int(0);
+  nsp[10] = arg;
   return Val_unit;
 }
 

stdlib/printexc.mli

@@ -157,7 +157,7 @@ external raise_with_backtrace: exn -> raw_backtrace -> 'a
 
 (** {1 Current call stack} *)
 
-val get_callstack: int -> raw_backtrace
+external get_callstack: int -> raw_backtrace = "caml_get_current_callstack"
 (** [Printexc.get_callstack n] returns a description of the top of the
     call stack on the current program point (for the current thread),
     with at most [n] entries.  (Note: this function is not related to

testsuite/tests/backtrace/callstack.ml

@@ -17,3 +17,8 @@ let () = Printf.printf "main thread:\n"
 let () = f3 ()
 let () = Printf.printf "new thread:\n"
 let () = Thread.join (Thread.create f3 ())
+
+let () =
+  Gc.finalise (fun _ -> f0 ()) [|1|];
+  Gc.full_major ();
+  ()

testsuite/tests/backtrace/callstack.reference

@@ -10,3 +10,5 @@ Called from file "callstack.ml", line 13, characters 27-32
 Called from file "callstack.ml", line 14, characters 27-32
 Called from file "callstack.ml", line 15, characters 27-32
 Called from file "thread.ml", line 39, characters 8-14
+Raised by primitive operation at file "callstack.ml", line 12, characters 38-66
+Called from file "callstack.ml", line 23, characters 2-18

testsuite/tests/statmemprof/arrays_in_major.ml

@@ -1,10 +1,6 @@
 (* TEST
    flags = "-g"
-   * bytecode
-     reference = "${test_source_directory}/arrays_in_major.byte.reference"
-   * native
-     reference = "${test_source_directory}/arrays_in_major.opt.reference"
-     compare_programs = "false"
+   compare_programs = "false"
 *)
 
 open Gc.Memprof
@@ -108,18 +104,6 @@ let () =
   check_distrib 300 300 100000 0.1;
   check_distrib 300000 300000 30 0.1
 
-(* FIXME : in bytecode mode, the function [caml_get_current_callstack_impl],
-   which is supposed to capture the current call stack, does not have access
-   to the current value of [pc]. Therefore, depending on how the C call is
-   performed, we may miss the first call stack slot in the captured backtraces.
-   This is the reason why the reference file is different in native and
-   bytecode modes.
-
-   Note that [Printexc.get_callstack] does not suffer from this problem, because
-   this function is actually an automatically generated stub which performs th
-   C call. This is because [Printexc.get_callstack] is not declared as external
-   in the mli file. *)
-
 let[@inline never] check_callstack () =
   Printf.printf "check_callstack\n%!";
   let callstack = ref None in

testsuite/tests/statmemprof/arrays_in_major.opt.reference → testsuite/tests/statmemprof/arrays_in_major.reference

@@ -8,7 +8,7 @@ check_distrib 300 3000 1 1.000000
 check_distrib 300 300 100000 0.100000
 check_distrib 300000 300000 30 0.100000
 check_callstack
-Raised by primitive operation at file "arrays_in_major.ml", line 16, characters 14-28
-Called from file "arrays_in_major.ml", line 133, characters 2-35
-Called from file "arrays_in_major.ml", line 139, characters 9-27
+Raised by primitive operation at file "arrays_in_major.ml", line 12, characters 14-28
+Called from file "arrays_in_major.ml", line 117, characters 2-35
+Called from file "arrays_in_major.ml", line 123, characters 9-27
 OK !