Index: stdlib/printexc.mli
===================================================================
--- stdlib/printexc.mli	(revision 13257)
+++ stdlib/printexc.mli	(working copy)
@@ -82,3 +82,8 @@
     the backtrace if it has itself raised an exception before.
     @since 3.11.2
 *)
+
+val current_call_stack: unit -> (string * int * int * int) list
+(** [Printexc.current_call_stack ()] returns a suffix of the current
+    call stack (whose length is not specified).  Each item is a tuple
+    (file name, line number, first character, last character). *)
Index: stdlib/printexc.ml
===================================================================
--- stdlib/printexc.ml	(revision 13257)
+++ stdlib/printexc.ml	(working copy)
@@ -137,5 +137,28 @@
 external record_backtrace: bool -> unit = "caml_record_backtrace"
 external backtrace_status: unit -> bool = "caml_backtrace_status"
 
+external set_backtrace_extract: bool -> unit = "caml_set_backtrace_extract"
+
+let current_call_stack () =
+  let rb = backtrace_status () in
+  record_backtrace true;
+  set_backtrace_extract true;
+  (try raise Exit with _ -> ());
+  let bt = get_exception_backtrace () in
+  set_backtrace_extract false;
+  record_backtrace rb;
+  match bt with
+  | None -> []
+  | Some a ->
+      let res = ref [] in
+      for i = Array.length a - 1 downto 0 do
+        match a.(i) with
+        | Known_location (_, fn, lineno, ch1, ch2) when fn <> "printexc.ml" ->
+            res := (fn, lineno, ch1, ch2) :: !res
+        | _ -> ()
+      done;
+      !res
+
+
 let register_printer fn =
   printers := fn :: !printers
Index: boot/ocamldep
===================================================================
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Index: boot/ocamllex
===================================================================
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Index: boot/ocamlc
===================================================================
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Index: byterun/backtrace.c
===================================================================
--- byterun/backtrace.c	(revision 13257)
+++ byterun/backtrace.c	(working copy)
@@ -35,6 +35,7 @@
 
 CAMLexport int caml_backtrace_active = 0;
 CAMLexport int caml_backtrace_pos = 0;
+CAMLexport int caml_backtrace_extract = 0;
 CAMLexport code_t * caml_backtrace_buffer = NULL;
 CAMLexport value caml_backtrace_last_exn = Val_unit;
 CAMLexport char * caml_cds_file = NULL;
@@ -59,6 +60,10 @@
   POS_CNUM = 3
 };
 
+CAMLprim value caml_set_backtrace_extract(value vflag){
+  caml_backtrace_extract = Int_val(vflag);
+  return Val_unit;
+}
 /* Start or stop the backtrace machinery */
 
 CAMLprim value caml_record_backtrace(value vflag)
@@ -92,6 +97,7 @@
 
 void caml_stash_backtrace(value exn, code_t pc, value * sp)
 {
+  value * limit;
   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) {
@@ -106,7 +112,8 @@
   if (pc >= caml_start_code && pc < end_code){
     caml_backtrace_buffer[caml_backtrace_pos++] = pc;
   }
-  for (/*nothing*/; sp < caml_trapsp; sp++) {
+  limit = (caml_backtrace_extract ? caml_stack_high : caml_trapsp);
+  for (/*nothing*/; sp < limit; sp++) {
     code_t p = (code_t) *sp;
     if (p >= caml_start_code && p < end_code) {
       if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) break;
Index: asmrun/backtrace.c
===================================================================
--- asmrun/backtrace.c	(revision 13257)
+++ asmrun/backtrace.c	(working copy)
@@ -23,10 +23,16 @@
 
 int caml_backtrace_active = 0;
 int caml_backtrace_pos = 0;
+int caml_backtrace_extract = 0;
 code_t * caml_backtrace_buffer = NULL;
 value caml_backtrace_last_exn = Val_unit;
 #define BACKTRACE_BUFFER_SIZE 1024
 
+CAMLprim value caml_set_backtrace_extract(value vflag){
+  caml_backtrace_extract = Int_val(vflag);
+  return Val_unit;
+}
+
 /* Start or stop the backtrace machinery */
 
 CAMLprim value caml_record_backtrace(value vflag)
@@ -104,9 +110,9 @@
     }
     /* Stop when we reach the current exception handler */
 #ifndef Stack_grows_upwards
-    if (sp > trapsp) return;
+    if (sp > trapsp && !caml_backtrace_extract) return;
 #else
-    if (sp < trapsp) return;
+    if (sp < trapsp && !caml_backtrace_extract) return;
 #endif
   }
 }

