1 files changed, 78 insertions, 4 deletions

diff --git a/byterun/backtrace.c b/byterun/backtrace.c
index 9e894f2164..4098e47e20 100644
--- a/byterun/backtrace.c
+++ b/byterun/backtrace.c
@@ -107,6 +107,7 @@ void caml_stash_backtrace(value exn, code_t pc, value * sp)
   }
   if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) return;
   if (pc >= caml_start_code && pc < end_code){
+    /* testing the code region is needed: PR#1554 */
     caml_backtrace_buffer[caml_backtrace_pos++] = pc;
   }
   for (/*nothing*/; sp < caml_trapsp; sp++) {
@@ -118,6 +119,74 @@ void caml_stash_backtrace(value exn, code_t pc, value * sp)
   }
 }
 
+/* returns the next frame pointer (or NULL if none is available);
+   updates *sp to point to the following one, and *trapsp to the next
+   trap frame, which we will skip when we reach it  */
+
+code_t caml_next_frame_pointer(value ** sp, value ** trapsp)
+{
+  code_t end_code = (code_t) ((char *) caml_start_code + caml_code_size);
+
+  while (*sp < caml_stack_high) {
+    code_t *p = (code_t*) (*sp)++;
+    if(&Trap_pc(*trapsp) == p) {
+      *trapsp = Trap_link(*trapsp);
+      continue;
+    }
+    if (*p >= caml_start_code && *p < end_code) return *p;
+  }
+  return NULL;
+}
+
+/* Stores upto [max_frames_value] frames of the current call stack to
+   return to the user. This is used not in an exception-raising
+   context, but only when the user requests to save the trace
+   (hopefully less often). Instead of using a bounded buffer as
+   [caml_stash_backtrace], we first traverse the stack to compute the
+   right size, then allocate space for the trace. */
+
+CAMLprim value caml_get_current_callstack(value max_frames_value) {
+  CAMLparam1(max_frames_value);
+  CAMLlocal1(trace);
+
+  /* we use `intnat` here because, were it only `int`, passing `max_int`
+     from the OCaml side would overflow on 64bits machines. */
+  intnat max_frames = Long_val(max_frames_value);
+  intnat trace_size;
+
+  /* first compute the size of the trace */
+  {
+    value * sp = caml_extern_sp;
+    value * trapsp = caml_trapsp;
+
+    for (trace_size = 0; trace_size < max_frames; trace_size++) {
+      code_t p = caml_next_frame_pointer(&sp, &trapsp);
+      if (p == NULL) break;
+    }
+  }
+
+  trace = caml_alloc(trace_size, Abstract_tag);
+
+  /* then collect the trace */
+  {
+    value * sp = caml_extern_sp;
+    value * trapsp = caml_trapsp;
+    uintnat trace_pos;
+
+    for (trace_pos = 0; trace_pos < trace_size; trace_pos++) {
+      code_t p = caml_next_frame_pointer(&sp, &trapsp);
+      Assert(p != NULL);
+      /* The assignment below is safe without [caml_initialize], even
+         if the trace is large and allocated on the old heap, because
+         we assign values that are outside the OCaml heap. */
+      Assert(!(Is_block((value) p) && Is_in_heap((value) p)));
+      Field(trace, trace_pos) = (value) p;
+    }
+  }
+
+  CAMLreturn(trace);
+}
+
 /* Read the debugging info contained in the current bytecode executable.
    Return an OCaml array of OCaml lists of debug_event records in "events",
    or Val_false on failure. */
@@ -126,6 +195,7 @@ void caml_stash_backtrace(value exn, code_t pc, value * sp)
 #define O_BINARY 0
 #endif
 
+static char *read_debug_info_error = "";
 static value read_debug_info(void)
 {
   CAMLparam0();
@@ -143,10 +213,14 @@ static value read_debug_info(void)
     exec_name = caml_exe_name;
   }
   fd = caml_attempt_open(&exec_name, &trail, 1);
-  if (fd < 0) CAMLreturn(Val_false);
+  if (fd < 0){
+    read_debug_info_error = "executable program file not found";
+    CAMLreturn(Val_false);
+  }
   caml_read_section_descriptors(fd, &trail);
   if (caml_seek_optional_section(fd, &trail, "DBUG") == -1) {
     close(fd);
+    read_debug_info_error = "program not linked with -g";
     CAMLreturn(Val_false);
   }
   chan = caml_open_descriptor_in(fd);
@@ -225,7 +299,7 @@ static void extract_location_info(value events, code_t pc,
     - Int_val (Field (ev_start, POS_BOL));
 }
 
-/* Print location information */
+/* Print location information -- same behavior as in Printexc */
 
 static void print_location(struct loc_info * li, int index)
 {
@@ -265,8 +339,8 @@ CAMLexport void caml_print_exception_backtrace(void)
 
   events = read_debug_info();
   if (events == Val_false) {
-    fprintf(stderr,
-            "(Program not linked with -g, cannot print stack backtrace)\n");
+    fprintf(stderr, "(Cannot print stack backtrace: %s)\n",
+            read_debug_info_error);
     return;
   }
   for (i = 0; i < caml_backtrace_pos; i++) {