Patch for native function backtraces

--x+6KMIRAuhnl3hBn
Content-Type: text/plain; charset=us-ascii
Content-Disposition: inline

Hi,

I'd like to share a patch (attached) for the OCaml compiler and runtime
which enables native function backtraces.  This allows you to get a
backtrace of the last functions called by OCaml at anytime when executing
native code programs.  This is especially useful as debugging aid in
the case of unexpected exceptions.

Note, however, that these are not stack backtraces but function call
backtraces.  Due to the way OCaml works, stack backtraces, which would
usually be more informative, are virtually impossible to get with native
code.  Function call backtraces give you at least some indication of
what happened before e.g. an uncaught exception escaped your application.

The runtime overhead added to programs compiled with debug information
for native backtraces is generally satisfactory.  It's at most around
100% for functions that just add two numbers when inlining is turned off.
For larger functions, or when inlining is turned on, which is the default,
it should be much lower (very program specific).

Native function backtraces are thread-safe, i.e. each thread has its
own backtrace.  The overhead added to thread creation/destruction and
context-switching has not been benchmarked, but it's unlikely that
anybody can measure a difference.

The OCaml-developers at INRIA may feel free to add this patch to their
distribution, the BSD-like license is very liberal.

See the instructions in the patch file on how to apply it, and how to
use backtraces.

Best regards,
Markus

-- 
Markus Mottl    [email protected]    http://www.ocaml.info

--x+6KMIRAuhnl3hBn
Content-Type: text/plain; charset=us-ascii
Content-Disposition: attachment; filename="ocaml_native_bt.patch"

---------------------------------------------------------------------------

              PATCH FOR NATIVE CODE FUNCTION BACKTRACES FOR OCAML

---------------------------------------------------------------------------

                                    LICENSE

Copyright (C) 2005
Jane Street Holding, LLC
Address: 111 Broadway, 21st Floor, 10006 New York, USA
Author: Markus Mottl <[email protected]>
All rights reserved.

This patch is based on a conceptual patch written in 2003 by Chris
Hecker <[email protected]>.  It has been completely rewritten to make it
thread-safe, more efficient, and better integrated with the OCaml-runtime.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:

    * Redistributions of source code must retain the above copyright
      notice, this list of conditions and the following disclaimer.

    * Neither the name of Jane Street Holding, LLC, nor the names of its
      contributors may be used to endorse or promote products derived
      from this patch without specific prior written permission.

THIS PATCH IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS
BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY,
OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
ARISING IN ANY WAY OUT OF THE USE OF THIS PATCH, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.

---------------------------------------------------------------------------

                               APPLYING THE PATCH

The patch was generated against the CVS-release of OCaml as of 2005-07-13,
but it can also be used with the source release of OCaml-3.08.3.  It may
also work with other releases.

To apply it just check out OCaml from the CVS-server at INRIA, or
download the source distribution, and change to the source directory.
DO NOT APPLY THIS PATCH YET!!!

First run "configure" with the arguments you want.  Then enter "make
world".  When the build process finishes it is time to apply the patch
as follows (in the source directory):

  patch -p0 < {path to this patch}/ocaml_native_bt.patch

Now enter "make all".  This build may end with the following error:

  Files main.cmo and ../stdlib/stdlib.cma(Printexc)
  make inconsistent assumptions over interface Printexc

If it does, just ignore the error.  In any case you should enter "make
bootstrap" now.  This last target should build without problems.

You can enter "make opt" and "make opt.opt" now to build the native
code compiler.

Finally, install OCaml with "make install", and you are done.

---------------------------------------------------------------------------

                                     USAGE

See file "stdlib/printexc.mli", section "Native function backtraces"
on how to compile your programs with debug information for native
function backtraces, how to turn on backtraces, and how to print/get
them at runtime.

New York, 2005-07-13
Markus Mottl
Jane Street Holding, LLC

===================================================================

Index: Makefile
===================================================================
RCS file: /caml/ocaml/Makefile,v
retrieving revision 1.196
diff -u -r1.196 Makefile
--- Makefile	31 May 2005 11:48:03 -0000	1.196
+++ Makefile	13 Jul 2005 16:39:22 -0000
@@ -71,7 +71,7 @@
 ASMCOMP=asmcomp/arch.cmo asmcomp/cmm.cmo asmcomp/printcmm.cmo \
   asmcomp/reg.cmo asmcomp/mach.cmo asmcomp/proc.cmo \
   asmcomp/clambda.cmo asmcomp/compilenv.cmo \