From a2d2342e4e85758be2361017ba2853cc367ce781 Mon Sep 17 00:00:00 2001
From: Jacques-Henri Jourdan <jacques-henri.jourdan@inria.fr>
Date: Sun, 21 Apr 2013 16:49:03 +0200
Subject: [PATCH] * PR#0005899 : exposing a way to inspect current call stack *
 list_of_raw_backtrace

---
 asmrun/backtrace.c  |  62 +++++++++++++++++++++++++++++++++++++++++----------
 byterun/backtrace.c |  63 ++++++++++++++++++++++++++++++++++++++++++++--------
 stdlib/printexc.ml  |  17 ++++++++++++++
 stdlib/printexc.mli |   8 +++++++
 4 files changed, 129 insertions(+), 21 deletions(-)

diff --git a/asmrun/backtrace.c b/asmrun/backtrace.c
index 3ca1824..84cdc26 100644
--- a/asmrun/backtrace.c
+++ b/asmrun/backtrace.c
@@ -58,22 +58,15 @@ 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, uintnat pc, char * sp, char * trapsp)
+void caml_stash_backtrace_custom(uintnat pc, char * sp, char * trapsp, int maxframes,
+				 code_t ** buffer, int buffer_size, int * buffer_pos)
 {
   frame_descr * d;
   uintnat h;
 
-  if (exn != caml_backtrace_last_exn) {
-    caml_backtrace_pos = 0;
-    caml_backtrace_last_exn = exn;
-  }
-  if (caml_backtrace_buffer == NULL) {
-    caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t));
-    if (caml_backtrace_buffer == NULL) return;
-  }
   if (caml_frame_descriptors == NULL) caml_init_frame_descriptors();
 
