Another great advantage for OCaml language due to Markus Mottl

* Another great advantage for OCaml language due to Markus Mottl
@ 2006-03-21 13:44 Andries Hekstra
  2006-03-21 14:45 ` Markus Mottl
  2006-03-21 16:23 ` [Caml-list] " Mike Lin
  0 siblings, 2 replies; 4+ messages in thread
From: Andries Hekstra @ 2006-03-21 13:44 UTC (permalink / raw)
  To: caml-list; +Cc: markus.mottl


[-- Attachment #1.1: Type: text/plain, Size: 1897 bytes --]

Dear Member of the OCaml mailing list,

The problem about which I reported on this reflector around two weeks ago 
(array index violation after around 4 days) has in the mean time been 
solved thanks to the great native function call backtrace for the ocamlopt 
compiler due to Markus Mottl. Given that my program crashed after 3.7 
days, and my program ran around 30x slower in byte code, debugging using 
byte code was not an option (this slowdown had been similar if I had used 
_DEBUG mode of a C++ program instead of _RELEASE version). Also, as 
reported earlier, putting "try ... with " around all attempts to index an 
array is not feasbile in standard OCaml for array elements in the left 
hand sides of assignments. A static unhandled exception checker provided 
on a web page, ran into dead HTML links. 

Hence, the native function call, which comes at minimal runtime overhead 
cost, mainly the cost of -inline 0, is a great new feature that would give 
OCaml another advantage over C++ when added to the OCaml language in a 
next release. Below I give a toy example :

--- nlv13512/TestProgram ---> ls
attempt.ml*
--- nlv13512/TestProgram ---> cat att*
let a = Array.make 2 0;; 
let f i = i*i;; 
let g i = a.(i);; 
let b = f 2;;
let c = g 2;; 
--- nlv13512/TestProgram ---> ocamlopt -inline 0 -gb attempt.ml
--- nlv13512/TestProgram ---> a.out
Fatal error: exception Invalid_argument("index out of bounds")
Native function backtrace:

  camlAttempt__g_60
  camlAttempt__f_58
--- nlv13512/TestProgram ---> 

=Andries

PS The attached patch was provided to me by Markus Mottl for the 3.09.1. 
release. 




------------------------------------------------------------------------
Dr. Ir. Andries P. Hekstra
Philips Research 
High Tech Campus 27  (WL-1-4.15)
5656 AG Eindhoven
Tel./Fax/Secr. +31 40 27 42048/42566/44051 
   *  Good open source anti-RSI software : http://www.workrave.org 

[-- Attachment #1.2: Type: text/html, Size: 2897 bytes --]

[-- Attachment #2: ocaml_native_bt.patch --]
[-- Type: application/octet-stream, Size: 25880 bytes --]

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

              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 <markus.mottl@gmail.com>
All rights reserved.

This patch is based on a conceptual patch written in 2003 by Chris
Hecker <checker@d6.com>.  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-11-18,
but it can also be used with the source release of OCaml-3.09.0.  It may
also work with other releases >= OCaml-3.09.0.

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 should end with the following error:

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

Just ignore this error.  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-11-18
Markus Mottl
Jane Street Holding, LLC

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

Index: Makefile
===================================================================
RCS file: /caml/ocaml/Makefile,v
retrieving revision 1.199
diff -u -r1.199 Makefile
--- Makefile	24 Sep 2005 16:20:36 -0000	1.199
+++ Makefile	7 Mar 2006 21:39:48 -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.98
diff -u -r1.98 Makefile.nt
--- Makefile.nt	24 Sep 2005 16:20:36 -0000	1.98
+++ Makefile.nt	7 Mar 2006 21:39:48 -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.105
diff -u -r1.105 cmmgen.ml
--- asmcomp/cmmgen.ml	27 Jan 2006 14:33:42 -0000	1.105
+++ asmcomp/cmmgen.ml	7 Mar 2006 21:39:48 -0000
@@ -1497,9 +1497,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 *)
@@ -1689,7 +1693,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 *)
 
@@ -1947,7 +1952,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	7 Mar 2006 21:39:48 -0000
@@ -0,0 +1,137 @@
+(* File: cmmgen_bt.ml
+
+   Completely rewritten by:
+
+     Copyright (C) 2005
+
+       Jane Street Holding, LLC
+       author: Markus Mottl
+       email: markus.mottl@gmail.com
+       WWW: http://www.ocaml.info
+
+   Initial concept and implementation:
+
+     Copyright (C) 2003
+
+       Chris Hecker
+       email: checker@d6.com
+       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.32
diff -u -r1.32 startup.c
--- asmrun/startup.c	22 Sep 2005 14:21:47 -0000	1.32
+++ asmrun/startup.c	7 Mar 2006 21:39:48 -0000
@@ -110,6 +110,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.53
diff -u -r1.53 Makefile
--- byterun/Makefile	4 Jan 2006 16:55:49 -0000	1.53
+++ byterun/Makefile	7 Mar 2006 21:39:48 -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	7 Mar 2006 21:39:48 -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	7 Mar 2006 21:39:48 -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.87
diff -u -r1.87 optmain.ml
--- driver/optmain.ml	4 Jan 2006 16:55:49 -0000	1.87
+++ driver/optmain.ml	7 Mar 2006 21:39:48 -0000
@@ -114,6 +114,8 @@
        "-for-pack", Arg.String (fun s -> for_package := Some s),
              "<ident>  Generate code that can later be `packed' with\n\
          \     ocamlopt -pack -o <ident>.cmx";
+       "-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.53
diff -u -r1.53 posix.c
--- otherlibs/systhreads/posix.c	22 Sep 2005 14:21:50 -0000	1.53
+++ otherlibs/systhreads/posix.c	7 Mar 2006 21:39:48 -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;
 
@@ -178,6 +214,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;
@@ -218,6 +262,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;
@@ -361,6 +413,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	7 Mar 2006 21:39:48 -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.12
diff -u -r1.12 printexc.mli
--- stdlib/printexc.mli	25 Oct 2005 18:34:07 -0000	1.12
+++ stdlib/printexc.mli	7 Mar 2006 21:39:48 -0000
@@ -36,3 +36,35 @@
    makes it harder to track the location of the exception
    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.49
diff -u -r1.49 clflags.ml
--- utils/clflags.ml	1 Aug 2005 15:51:09 -0000	1.49
+++ utils/clflags.ml	7 Mar 2006 21:39:48 -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 *)
Index: utils/clflags.mli
===================================================================
RCS file: /caml/ocaml/utils/clflags.mli,v
retrieving revision 1.1
diff -u -r1.1 clflags.mli
--- utils/clflags.mli	26 Oct 2005 13:23:27 -0000	1.1
+++ utils/clflags.mli	7 Mar 2006 21:39:48 -0000
@@ -22,6 +22,7 @@
 val print_types : bool ref
 val make_archive : bool ref
 val debug : bool ref
+val debug_native_backtrace : bool ref
 val fast : bool ref
 val link_everything : bool ref
 val custom_runtime : bool ref


^ permalink raw reply	[flat|nested] 4+ messages in thread