-  asmcomp/closure.cmo asmcomp/cmmgen.cmo \
+  asmcomp/closure.cmo asmcomp/cmmgen_bt.cmo asmcomp/cmmgen.cmo \
   asmcomp/printmach.cmo asmcomp/selectgen.cmo asmcomp/selection.cmo \
   asmcomp/comballoc.cmo asmcomp/liveness.cmo \
   asmcomp/spill.cmo asmcomp/split.cmo \
Index: Makefile.nt
===================================================================
RCS file: /caml/ocaml/Makefile.nt,v
retrieving revision 1.97
diff -u -r1.97 Makefile.nt
--- Makefile.nt	9 May 2005 13:39:17 -0000	1.97
+++ Makefile.nt	13 Jul 2005 16:39:22 -0000
@@ -67,7 +67,7 @@
 ASMCOMP=asmcomp/arch.cmo asmcomp/cmm.cmo asmcomp/printcmm.cmo \
   asmcomp/reg.cmo asmcomp/mach.cmo asmcomp/proc.cmo \
   asmcomp/clambda.cmo asmcomp/compilenv.cmo \
-  asmcomp/closure.cmo asmcomp/cmmgen.cmo \
+  asmcomp/closure.cmo asmcomp/cmmgen_bt.cmo asmcomp/cmmgen.cmo \
   asmcomp/printmach.cmo asmcomp/selectgen.cmo asmcomp/selection.cmo \
   asmcomp/comballoc.cmo asmcomp/liveness.cmo \
   asmcomp/spill.cmo asmcomp/split.cmo \
Index: asmcomp/cmmgen.ml
===================================================================
RCS file: /caml/ocaml/asmcomp/cmmgen.ml,v
retrieving revision 1.102
diff -u -r1.102 cmmgen.ml
--- asmcomp/cmmgen.ml	30 Nov 2004 07:28:00 -0000	1.102
+++ asmcomp/cmmgen.ml	13 Jul 2005 16:39:22 -0000
@@ -1500,9 +1500,13 @@
 (* Translate a function definition *)
 
 let transl_function lbl params body =
+  let fun_body =
+    if !Clflags.debug_native_backtrace then
+      Csequence (Cmmgen_bt.generate_bt lbl, transl body)
+    else transl body in
   Cfunction {fun_name = lbl;
              fun_args = List.map (fun id -> (id, typ_addr)) params;
-             fun_body = transl body;
+             fun_body = fun_body;
              fun_fast = !Clflags.optimize_for_speed}
 
 (* Translate all function definitions *)
@@ -1692,7 +1696,8 @@
         c := Cdata(emit_constant_closure symb fundecls []) :: !c)
     !constant_closures;
   constant_closures := [];
-  !c
+  if !Clflags.debug_native_backtrace then Cmmgen_bt.emit_instrumented_funs c
+  else !c
 
 (* Translate a compilation unit *)
 