-  while (1) {
+  while (*buffer_pos < maxframes) {
     /* Find the descriptor corresponding to the return address */
     h = Hash_retaddr(pc);
     while(1) {
@@ -85,8 +78,18 @@ void caml_stash_backtrace(value exn, uintnat pc, char * sp, char * trapsp)
     /* Skip to next frame */
     if (d->frame_size != 0xFFFF) {
       /* Regular frame, store its descriptor in the backtrace buffer */
-      if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) return;
-      caml_backtrace_buffer[caml_backtrace_pos++] = (code_t) d;
+      if (*buffer_pos >= buffer_size) {
+	int new_buffer_size = buffer_size * 2 + 1;
+	if(new_buffer_size > maxframes)
+	  new_buffer_size = maxframes;
+	code_t *new_buffer = (code_t*)realloc(*buffer, new_buffer_size * sizeof(code_t));
+	if(new_buffer == NULL)
+	  return;
+	buffer_size = new_buffer_size;
+	*buffer = new_buffer;
+      }
+      (*buffer)[(*buffer_pos)++] = (code_t) d;
+
 #ifndef Stack_grows_upwards
       sp += (d->frame_size & 0xFFFC);
 #else
@@ -114,6 +117,41 @@ void caml_stash_backtrace(value exn, uintnat pc, char * sp, char * trapsp)
   }
 }
 
+void caml_stash_backtrace(value exn, uintnat pc, char * sp, char * trapsp) {
+  if (exn != caml_backtrace_last_exn) {
+    caml_backtrace_pos = 0;
+    caml_backtrace_last_exn = exn;
+  }
+  if (caml_backtrace_buffer == NULL) {
+    caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t));
+    if (caml_backtrace_buffer == NULL) return;
+  }
+  caml_stash_backtrace_custom(pc, sp, trapsp, BACKTRACE_BUFFER_SIZE,
+			      &caml_backtrace_buffer, BACKTRACE_BUFFER_SIZE, &caml_backtrace_pos);
+}
+
+CAMLprim value caml_stash_current_backtrace(value maxframes) {
+  CAMLparam1(maxframes);
+  CAMLlocal1(res);
+
+  int initial_size = 16;
+  if(initial_size > maxframes)
+    initial_size = maxframes;
+  code_t * buffer = (code_t*)malloc(initial_size * sizeof(code_t));
+  int buffer_pos = 0;
+  int imaxframes = Int_val(maxframes);
+
+  caml_stash_backtrace_custom(caml_last_return_address, caml_bottom_of_stack, caml_top_of_stack,
+			      imaxframes, &buffer, initial_size, &buffer_pos);
+
+  res = caml_alloc(buffer_pos, Abstract_tag);
+  memcpy(&Field(res, 0), buffer, buffer_pos * sizeof(code_t));
+
+  free(buffer);
+
+  CAMLreturn(res);
+}
+
 /* Extract location information for the given frame descriptor */
 
 struct loc_info {
diff --git a/byterun/backtrace.c b/byterun/backtrace.c
index 9e894f2..07433a7 100644
--- a/byterun/backtrace.c
+++ b/byterun/backtrace.c
@@ -93,10 +93,36 @@ 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_custom(value * sp, value * limitsp, int maxframes,
+				 code_t ** buffer, int buffer_size, int * buffer_pos)
 {
   code_t end_code = (code_t) ((char *) caml_start_code + caml_code_size);
-  if (pc != NULL) pc = pc - 1;
+  value* trapsp = caml_trapsp;
+  for (/*nothing*/; sp < limitsp && *buffer_pos < maxframes; sp++) {
+    if(&Trap_pc(trapsp) == (code_t*)sp) {
+      trapsp = Trap_link(trapsp);
+      continue;
+    }
+
+    code_t p = (code_t) *sp;
+    if (p >= caml_start_code && p < end_code) {
+      if (*buffer_pos >= buffer_size) {
+	int new_buffer_size = buffer_size * 2 + 1;
+	if(new_buffer_size > maxframes)
+	  new_buffer_size = maxframes;
+	code_t *new_buffer =
+	  (code_t*)realloc(*buffer, new_buffer_size * sizeof(code_t));
+	if(new_buffer == NULL)
+	  break;
+	buffer_size = new_buffer_size;
+	*buffer = new_buffer;
+      }
+      (*buffer)[(*buffer_pos)++] = p;
+    }
+  }
+}
+
+void caml_stash_backtrace(value exn, code_t pc, value * sp) {
   if (exn != caml_backtrace_last_exn) {
     caml_backtrace_pos = 0;
     caml_backtrace_last_exn = exn;
@@ -105,17 +131,36 @@ void caml_stash_backtrace(value exn, code_t pc, value * sp)
     caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t));
     if (caml_backtrace_buffer == NULL) return;
   }
+  code_t end_code = (code_t) ((char *) caml_start_code + caml_code_size);
+  if (pc != NULL) pc = pc - 1;
   if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) return;
   if (pc >= caml_start_code && pc < end_code){
     caml_backtrace_buffer[caml_backtrace_pos++] = pc;
   }
-  for (/*nothing*/; sp < caml_trapsp; sp++) {
-    code_t p = (code_t) *sp;
-    if (p >= caml_start_code && p < end_code) {
-      if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) break;
-      caml_backtrace_buffer[caml_backtrace_pos++] = p;
-    }
-  }
+  caml_stash_backtrace_custom(sp, caml_trapsp, BACKTRACE_BUFFER_SIZE,
+			      &caml_backtrace_buffer, BACKTRACE_BUFFER_SIZE, &caml_backtrace_pos);
+}
+
+CAMLprim value caml_stash_current_backtrace(value maxframes) {
+  CAMLparam1(maxframes);
+  CAMLlocal1(res);
+
+  int initial_size = 16;
+  if(initial_size > maxframes)
+    initial_size = maxframes;
+  code_t * buffer = (code_t*)malloc(initial_size * sizeof(code_t));
+  int buffer_pos = 0;
+  int imaxframes = Int_val(maxframes);
+
+  caml_stash_backtrace_custom(caml_extern_sp, caml_stack_high,
+			      imaxframes, &buffer, initial_size, &buffer_pos);
+
+  res = caml_alloc(buffer_pos, Abstract_tag);
+  memcpy(&Field(res, 0), buffer, buffer_pos * sizeof(code_t));
+
+  free(buffer);
+
+  CAMLreturn(res);
 }
 
 /* Read the debugging info contained in the current bytecode executable.
diff --git a/stdlib/printexc.ml b/stdlib/printexc.ml
index a36e2d4..9acbebd 100644
--- a/stdlib/printexc.ml
+++ b/stdlib/printexc.ml
@@ -163,5 +163,22 @@ let get_backtrace () =
 external record_backtrace: bool -> unit = "caml_record_backtrace"
 external backtrace_status: unit -> bool = "caml_backtrace_status"
 
+let list_of_raw_backtrace bt =
+  let bt = convert_raw_backtrace bt in
+  match bt with
+  | None -> []
+  | Some a ->
+      let res = ref [] in
+      for i = Array.length a - 1 downto 0 do
+        match a.(i) with
+        | Known_location (_, fn, lineno, ch1, ch2) ->
+            res := (fn, lineno, ch1, ch2) :: !res
+        | _ -> ()
+      done;
+      !res
+
 let register_printer fn =
   printers := fn :: !printers
+
+external current_backtrace:
+  int -> raw_backtrace = "caml_stash_current_backtrace"
diff --git a/stdlib/printexc.mli b/stdlib/printexc.mli
index ad48f66..6a2d134 100644
--- a/stdlib/printexc.mli
+++ b/stdlib/printexc.mli
@@ -100,3 +100,11 @@ val get_raw_backtrace: unit -> raw_backtrace
 val print_raw_backtrace: out_channel -> raw_backtrace -> unit
 val raw_backtrace_to_string: raw_backtrace -> string
 
+val list_of_raw_backtrace: raw_backtrace -> (string * int * int * int) list
+(** [Printexc.list_of_raw_backtrace bt] converts a raw backtrace to a
+    list of locations. Each item is a tuple (file name, line number,
+    first character, last character). *)
+
+val current_backtrace: int -> raw_backtrace
+(** [Printexc.current_backtrace n] returns the backtrace of the current
+    stack. The backtrace is truncated to the highest [n] frames. *)
-- 
1.8.1.4

commit 057e1d6662f16db70fb363b72b607b45da281c41
Author: Gabriel Scherer <gabriel.scherer@inria.fr>
Date:   Sat Jun 15 21:33:25 2013 +0200

    implement a caml_stash_current_backtrace primitive to save the call stack at any point
    
    This commit only implements runtime support in asmrun/ and byterun/.
    The more subjective Printexc interface will come separately.

diff --git a/asmrun/backtrace.c b/asmrun/backtrace.c
index 94ee9d2..197978b 100644
--- a/asmrun/backtrace.c
+++ b/asmrun/backtrace.c
@@ -48,79 +48,159 @@ CAMLprim value caml_record_backtrace(value vflag)
   return Val_unit;
 }
 
 /* Return the status of the backtrace machinery */
 
 CAMLprim value caml_backtrace_status(value vunit)
 {
   return Val_bool(caml_backtrace_active);
 }
 
-/* Store the return addresses contained in the given stack fragment
-   into the backtrace array */
+/* returns the next frame descriptor (or NULL if none is available),
+   and updates *pc and *sp to point to the following one.  */
 