@@ -1950,7 +1955,7 @@
   Cdata(Cglobal_symbol "caml_globals" ::
         Cdefine_symbol "caml_globals" ::
         List.map mksym namelist @
-        [cint_zero])
+        (cint_zero :: Cmmgen_bt.generate_defs !Clflags.debug_native_backtrace))
 
 let globals_map namelist =
   Cdata(Cglobal_symbol "caml_globals_map" ::
Index: asmcomp/cmmgen_bt.ml
===================================================================
RCS file: asmcomp/cmmgen_bt.ml
diff -N asmcomp/cmmgen_bt.ml
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ asmcomp/cmmgen_bt.ml	13 Jul 2005 16:39:22 -0000
@@ -0,0 +1,137 @@
+(* File: cmmgen_bt.ml
+
+   Completely rewritten by:
+
+     Copyright (C) 2005
+
+       Jane Street Holding, LLC
+       author: Markus Mottl
+       email: [email protected]
+       WWW: http://www.ocaml.info
+
+   Initial concept and implementation:
+
+     Copyright (C) 2003
+
+       Chris Hecker
+       email: [email protected]
+       WWW: http://www.d6.com/users/checker
+*)
+
+(* $Id$ *)
+
+(* Code generator for native function backtraces *)
+
+open Arch
+open Cmm
+
+let num_entries = 32  (* must be power of 2 *)
+let num_entries_name = "caml_native_bt_num_entries"
+let natint_num_entries = Nativeint.of_int num_entries
+let num_entries_mask = num_entries - 1
+let natint_num_entries_mask = Nativeint.of_int num_entries_mask
+let cconst_num_entries_mask = Cconst_natint natint_num_entries_mask
+
+let buf_name = "caml_native_bt_buf"
+let buf_sym = Cconst_symbol buf_name
+
+let buf_idx_name = "caml_native_bt_buf_idx"
+let buf_idx_sym = Cconst_symbol buf_idx_name
+
+let cconst_size_addr_lst = [Cconst_int size_addr]
+let cconst_one = Cconst_int 1
+let cconst_unit = cconst_one
+
+(* XXX: Duplicated from cmmgen.ml; should be factored out *)
+let emit_string_constant s cont =
+  let n = size_int - 1 - (String.length s) mod size_int in
+  Cstring s :: Cskip n :: Cint8 n :: cont
+
+let traced_funs = ref []
+let make_fun_name lbl = "caml_native_bt__" ^ lbl
+
+(* Emit the names of all traced functions as C-strings *)
+let emit_instrumented_funs c =
+  let cdata =
+    List.fold_left (fun syms lbl ->
+        Cdefine_symbol (make_fun_name lbl)
+        :: emit_string_constant (lbl ^ "\000") syms)
+      []
+      !traced_funs in
+  c := Cdata cdata :: !c;
+  traced_funs := [];
+  !c
+
+let get_buf_ofs idx = Cop (Cmuli, Cvar idx :: cconst_size_addr_lst)
+
+let incr_idx idx =
+  Cop (Cand, [Cop (Caddi, [Cvar idx; cconst_one]); cconst_num_entries_mask])
+
+let store_new buf idx cur_fun last_fun_ptr =
+  (* Increment index of ring buffer *)
+  Clet (
+    idx,
+    incr_idx idx,
+    (* Load pointer to name of new "last" function *)
+    Clet (
+      last_fun_ptr,
+      Cop (Cadda, [Cvar buf; get_buf_ofs idx]),
+        Csequence (
+          (* Store new buffer index *)
+          Cop (Cstore Word, [buf_idx_sym; Cvar idx]),
+          (* Store new function name *)
+          Cop (Cstore Word, [Cvar last_fun_ptr; Cvar cur_fun]))))
+
+(* Generate code for tracing native code functions *)
+let generate_bt lbl =
+  (* Remember name of traced function *)
+  traced_funs := lbl :: !traced_funs;
+  (* Load name of current function *)
+  let cur_fun = Ident.create "cur_fun" in
+  Clet (
+    cur_fun,
+    Cconst_symbol (make_fun_name lbl),
+    (* Load buffer *)
+    let buf = Ident.create "buf" in
+    Clet (
+      buf,
+      buf_sym,
+      (* Load buffer index *)
+      let idx = Ident.create "idx" in
+      Clet (
+        idx,
+        Cop (Cload Word, [buf_idx_sym]),
+        (* Load pointer to name of last function *)
+        let last_fun_ptr = Ident.create "last_fun_ptr" in
+        Clet (
+          last_fun_ptr,
+          Cop (Cadda, [Cvar buf; get_buf_ofs idx]),
+          (* Load name of last function *)
+          let last_fun = Ident.create "last_fun" in
+          Clet (
+            last_fun,
+            Cop (Cload Word, [Cvar last_fun_ptr]),
+            Cifthenelse (
+              (* If not same function,... *)
+              Cop (Ccmpa Cne, [Cvar cur_fun; Cvar last_fun]),
+              (* ..., then store new function, *)
+              store_new buf idx cur_fun last_fun_ptr,
+              (* ..., otherwise do nothing. *)
+              Ctuple []))))))
+
+let cint_zero = Cint 0n
+let buf_zeros = Array.to_list (Array.make num_entries cint_zero)
+let cint_natint_num_entries = Cint natint_num_entries 
+let cint_zero_lst = [cint_zero]
+
+(* Allocate backtrace variables and buffer *)
+let generate_defs with_bt =
+  Cglobal_symbol num_entries_name
+    :: Cdefine_symbol num_entries_name
+    :: (if with_bt then cint_natint_num_entries else cint_zero)
+    :: Cglobal_symbol buf_idx_name
+    :: Cdefine_symbol buf_idx_name
+    :: Cint natint_num_entries_mask
+    :: Cglobal_symbol buf_name
+    :: Cdefine_symbol buf_name
+    :: if with_bt then buf_zeros else cint_zero_lst
Index: asmrun/startup.c
===================================================================
RCS file: /caml/ocaml/asmrun/startup.c,v
retrieving revision 1.31
diff -u -r1.31 startup.c
--- asmrun/startup.c	24 Mar 2005 17:20:51 -0000	1.31
+++ asmrun/startup.c	13 Jul 2005 16:39:22 -0000
@@ -106,6 +106,7 @@
       case 'o': scanmult (opt, &percent_free_init); break;
       case 'O': scanmult (opt, &max_percent_free_init); break;
       case 'v': scanmult (opt, &caml_verb_gc); break;
+      case 'b': scanmult (opt, &caml_native_bt_activ); break;
       case 'p': caml_parser_trace = 1; break;
       }
     }