-void caml_stash_backtrace(value exn, uintnat pc, char * sp, char * trapsp)
+frame_descr * caml_next_frame_descriptor(uintnat * pc, char ** sp)
 {
   frame_descr * d;
   uintnat h;
 
-  if (exn != caml_backtrace_last_exn) {
-    caml_backtrace_pos = 0;
-    caml_backtrace_last_exn = exn;
-  }
-  if (caml_backtrace_buffer == NULL) {
-    caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t));
-    if (caml_backtrace_buffer == NULL) return;
-  }
   if (caml_frame_descriptors == NULL) caml_init_frame_descriptors();
 
   while (1) {
-    /* Find the descriptor corresponding to the return address */
-    h = Hash_retaddr(pc);
-    while(1) {
+    h = Hash_retaddr(*pc);
+    while (1) {
       d = caml_frame_descriptors[h];
-      if (d == 0) return; /* can happen if some code not compiled with -g */
-      if (d->retaddr == pc) break;
+      if (d == 0) return NULL; /* can happen if some code not compiled with -g */
+      if (d->retaddr == *pc) break;
       h = (h+1) & caml_frame_descriptors_mask;
     }
     /* Skip to next frame */
     if (d->frame_size != 0xFFFF) {
-      /* Regular frame, store its descriptor in the backtrace buffer */
-      if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) return;
-      caml_backtrace_buffer[caml_backtrace_pos++] = (code_t) d;
+      /* Regular frame, update sp/pc and return the frame descriptor */
 #ifndef Stack_grows_upwards
-      sp += (d->frame_size & 0xFFFC);
+      *sp += (d->frame_size & 0xFFFC);
 #else
-      sp -= (d->frame_size & 0xFFFC);
+      *sp -= (d->frame_size & 0xFFFC);
 #endif
-      pc = Saved_return_address(sp);
+      *pc = Saved_return_address(*sp);
 #ifdef Mask_already_scanned
-      pc = Mask_already_scanned(pc);
+      *pc = Mask_already_scanned(*pc);
 #endif
+      return d;
     } else {
       /* Special frame marking the top of a stack chunk for an ML callback.
          Skip C portion of stack and continue with next ML stack chunk. */
-      struct caml_context * next_context = Callback_link(sp);
-      sp = next_context->bottom_of_stack;
-      pc = next_context->last_retaddr;
+      struct caml_context * next_context = Callback_link(*sp);
+      *sp = next_context->bottom_of_stack;
+      *pc = next_context->last_retaddr;
       /* A null sp means no more ML stack chunks; stop here. */
-      if (sp == NULL) return;
+      if (*sp == NULL) return NULL;
     }
+  }
+}
+
+/* Stores the return addresses contained in the given stack fragment
+   into the backtrace array ; this version is performance-sensitive as
+   it is called at each [raise] in a program compiled with [-g], so we
+   preserved the global, statically bounded buffer of the old
+   implementation -- before the more flexible
+   caml_stash_current_backtrace was implemented. */
+
+void caml_stash_backtrace(value exn, uintnat pc, char * sp, char * trapsp)
+{
+  if (exn != caml_backtrace_last_exn) {
+    caml_backtrace_pos = 0;
+    caml_backtrace_last_exn = exn;
+  }
+  if (caml_backtrace_buffer == NULL) {
+    caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t));
+    if (caml_backtrace_buffer == NULL) return;
+  }
+
+  /* iterate on each frame  */
+  while (1) {
+    frame_descr * descr = caml_next_frame_descriptor(&pc, &sp);
+    if (descr == NULL) return;
+    /* store its descriptor in the backtrace buffer */
+    if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) return;
+    caml_backtrace_buffer[caml_backtrace_pos++] = (code_t) descr;
+    
     /* Stop when we reach the current exception handler */
 #ifndef Stack_grows_upwards
     if (sp > trapsp) return;
 #else
     if (sp < trapsp) return;
 #endif
   }
 }
 