Index: byterun/Makefile
===================================================================
RCS file: /caml/ocaml/byterun/Makefile,v
retrieving revision 1.51
diff -u -r1.51 Makefile
--- byterun/Makefile	27 Nov 2004 01:03:40 -0000	1.51
+++ byterun/Makefile	13 Jul 2005 16:39:22 -0000
@@ -31,8 +31,8 @@
 
 PRIMS=alloc.c array.c compare.c extern.c floats.c gc_ctrl.c hash.c \
   intern.c interp.c ints.c io.c lexing.c md5.c meta.c obj.c parsing.c \
-  signals.c str.c sys.c terminfo.c callback.c weak.c finalise.c stacks.c \
-  dynlink.c
+  signals.c printexc.c str.c sys.c terminfo.c callback.c weak.c finalise.c \
+  stacks.c dynlink.c
 
 PUBLIC_INCLUDES=alloc.h callback.h config.h custom.h fail.h intext.h \
   memory.h misc.h mlvalues.h printexc.h signals.h compatibility.h
Index: byterun/printexc.c
===================================================================
RCS file: /caml/ocaml/byterun/printexc.c,v
retrieving revision 1.16
diff -u -r1.16 printexc.c
--- byterun/printexc.c	8 Jan 2004 22:28:48 -0000	1.16
+++ byterun/printexc.c	13 Jul 2005 16:39:22 -0000
@@ -24,6 +24,8 @@
 #include "fail.h"
 #include "misc.h"
 #include "mlvalues.h"
+#include "memory.h"
+#include "alloc.h"
 #include "printexc.h"
 
 struct stringbuf {
@@ -93,6 +95,79 @@
 }
 
 
+/* Native function backtraces */
+
+unsigned long caml_native_bt_activ = 0;
+
+#ifdef NATIVE_CODE
+extern unsigned long caml_native_bt_buf_idx;
+extern unsigned long caml_native_bt_num_entries;
+extern char *caml_native_bt_buf[];
+#endif
+
+CAMLprim value caml_print_native_backtrace(value unit)
+{
+#ifdef NATIVE_CODE
+  int i;
+  char *last_fun;
+
+  if (!caml_native_bt_activ) return Val_unit;
+
+  last_fun =
+    (caml_native_bt_num_entries == 0)
+      ? NULL : caml_native_bt_buf[caml_native_bt_buf_idx];
+
+  if (last_fun == NULL) {
+    fprintf(stderr, "Native function backtrace empty.\n");
+    return Val_unit;
+  }
+
+  fprintf(stderr, "Native function backtrace:\n\n  %s\n", last_fun);
+
+  for (i = caml_native_bt_buf_idx - 1; i >= 0; --i) {
+    if (!caml_native_bt_buf[i]) goto end;
+    fprintf(stderr, "  %s\n", caml_native_bt_buf[i]);
+  }
+  for (i = caml_native_bt_num_entries - 1; i > caml_native_bt_buf_idx; --i) {
+    if (!caml_native_bt_buf[i]) goto end;
+    fprintf(stderr, "  %s\n", caml_native_bt_buf[i]);
+  }
+
+end:
+  fflush(stderr);
+#endif
+  return Val_unit;
+}
+
+CAMLprim value caml_get_native_backtrace(value unit)
+{
+#ifdef NATIVE_CODE
+  if (!(caml_native_bt_activ && caml_native_bt_buf[0])) return Atom(0);
+
+  CAMLparam0();
+  CAMLlocal1(v_res);
+
+  int i,
+      lix = caml_native_bt_num_entries - 1,
+      res_pos = 0,
+      res_len =
+        caml_native_bt_buf[lix]
+          ? caml_native_bt_num_entries : caml_native_bt_buf_idx + 1;
+
+  v_res = caml_alloc(res_len, 0);
+
+  for (i = caml_native_bt_buf_idx; i >= 0 && res_pos < res_len; --i)
+    Store_field(v_res, res_pos++, caml_copy_string(caml_native_bt_buf[i]));
+  for (i = lix; i > caml_native_bt_buf_idx && res_pos < res_len; --i)
+    Store_field(v_res, res_pos++, caml_copy_string(caml_native_bt_buf[i]));
+
+  CAMLreturn(v_res);
+#else
+  return Atom(0);
+#endif
+}
+
+
 void caml_fatal_uncaught_exception(value exn)
 {
   char * msg;
@@ -118,8 +193,11 @@
   /* Display the uncaught exception */
   fprintf(stderr, "Fatal error: exception %s\n", msg);
   free(msg);
+#ifdef NATIVE_CODE
+  /* Native function backtraces */
+  if (caml_native_bt_activ) caml_print_native_backtrace(Val_unit);
+#else
   /* Display the backtrace if available */
-#ifndef NATIVE_CODE
   if (caml_backtrace_active && !caml_debugger_in_use){
     caml_print_exception_backtrace();
   }
Index: byterun/printexc.h
===================================================================
RCS file: /caml/ocaml/byterun/printexc.h,v
retrieving revision 1.5
diff -u -r1.5 printexc.h
--- byterun/printexc.h	1 Jan 2004 16:42:37 -0000	1.5
+++ byterun/printexc.h	13 Jul 2005 16:39:22 -0000
@@ -23,5 +23,8 @@
 CAMLextern char * caml_format_exception (value);
 void caml_fatal_uncaught_exception (value) Noreturn;
 
+/* Native function backtraces */
+
+extern unsigned long caml_native_bt_activ;
 
 #endif /* CAML_PRINTEXC_H */
Index: driver/optmain.ml
===================================================================
RCS file: /caml/ocaml/driver/optmain.ml,v
retrieving revision 1.85
diff -u -r1.85 optmain.ml
--- driver/optmain.ml	9 May 2005 13:39:17 -0000	1.85
+++ driver/optmain.ml	13 Jul 2005 16:39:22 -0000
@@ -111,6 +111,8 @@
              " print configuration values and exit";
        "-dtypes", Arg.Set save_types,
              " Save type information in <filename>.annot";
+       "-gb", Arg.Set debug_native_backtrace,
+              " generate debugging information for native code backtraces";
        "-i", Arg.Unit (fun () -> print_types := true; compile_only := true),
              " Print inferred interface";
        "-I", Arg.String(fun dir -> include_dirs := dir :: !include_dirs),
Index: otherlibs/systhreads/posix.c
===================================================================
RCS file: /caml/ocaml/otherlibs/systhreads/posix.c,v
retrieving revision 1.50
diff -u -r1.50 posix.c
--- otherlibs/systhreads/posix.c	13 Jul 2004 12:25:13 -0000	1.50
+++ otherlibs/systhreads/posix.c	13 Jul 2005 16:39:23 -0000
@@ -48,6 +48,15 @@
 #endif
 #include "sys.h"
 
+#ifdef NATIVE_CODE
+/* Native function backtraces */
+extern unsigned long caml_native_bt_activ;
+extern unsigned long caml_native_bt_buf_idx;
+extern unsigned long caml_native_bt_num_entries;
+extern char *caml_native_bt_buf[];
+extern CAMLprim value caml_print_native_backtrace(value unit);
+#endif
+
 /* Initial size of stack when a thread is created (4 Ko) */
 #define Thread_stack_size (Stack_size / 4)
 
@@ -80,6 +89,9 @@
   char * exception_pointer;     /* Saved value of caml_exception_pointer */
   struct caml__roots_block * local_roots; /* Saved value of local_roots */
   struct longjmp_buffer * exit_buf; /* For thread exit */
+  /* Native function backtraces */
+  unsigned long native_bt_idx;
+  char *(*native_bt_buf_ptr)[];
 #else
   value * stack_low;            /* The execution stack for this thread */
   value * stack_high;
@@ -96,6 +108,30 @@
 
 typedef struct caml_thread_struct * caml_thread_t;
 
+#ifdef NATIVE_CODE
+/* Native function backtraces */
+static inline void malloc_native_bt_buf(caml_thread_t th)
+{
+  if (caml_native_bt_activ) {
+    char *(*native_bt_buf_ptr)[] =
+      malloc(caml_native_bt_num_entries * sizeof(char**));
+    if (native_bt_buf_ptr == NULL) caml_raise_out_of_memory();
+    th->native_bt_buf_ptr = native_bt_buf_ptr;
+  }
+}
+
+static inline void calloc_native_bt_buf(caml_thread_t th)
+{
+  if (caml_native_bt_activ) {
+    char *(*native_bt_buf_ptr)[] =
+      calloc(caml_native_bt_num_entries, sizeof(char**));
+    if (native_bt_buf_ptr == NULL) caml_raise_out_of_memory();
+    th->native_bt_buf_ptr = native_bt_buf_ptr;
+    th->native_bt_idx = 0;
+  }
+}
+#endif
+
 /* The descriptor for the currently executing thread */
 static caml_thread_t curr_thread = NULL;
 
@@ -183,6 +219,14 @@
   curr_thread->gc_regs = caml_gc_regs;
   curr_thread->exception_pointer = caml_exception_pointer;
   curr_thread->local_roots = local_roots;
+  /* Native function backtraces */
+  if (caml_native_bt_activ) {
+    int i;
+    curr_thread->native_bt_idx = caml_native_bt_buf_idx;
+    char **native_bt_buf = *(curr_thread->native_bt_buf_ptr);
+    for (i = 0; i < caml_native_bt_num_entries; ++i)
+      native_bt_buf[i] = caml_native_bt_buf[i];
+  }
 #else
   curr_thread->stack_low = stack_low;
   curr_thread->stack_high = stack_high;
@@ -223,6 +267,14 @@
   caml_gc_regs = curr_thread->gc_regs;
   caml_exception_pointer = curr_thread->exception_pointer;
   local_roots = curr_thread->local_roots;
+  /* Native function backtraces */
+  if (caml_native_bt_activ) {
+    int i;
+    caml_native_bt_buf_idx = curr_thread->native_bt_idx;
+    char **native_bt_buf = *(curr_thread->native_bt_buf_ptr);
+    for (i = 0; i < caml_native_bt_num_entries; ++i)
+      caml_native_bt_buf[i] = native_bt_buf[i];
+  }
 #else
   stack_low = curr_thread->stack_low;
   stack_high = curr_thread->stack_high;
@@ -359,6 +411,8 @@
     curr_thread->prev = curr_thread;
 #ifdef NATIVE_CODE
     curr_thread->exit_buf = &caml_termination_jmpbuf;
+    /* Native function backtraces */
+    malloc_native_bt_buf(curr_thread);
 #endif
     /* The stack-related fields will be filled in at the next
        enter_blocking_section */
@@ -405,7 +459,9 @@
   caml_runtime_busy = 0;
   pthread_mutex_unlock(&caml_runtime_mutex);
   pthread_cond_signal(&caml_runtime_is_free);
-#ifndef NATIVE_CODE
+#ifdef NATIVE_CODE
+  if (caml_native_bt_activ) free(th->native_bt_buf_ptr);
+#else
   /* Free the memory resources */
   stat_free(th->stack_low);
   if (th->backtrace_buffer != NULL) free(th->backtrace_buffer);
@@ -469,6 +525,8 @@
     th->bottom_of_stack = NULL;
     th->exception_pointer = NULL;
     th->local_roots = NULL;
+    /* Native function backtraces */
+    calloc_native_bt_buf(th);
 #else
     /* Allocate the stacks */
     th->stack_low = (value *) stat_alloc(Thread_stack_size);
@@ -495,7 +553,10 @@
       /* Fork failed, remove thread info block from list of threads */
       th->next->prev = curr_thread;
       curr_thread->next = th->next;
-#ifndef NATIVE_CODE
+#ifdef NATIVE_CODE
+      /* Native function backtraces */
+      if (caml_native_bt_activ) free(th->native_bt_buf_ptr);
+#else
       stat_free(th->stack_low);
 #endif
       stat_free(th);
@@ -528,7 +589,10 @@
   fprintf(stderr, "Thread %d killed on uncaught exception %s\n",
           Int_val(Ident(curr_thread->descr)), msg);
   free(msg);
-#ifndef NATIVE_CODE
+#ifdef NATIVE_CODE
+  /* Native function backtraces */
+  if (caml_native_bt_activ) caml_print_native_backtrace(Val_unit);
+#else
   if (backtrace_active) print_exception_backtrace();
 #endif
   fflush(stderr);
Index: stdlib/printexc.ml
===================================================================
RCS file: /caml/ocaml/stdlib/printexc.ml,v
retrieving revision 1.18
diff -u -r1.18 printexc.ml
--- stdlib/printexc.ml	16 Jan 2004 15:24:02 -0000	1.18
+++ stdlib/printexc.ml	13 Jul 2005 16:39:23 -0000
@@ -68,3 +68,12 @@
     flush stdout;
     eprintf "Uncaught exception: %s\n" (to_string x);
     exit 2
+
+
+(* Native function backtraces *)
+
+external print_native_backtrace :
+  unit -> unit = "caml_print_native_backtrace" "noalloc"
+
+external get_native_backtrace :
+  unit -> string array = "caml_get_native_backtrace"
Index: stdlib/printexc.mli
===================================================================
RCS file: /caml/ocaml/stdlib/printexc.mli,v
retrieving revision 1.11
diff -u -r1.11 printexc.mli
--- stdlib/printexc.mli	7 Dec 2001 13:40:57 -0000	1.11
+++ stdlib/printexc.mli	13 Jul 2005 16:39:23 -0000
@@ -37,3 +37,34 @@
    using the debugger or the stack backtrace facility.
    So, do not use [Printexc.catch] in new code.  *)
 