+/* Stores upto [max_frames_value] frames to return to the user. This
+   is used not in an exception-raising context, but 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_stash_current_backtrace(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 */
+  {
+    uintnat pc = caml_last_return_address;
+    /* note that [caml_bottom_of_stack] always points to the most recent
+     * frame, independently of the [Stack_grows_upwards] setting */
+    char * sp = caml_bottom_of_stack;
+    char * limitsp = caml_top_of_stack;
+
+    trace_size = 0;
+    while (1) {
+      frame_descr * descr = caml_next_frame_descriptor(&pc, &sp);
+      if (descr == NULL) break; 
+      if (trace_size >= max_frames) break;
+      ++trace_size;
+
+#ifndef Stack_grows_upwards
+      if (sp > limitsp) break;
+#else
+      if (sp < limitsp) break;
+#endif
+    }
+  }
+
+  trace = caml_alloc((mlsize_t) trace_size, Abstract_tag);
+
+  /* then collect the trace */
+  {
+    uintnat pc = caml_last_return_address;
+    char * sp = caml_bottom_of_stack;
+    intnat trace_pos;
+
+    for (trace_pos = 0; trace_pos < trace_size; trace_pos++) {
+      frame_descr * descr = caml_next_frame_descriptor(&pc, &sp);
+      Assert(descr != 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) descr) && Is_in_heap((value) descr)));
+      Field(trace, trace_pos) = (value) descr;
+    }
+  }
+
+  CAMLreturn(trace);
+}
+
 /* Extract location information for the given frame descriptor */
 
 struct loc_info {
   int loc_valid;
   int loc_is_raise;
   char * loc_filename;
   int loc_lnum;
   int loc_startchr;
   int loc_endchr;
 };
diff --git a/byterun/backtrace.c b/byterun/backtrace.c
index 0bcc221..19f43b2 100644
--- a/byterun/backtrace.c
+++ b/byterun/backtrace.c
@@ -100,31 +100,100 @@ void caml_stash_backtrace(value exn, code_t pc, value * sp)
   if (exn != caml_backtrace_last_exn) {
     caml_backtrace_pos = 0;
     caml_backtrace_last_exn = exn;
   }
   if (caml_backtrace_buffer == NULL) {
     caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t));
     if (caml_backtrace_buffer == NULL) return;
   }
   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++) {
     code_t p = (code_t) *sp;
     if (p >= caml_start_code && p < end_code) {
       if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) break;
       caml_backtrace_buffer[caml_backtrace_pos++] = p;
     }
   }
 }
 
+/* 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 to return to the user. This
+   is used not in an exception-raising context, but 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_stash_current_backtrace(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. */
 
 #ifndef O_BINARY
 #define O_BINARY 0
 #endif
 
 static value read_debug_info(void)
 {

commit 7ccf73df2527344c4f516193de044d3b295c8629
Author: Gabriel Scherer <gabriel.scherer@inria.fr>
Date:   Sat Jun 15 21:35:25 2013 +0200

    add user-visible support in Printexc for the new caml_stash_current_backtrace primitive

diff --git a/stdlib/printexc.ml b/stdlib/printexc.ml
index a36e2d4..72d1efc 100644
--- a/stdlib/printexc.ml
+++ b/stdlib/printexc.ml
@@ -93,21 +93,24 @@ type loc_info =
   | Unknown_location of bool (*is_raise*)
 
 (* to avoid warning *)
 let _ = [Known_location (false, "", 0, 0, 0); Unknown_location false]
 
 type backtrace = loc_info array
 
 external convert_raw_backtrace:
   raw_backtrace -> backtrace option = "caml_convert_raw_backtrace"
 
-let format_loc_info pos li =
+(* this alias is exposed to users *)
+let loc_info_of_raw_backtrace = convert_raw_backtrace
+
+let loc_info_to_string pos li =
   let is_raise =
     match li with
     | Known_location(is_raise, _, _, _, _) -> is_raise
     | Unknown_location(is_raise) -> is_raise in
   let info =
     if is_raise then
       if pos = 0 then "Raised at" else "Re-raised at"
     else
       if pos = 0 then "Raised by primitive operation at" else "Called from"
   in
@@ -120,48 +123,51 @@ let format_loc_info pos li =
               info
 
 let print_exception_backtrace outchan backtrace =
   match backtrace with
   | None ->
       fprintf outchan
         "(Program not linked with -g, cannot print stack backtrace)\n"
   | Some a ->
       for i = 0 to Array.length a - 1 do
         if a.(i) <> Unknown_location true then
-          fprintf outchan "%s\n" (format_loc_info i a.(i))
+          fprintf outchan "%s\n" (loc_info_to_string i a.(i))
       done
 
 let print_raw_backtrace outchan raw_backtrace =
   print_exception_backtrace outchan (convert_raw_backtrace raw_backtrace)
 
 (* confusingly named: prints the global current backtrace *)
 let print_backtrace outchan =
   print_raw_backtrace outchan (get_raw_backtrace ())
 
 let backtrace_to_string backtrace =
   match backtrace with
   | None ->
      "(Program not linked with -g, cannot print stack backtrace)\n"
   | Some a ->
       let b = Buffer.create 1024 in
       for i = 0 to Array.length a - 1 do
         if a.(i) <> Unknown_location true then
-          bprintf b "%s\n" (format_loc_info i a.(i))
+          bprintf b "%s\n" (loc_info_to_string i a.(i))
       done;
       Buffer.contents b
 
 let raw_backtrace_to_string raw_backtrace =
   backtrace_to_string (convert_raw_backtrace raw_backtrace)
 
 (* confusingly named:
    returns the *string* corresponding to the global current backtrace *)
 let get_backtrace () =
   (* we could use the caml_get_exception_backtrace primitive here, but
      we hope to deprecate it so it's better to just compose the
      raw stuff *)
   backtrace_to_string (convert_raw_backtrace (get_raw_backtrace ()))
 
 external record_backtrace: bool -> unit = "caml_record_backtrace"
 external backtrace_status: unit -> bool = "caml_backtrace_status"
 
+external get_callstack:
+  int -> raw_backtrace = "caml_stash_current_backtrace"
+
 let register_printer fn =
   printers := fn :: !printers
diff --git a/stdlib/printexc.mli b/stdlib/printexc.mli
index b653265..a929594 100644
--- a/stdlib/printexc.mli
+++ b/stdlib/printexc.mli
@@ -92,10 +92,41 @@ type raw_backtrace
     the [get_backtrace()] function does.
 
     This allows to pay the performance overhead of representation
     conversion and formatting only at printing time, which is useful
     if you want to record more backtrace than you actually print.
 *)
 
 val get_raw_backtrace: unit -> raw_backtrace
 val print_raw_backtrace: out_channel -> raw_backtrace -> unit
 val raw_backtrace_to_string: raw_backtrace -> string
+
+val get_callstack: int -> raw_backtrace
+(** [Printexc.get_raw_callstack n] returns the backtrace corresponding
+    to the current call stack -- as opposed to the backtrace of the
+    exception raised last. The backtrace is truncated to the
+    highest [n] frames. *)
+
+(** {6 Facilities for manipulating backtraces} *)
+
+type loc_info =
+  | Known_location of bool   (* is_raise *)
+                    * string (* filename *)
+                    * int    (* line number *)
+                    * int    (* start char *)
+                    * int    (* end char *)
+  | Unknown_location of bool (*is_raise*)
+(** The [loc_info] type represents the location information present in
+    each slot of the backtrace. *)
+
+val loc_info_of_raw_backtrace : raw_backtrace -> loc_info array option
+(** Extracts the location information of a backtrace value. The
+    location of the most recent program point (the one corresponding
+    to the [raise] or call to [current_backtrace]) is at index [0].
+*)
+
+val loc_info_to_string : int -> loc_info -> string
+(** Prints location information, in a way compatible with the
+    behaviour of [backtrace_to_string]. The integer parameter is meant
+    to be a position in a trace, as the most recent location
+    (index [0]) is printed in a specific way.
+*)