+
+(** {6 Native function backtraces}
+
+    To turn on native function backtraces, the environment variable
+    OCAMLRUNPARAM must contain a non-zero setting for parameter "b".
+
+    Only non-inlined functions in modules compiled to native code with
+    "-gb" will be traced, other functions do not appear in backtraces.
+
+    In multi-threaded programs each thread maintains its own backtrace.
+
+    Only the last 32 called functions (assembler symbols; includes
+    anonymous functions) will be printed/returned in reverse order of
+    execution (i.e. last called function first).
+
+    If a function calls itself recursively and directly, it will only
+    appear once in backtraces to prevent it from wiping out its history.
+*)
+
+external print_native_backtrace :
+  unit -> unit = "caml_print_native_backtrace" "noalloc"
+(** [print_native_backtrace ()] prints a native function backtrace to
+    [stderr].  Does nothing when executed from byte code, or when native
+    function backtraces have not been turned on. *)
+
+external get_native_backtrace :
+  unit -> string array = "caml_get_native_backtrace"
+(** [get_native_backtrace ()] returns a native function backtrace as
+    array of function names.  Returns the empty array when executed from
+    byte code, or when native function backtraces have not been turned
+    on, or when no function has been traced yet. *)
Index: utils/clflags.ml
===================================================================
RCS file: /caml/ocaml/utils/clflags.ml,v
retrieving revision 1.48
diff -u -r1.48 clflags.ml
--- utils/clflags.ml	28 Jan 2005 17:52:58 -0000	1.48
+++ utils/clflags.ml	13 Jul 2005 16:39:23 -0000
@@ -25,6 +25,7 @@
 and print_types = ref false             (* -i *)
 and make_archive = ref false            (* -a *)
 and debug = ref false                   (* -g *)
+and debug_native_backtrace = ref false  (* -gb *)
 and fast = ref false                    (* -unsafe *)
 and link_everything = ref false         (* -linkall *)
 and custom_runtime = ref false          (* -custom *)

--x+6KMIRAuhnl3hBn
Content-Type: text/plain; charset="us-ascii"
MIME-Version: 1.0
Content-Transfer-Encoding: 7bit
Content-Disposition: inline

_______________________________________________
Caml-announce mailing list
[email protected]
http://yquem.inria.fr/cgi-bin/mailman/listinfo/caml-announce

--x+6KMIRAuhnl3hBn--