Permalink
Switch branches/tags
Nothing to show
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
807 lines (762 sloc) 26.2 KB
diff --git a/.depend b/.depend
index dee02ef..fd01a87 100644
--- a/.depend
+++ b/.depend
@@ -274,6 +274,7 @@ bytecomp/lambda.cmi: typing/types.cmi typing/primitive.cmi typing/path.cmi \
parsing/location.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi
bytecomp/matching.cmi: typing/typedtree.cmi parsing/location.cmi \
bytecomp/lambda.cmi typing/ident.cmi parsing/asttypes.cmi
+bytecomp/meta.cmi: bytecomp/instruct.cmi
bytecomp/printinstr.cmi: bytecomp/instruct.cmi
bytecomp/printlambda.cmi: bytecomp/lambda.cmi
bytecomp/simplif.cmi: bytecomp/lambda.cmi
@@ -356,8 +357,8 @@ bytecomp/matching.cmx: typing/types.cmx bytecomp/typeopt.cmx \
typing/primitive.cmx typing/predef.cmx typing/parmatch.cmx utils/misc.cmx \
parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx \
typing/btype.cmx parsing/asttypes.cmi bytecomp/matching.cmi
-bytecomp/meta.cmo: bytecomp/meta.cmi
-bytecomp/meta.cmx: bytecomp/meta.cmi
+bytecomp/meta.cmo: bytecomp/instruct.cmi bytecomp/meta.cmi
+bytecomp/meta.cmx: bytecomp/instruct.cmx bytecomp/meta.cmi
bytecomp/printinstr.cmo: bytecomp/printlambda.cmi parsing/location.cmi \
bytecomp/lambda.cmi bytecomp/instruct.cmi typing/ident.cmi \
bytecomp/printinstr.cmi
diff --git a/Makefile b/Makefile
index a3da5f2..f014739 100644
--- a/Makefile
+++ b/Makefile
@@ -19,8 +19,8 @@ include stdlib/StdlibModules
CAMLC=boot/ocamlrun boot/ocamlc -nostdlib -I boot
CAMLOPT=boot/ocamlrun ./ocamlopt -nostdlib -I stdlib
-COMPFLAGS=-warn-error A $(INCLUDES)
-LINKFLAGS=
+COMPFLAGS=-g -warn-error A $(INCLUDES)
+LINKFLAGS=-g
CAMLYACC=boot/ocamlyacc
YACCFLAGS=-v
diff --git a/asmrun/backtrace.c b/asmrun/backtrace.c
index 07d7f6f..3bf17a8 100644
--- a/asmrun/backtrace.c
+++ b/asmrun/backtrace.c
@@ -97,7 +97,7 @@ void caml_stash_backtrace(value exn, uintnat pc, char * sp, char * trapsp)
/* Print a backtrace */
-static void print_location(int index, frame_descr * d)
+static int snprint_location(char *s, int len, int index, frame_descr * d)
{
uintnat infoptr;
uint32 info1, info2, k, n, l, a, b;
@@ -106,7 +106,7 @@ static void print_location(int index, frame_descr * d)
/* If no debugging information available, print nothing.
When everything is compiled with -g, this corresponds to
compiler-inserted re-raise operations. */
- if ((d->frame_size & 1) == 0) return;
+ if ((d->frame_size & 1) == 0) return 0;
/* Recover debugging info */
infoptr = ((uintnat) d +
sizeof(char *) + sizeof(short) + sizeof(short) +
@@ -136,14 +136,65 @@ static void print_location(int index, frame_descr * d)
else
kind = "Called from";
- fprintf(stderr, "%s file \"%s\", line %d, characters %d-%d\n",
- kind, ((char *) infoptr) + n, l, a, b);
+ char *fmt = "%s file \"%s\", line %d, characters %d-%d\n";
+ if (s)
+ return snprintf(s, len, fmt, kind, ((char *) infoptr) + n, l, a, b);
+ else {
+ fprintf(stderr, fmt, kind, ((char *) infoptr) + n, l, a, b);
+ return 0;
+ }
}
-void caml_print_exception_backtrace(void)
+static int snprint_exception_backtrace(char *s, int len)
{
int i;
+ int total_chars = 0;
for (i = 0; i < caml_backtrace_pos; i++)
- print_location(i, (frame_descr *) caml_backtrace_buffer[i]);
+ {
+ int chars = snprint_location(s, len, i, (frame_descr *) caml_backtrace_buffer[i]);
+ total_chars += chars;
+ s += chars;
+ len -= chars;
+ }
+ return total_chars;
+}
+
+void caml_print_exception_backtrace(void)
+{
+ snprint_exception_backtrace(0, 0);
+}
+
+CAMLprim value caml_sprint_backtrace(value sv)
+{
+ if (caml_backtrace_active)
+ {
+ int len = caml_string_length(sv);
+ char *s = String_val(sv);
+ int chars = snprint_exception_backtrace(s, len);
+ return Val_int(chars);
+ }
+ else
+ return Val_int(0);
+}
+
+CAMLprim value caml_capture_backtrace(value on)
+{
+ if (Bool_val(on))
+ {
+ caml_backtrace_active = 1;
+ caml_register_global_root(&caml_backtrace_last_exn);
+ }
+ else
+ {
+ caml_backtrace_active = 0;
+ caml_remove_global_root(&caml_backtrace_last_exn);
+ caml_backtrace_last_exn = Val_unit;
+ }
+ return Val_unit;
+}
+
+CAMLprim value caml_backtrace_captured(value unit)
+{
+ return caml_backtrace_active ? Val_true : Val_false;
}
diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml
index 0201ba6..576e530 100644
--- a/bytecomp/emitcode.ml
+++ b/bytecomp/emitcode.ml
@@ -395,8 +395,9 @@ let to_memory init_code fun_code =
String.unsafe_blit !out_buffer 0 code 0 !out_position;
let reloc = List.rev !reloc_info
and code_size = !out_position in
+ let events = !events in
init();
- (code, code_size, reloc)
+ (code, code_size, reloc, events)
(* Emission to a file for a packed library *)
diff --git a/bytecomp/emitcode.mli b/bytecomp/emitcode.mli
index 5a09293..742009c 100644
--- a/bytecomp/emitcode.mli
+++ b/bytecomp/emitcode.mli
@@ -23,7 +23,7 @@ val to_file: out_channel -> string -> instruction list -> unit
name of compilation unit implemented
list of instructions to emit *)
val to_memory: instruction list -> instruction list ->
- string * int * (reloc_info * int) list
+ string * int * (reloc_info * int) list * debug_event list
(* Arguments:
initialization code (terminated by STOP)
function code
diff --git a/bytecomp/meta.ml b/bytecomp/meta.ml
index 08cf707..1109b52 100644
--- a/bytecomp/meta.ml
+++ b/bytecomp/meta.ml
@@ -24,3 +24,6 @@ external invoke_traced_function : Obj.t -> Obj.t -> Obj.t -> Obj.t
= "caml_invoke_traced_function"
external get_section_table : unit -> (string * Obj.t) list
= "caml_get_section_table"
+
+external add_debug_info : string -> int -> Instruct.debug_event list array -> unit = "caml_add_debug_info"
+external remove_debug_info : string -> unit = "caml_remove_debug_info"
diff --git a/byterun/Makefile b/byterun/Makefile
index e76fab3..e7e4b64 100644
--- a/byterun/Makefile
+++ b/byterun/Makefile
@@ -29,7 +29,7 @@ OBJS=interp.o misc.o stacks.o fix_code.o startup.o main.o \
DOBJS=$(OBJS:.o=.d.o) instrtrace.d.o
-PRIMS=alloc.c array.c compare.c extern.c floats.c gc_ctrl.c hash.c \
+PRIMS=alloc.c array.c backtrace.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
diff --git a/byterun/backtrace.c b/byterun/backtrace.c
index dd35361..294f7d6 100644
--- a/byterun/backtrace.c
+++ b/byterun/backtrace.c
@@ -38,6 +38,7 @@ CAMLexport int caml_backtrace_active = 0;
CAMLexport int caml_backtrace_pos = 0;
CAMLexport code_t * caml_backtrace_buffer = NULL;
CAMLexport value caml_backtrace_last_exn = Val_unit;
+CAMLexport value caml_debug_info = Val_emptylist;
#define BACKTRACE_BUFFER_SIZE 1024
/* Location of fields in the Instruct.debug_event record */
@@ -59,6 +60,49 @@ enum {
POS_CNUM = 3
};
+/* Location of fields in the caml_debug_info records */;
+enum {
+ DI_START = 0,
+ DI_SIZE = 1,
+ DI_EVENTS = 2
+};
+
+CAMLprim value caml_add_debug_info(code_t start, value size, value events)
+{
+ CAMLparam1(events);
+ CAMLlocal1(debug_info);
+ debug_info = caml_alloc(3, 0);
+ Store_field(debug_info, DI_START, (value)start);
+ Store_field(debug_info, DI_SIZE, size);
+ Store_field(debug_info, DI_EVENTS, events);
+ value cons = caml_alloc(2, 0);
+ Store_field(cons, 0, debug_info);
+ Store_field(cons, 1, caml_debug_info);
+ caml_debug_info = cons;
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value caml_remove_debug_info(code_t start)
+{
+ CAMLparam0();
+ value dis = caml_debug_info;
+ value prev = 0;
+ while (dis != Val_emptylist) {
+ value di = Field(dis, 0);
+ code_t di_start = (code_t)Field(di, DI_START);
+ if (di_start == start) {
+ if (prev)
+ Store_field(prev, 1, Field(dis, 1));
+ else
+ caml_debug_info = Field(dis, 1);
+ break;
+ }
+ prev = di;
+ dis = Field(dis, 1);
+ }
+ CAMLreturn(Val_unit);
+}
+
/* Initialize the backtrace machinery */
void caml_init_backtrace(void)
@@ -74,7 +118,6 @@ void caml_init_backtrace(void)
void caml_stash_backtrace(value exn, code_t pc, value * sp)
{
- 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) {
caml_backtrace_pos = 0;
@@ -85,14 +128,30 @@ void caml_stash_backtrace(value exn, code_t pc, value * sp)
if (caml_backtrace_buffer == NULL) return;
}
if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) return;
- if (pc >= caml_start_code && pc < end_code){
- caml_backtrace_buffer[caml_backtrace_pos++] = pc;
+ value dis = caml_debug_info;
+ while (dis != Val_emptylist) {
+ value di = Field(dis, 0);
+ code_t start = (code_t)Field(di, DI_START);
+ code_t end = (code_t) ((char *) start + Int_val(Field(di, DI_SIZE)));
+ if (pc >= start && pc < end){
+ caml_backtrace_buffer[caml_backtrace_pos++] = pc;
+ break;
+ }
+ dis = Field(dis, 1);
}
for (/*nothing*/; sp < caml_trapsp; sp++) {
+ if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) break;
code_t p = (code_t) *sp;
- if (p >= caml_start_code && p < end_code) {
- if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) break;
+ value dis = caml_debug_info;
+ while (dis != Val_emptylist) {
+ value di = Field(dis, 0);
+ code_t start = (code_t)Field(di, DI_START);
+ code_t end = (code_t) ((char *) start + Int_val(Field(di, DI_SIZE)));
+ if (p >= start && p < end) {
caml_backtrace_buffer[caml_backtrace_pos++] = p;
+ break;
+ }
+ dis = Field(dis, 1);
}
}
}
@@ -105,79 +164,87 @@ void caml_stash_backtrace(value exn, code_t pc, value * sp)
#define O_BINARY 0
#endif
-static value read_debug_info(void)
+CAMLexport void caml_read_debug_info(int fd, struct exec_trailer *trail)
{
CAMLparam0();
CAMLlocal1(events);
- char * exec_name;
- int fd;
- struct exec_trailer trail;
struct channel * chan;
uint32 num_events, orig, i;
value evl, l;
- exec_name = caml_exe_name;
- fd = caml_attempt_open(&exec_name, &trail, 1);
- if (fd < 0) CAMLreturn(Val_false);
- caml_read_section_descriptors(fd, &trail);
- if (caml_seek_optional_section(fd, &trail, "DBUG") == -1) {
- close(fd);
- CAMLreturn(Val_false);
- }
- chan = caml_open_descriptor_in(fd);
- num_events = caml_getword(chan);
- events = caml_alloc(num_events, 0);
- for (i = 0; i < num_events; i++) {
- orig = caml_getword(chan);
- evl = caml_input_val(chan);
- /* Relocate events in event list */
- for (l = evl; l != Val_int(0); l = Field(l, 1)) {
+ caml_register_global_root(&caml_debug_info);
+
+ if (caml_seek_optional_section(fd, trail, "DBUG") == -1)
+ events = caml_alloc(0, 0);
+
+ else {
+ chan = caml_open_descriptor_in(fd);
+ num_events = caml_getword(chan);
+ events = caml_alloc(num_events, 0);
+ for (i = 0; i < num_events; i++) {
+ orig = caml_getword(chan);
+ evl = caml_input_val_(chan, 1);
+ /* Relocate events in event list */
+ for (l = evl; l != Val_int(0); l = Field(l, 1)) {
value ev = Field(l, 0);
Field(ev, EV_POS) = Val_long(Long_val(Field(ev, EV_POS)) + orig);
+ }
+ /* Record event list */
+ Store_field(events, i, evl);
}
- /* Record event list */
- Store_field(events, i, evl);
+ caml_release_channel(chan);
}
- caml_close_channel(chan);
- CAMLreturn(events);
+
+ caml_add_debug_info(caml_start_code, Val_int(caml_code_size), events);
+ CAMLreturn0;
}
/* Search the event for the given PC. Return Val_false if not found. */
-static value event_for_location(value events, code_t pc)
+static value event_for_location(code_t pc)
{
mlsize_t i;
value pos, l, ev, ev_pos, best_ev;
best_ev = 0;
- Assert(pc >= caml_start_code && pc < caml_start_code + caml_code_size);
- pos = Val_long((char *) pc - (char *) caml_start_code);
- for (i = 0; i < Wosize_val(events); i++) {
- for (l = Field(events, i); l != Val_int(0); l = Field(l, 1)) {
- ev = Field(l, 0);
- ev_pos = Field(ev, EV_POS);
- if (ev_pos == pos) return ev;
- /* ocamlc sometimes moves an event past a following PUSH instruction;
- allow mismatch by 1 instruction. */
- if (ev_pos == pos + 8) best_ev = ev;
+ value dis = caml_debug_info;
+ while (dis != Val_emptylist) {
+ value di = Field(dis, 0);
+ code_t start = (code_t)Field(di, DI_START);
+ code_t end = (code_t) ((char *) start + Int_val(Field(di, DI_SIZE)));
+ if (start <= pc && pc < end) {
+ value events = Field(di, DI_EVENTS);
+ pos = Val_long((char *) pc - (char *) start);
+ for (i = 0; i < Wosize_val(events); i++) {
+ for (l = Field(events, i); l != Val_int(0); l = Field(l, 1)) {
+ ev = Field(l, 0);
+ ev_pos = Field(ev, EV_POS);
+ if (ev_pos == pos) return ev;
+ /* ocamlc sometimes moves an event past a following PUSH instruction;
+ allow mismatch by 1 instruction. */
+ if (ev_pos == pos + 8) best_ev = ev;
+ }
+ }
+ if (best_ev != 0) return best_ev;
+ return Val_false;
}
+ dis = Field(dis, 1);
}
- if (best_ev != 0) return best_ev;
return Val_false;
}
/* Print the location corresponding to the given PC */
-static void print_location(value events, int index)
+static int snprint_location(char *s, int len, int index)
{
code_t pc = caml_backtrace_buffer[index];
char * info;
value ev;
- ev = event_for_location(events, pc);
+ ev = event_for_location(pc);
if (caml_is_instruction(*pc, RAISE)) {
/* Ignore compiler-inserted raise */
- if (ev == Val_false) return;
+ if (ev == Val_false) return 0;
/* Initial raise if index == 0, re-raise otherwise */
if (index == 0)
info = "Raised at";
@@ -190,7 +257,13 @@ static void print_location(value events, int index)
info = "Called from";
}
if (ev == Val_false) {
- fprintf(stderr, "%s unknown location\n", info);
+ char *fmt = "%s unknown location\n";
+ if (s)
+ return snprintf(s, len, fmt, info);
+ else {
+ fprintf(stderr, fmt, info);
+ return 0;
+ }
} else {
value ev_start = Field (Field (ev, EV_LOC), LOC_START);
char *fname = String_val (Field (ev_start, POS_FNAME));
@@ -199,24 +272,68 @@ static void print_location(value events, int index)
- Int_val (Field (ev_start, POS_BOL));
int endchr = Int_val (Field (Field (Field (ev, EV_LOC), LOC_END), POS_CNUM))
- Int_val (Field (ev_start, POS_BOL));
- fprintf (stderr, "%s file \"%s\", line %d, characters %d-%d\n", info, fname,
- lnum, startchr, endchr);
+ char *fmt = "%s file \"%s\", line %d, characters %d-%d\n";
+ if (s)
+ return snprintf (s, len, fmt, info, fname, lnum, startchr, endchr);
+ else {
+ fprintf (stderr, fmt, info, fname,lnum, startchr, endchr);
+ return 0;
+ }
}
}
/* Print a backtrace */
-CAMLexport void caml_print_exception_backtrace(void)
+static int snprint_exception_backtrace(char *s, int len)
{
- value events;
int i;
- events = read_debug_info();
- if (events == Val_false) {
- fprintf(stderr,
- "(Program not linked with -g, cannot print stack backtrace)\n");
- return;
- }
+ int total_chars = 0;
for (i = 0; i < caml_backtrace_pos; i++)
- print_location(events, i);
+ {
+ int chars = snprint_location(s, len, i);
+ total_chars += chars;
+ s += chars;
+ len -= chars;
+ }
+ return total_chars;
+}
+
+CAMLexport void caml_print_exception_backtrace(void)
+{
+ snprint_exception_backtrace(0, 0);
+}
+
+CAMLprim value caml_sprint_backtrace(value sv)
+{
+ if (caml_backtrace_active)
+ {
+ int len = caml_string_length(sv);
+ char *s = String_val(sv);
+ int chars = snprint_exception_backtrace(s, len);
+ return Val_int(chars);
+ }
+ else
+ return Val_int(0);
+}
+
+CAMLprim value caml_capture_backtrace(value on)
+{
+ if (Bool_val(on))
+ {
+ caml_backtrace_active = 1;
+ caml_register_global_root(&caml_backtrace_last_exn);
+ }
+ else
+ {
+ caml_backtrace_active = 0;
+ caml_remove_global_root(&caml_backtrace_last_exn);
+ caml_backtrace_last_exn = Val_unit;
+ }
+ return Val_unit;
+}
+
+CAMLprim value caml_backtrace_captured(value unit)
+{
+ return caml_backtrace_active ? Val_true : Val_false;
}
diff --git a/byterun/backtrace.h b/byterun/backtrace.h
index f962ad7..44f6b73 100644
--- a/byterun/backtrace.h
+++ b/byterun/backtrace.h
@@ -17,6 +17,7 @@
#define CAML_BACKTRACE_H
#include "mlvalues.h"
+#include "exec.h"
CAMLextern int caml_backtrace_active;
CAMLextern int caml_backtrace_pos;
@@ -28,5 +29,6 @@ extern void caml_init_backtrace(void);
extern void caml_stash_backtrace(value exn, code_t pc, value * sp);
#endif
CAMLextern void caml_print_exception_backtrace(void);
+CAMLextern void caml_read_debug_info(int fd, struct exec_trailer *trail);
#endif /* CAML_BACKTRACE_H */
diff --git a/byterun/intern.c b/byterun/intern.c
index fbc4fe1..f9e9c6a 100644
--- a/byterun/intern.c
+++ b/byterun/intern.c
@@ -324,7 +324,7 @@ static void intern_rec(value *dest)
*dest = v;
}
-static void intern_alloc(mlsize_t whsize, mlsize_t num_objects)
+static void intern_alloc_(mlsize_t whsize, mlsize_t num_objects, int out_of_heap)
{
mlsize_t wosize;
@@ -335,7 +335,7 @@ static void intern_alloc(mlsize_t whsize, mlsize_t num_objects)
return;
}
wosize = Wosize_whsize(whsize);
- if (wosize > Max_wosize) {
+ if (wosize > Max_wosize || out_of_heap) {
/* Round desired size up to next page */
asize_t request =
((Bsize_wsize(whsize) + Page_size - 1) >> Page_log) << Page_log;
@@ -367,6 +367,11 @@ static void intern_alloc(mlsize_t whsize, mlsize_t num_objects)
intern_obj_table = NULL;
}
+static void intern_alloc(mlsize_t whsize, mlsize_t num_objects)
+{
+ intern_alloc_(whsize, num_objects, 0);
+}
+
static void intern_add_to_heap(mlsize_t whsize)
{
/* Add new heap chunk to heap if needed */
@@ -387,7 +392,7 @@ static void intern_add_to_heap(mlsize_t whsize)
}
}
-value caml_input_val(struct channel *chan)
+value caml_input_val_(struct channel *chan, int out_of_heap)
{
uint32 magic;
mlsize_t block_len, num_objects, size_32, size_64, whsize;
@@ -421,16 +426,22 @@ value caml_input_val(struct channel *chan)
#else
whsize = size_32;
#endif
- intern_alloc(whsize, num_objects);
+ intern_alloc_(whsize, num_objects, out_of_heap);
/* Fill it in */
intern_rec(&res);
- intern_add_to_heap(whsize);
+ if (!out_of_heap)
+ intern_add_to_heap(whsize);
/* Free everything */
caml_stat_free(intern_input);
if (intern_obj_table != NULL) caml_stat_free(intern_obj_table);
return res;
}
+value caml_input_val(struct channel *chan)
+{
+ return caml_input_val_(chan, 0);
+}
+
CAMLprim value caml_input_value(value vchan)
{
CAMLparam1 (vchan);
diff --git a/byterun/intext.h b/byterun/intext.h
index 7d8eb4c..a02713b 100644
--- a/byterun/intext.h
+++ b/byterun/intext.h
@@ -97,6 +97,7 @@ CAMLextern intnat caml_output_value_to_block(value v, value flags,
/* <private> */
value caml_input_val (struct channel * chan);
/* Read a structured value from the channel [chan]. */
+value caml_input_val_ (struct channel * chan, int out_of_heap);
/* </private> */
CAMLextern value caml_input_val_from_string (value str, intnat ofs);
diff --git a/byterun/io.c b/byterun/io.c
index 04b9746..58d2b07 100644
--- a/byterun/io.c
+++ b/byterun/io.c
@@ -103,6 +103,12 @@ static void unlink_channel(struct channel *channel)
CAMLexport void caml_close_channel(struct channel *channel)
{
close(channel->fd);
+ caml_release_channel(channel);
+}
+
+/* release the channel but leave the file descriptor open */
+CAMLexport void caml_release_channel(struct channel *channel)
+{
if (channel->refcount > 0) return;
if (caml_channel_mutex_free != NULL) (*caml_channel_mutex_free)(channel);
unlink_channel(channel);
diff --git a/byterun/io.h b/byterun/io.h
index 749027a..47c6860 100644
--- a/byterun/io.h
+++ b/byterun/io.h
@@ -77,6 +77,7 @@ enum {
CAMLextern struct channel * caml_open_descriptor_in (int);
CAMLextern struct channel * caml_open_descriptor_out (int);
CAMLextern void caml_close_channel (struct channel *);
+CAMLextern void caml_release_channel (struct channel *);
CAMLextern int caml_channel_binary_mode (struct channel *);
CAMLextern value caml_alloc_channel(struct channel *chan);
diff --git a/byterun/startup.c b/byterun/startup.c
index e08a06e..19103e6 100644
--- a/byterun/startup.c
+++ b/byterun/startup.c
@@ -392,6 +392,7 @@ CAMLexport void caml_main(char **argv)
caml_stat_free(shared_lib_path);
caml_stat_free(shared_libs);
caml_stat_free(req_prims);
+ caml_read_debug_info(fd, &trail);
/* Load the globals */
caml_seek_section(fd, &trail, "DATA");
chan = caml_open_descriptor_in(fd);
diff --git a/otherlibs/dynlink/dynlink.ml b/otherlibs/dynlink/dynlink.ml
index 24e0e0a..aa9576b 100644
--- a/otherlibs/dynlink/dynlink.ml
+++ b/otherlibs/dynlink/dynlink.ml
@@ -176,6 +176,13 @@ let load_compunit ic file_name compunit =
| _ -> assert false in
raise(Error(Linking_error (file_name, new_error)))
end;
+ let events =
+ if compunit.cu_debug = 0 then [| |]
+ else begin
+ seek_in ic compunit.cu_debug;
+ [| input_value ic |]
+ end in
+ Meta.add_debug_info code code_size events;
begin try
ignore((Meta.reify_bytecode code code_size) ())
with exn ->
diff --git a/stdlib/printexc.ml b/stdlib/printexc.ml
index 77bf127..b65287d 100644
--- a/stdlib/printexc.ml
+++ b/stdlib/printexc.ml
@@ -13,6 +13,10 @@
(* $Id: printexc.ml,v 1.18 2004/01/16 15:24:02 doligez Exp $ *)
+external capture_backtrace : bool -> unit = "caml_capture_backtrace";;
+external backtrace_captured : unit -> bool = "caml_backtrace_captured";;
+external sprint_backtrace : string -> int = "caml_sprint_backtrace";;
+
open Printf;;
let locfmt = format_of_string "File \"%s\", line %d, characters %d-%d: %s";;
diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml
index 204df79..f897b39 100644
--- a/toplevel/topdirs.ml
+++ b/toplevel/topdirs.ml
@@ -74,11 +74,19 @@ let load_compunit ic filename ppf compunit =
let initial_symtable = Symtable.current_state() in
Symtable.patch_object code compunit.cu_reloc;
Symtable.update_global_table();
+ let events =
+ if compunit.cu_debug = 0 then [| |]
+ else begin
+ seek_in ic compunit.cu_debug;
+ [| input_value ic |]
+ end in
+ Meta.add_debug_info code code_size events;
begin try
may_trace := true;
ignore((Meta.reify_bytecode code code_size) ());
may_trace := false;
with exn ->
+ capture_backtrace ();
may_trace := false;
Symtable.restore_state initial_symtable;
print_exception_outcome ppf exn;
@@ -298,4 +306,10 @@ let _ =
(Directive_string (parse_warnings std_out false));
Hashtbl.add directive_table "warn_error"
- (Directive_string (parse_warnings std_out true))
+ (Directive_string (parse_warnings std_out true));
+
+ Hashtbl.add directive_table "debug"
+ (Directive_bool(fun b -> Clflags.debug := b));
+
+ Hashtbl.add directive_table "capture_backtrace"
+ (Directive_bool(fun b -> Printexc.capture_backtrace b))
diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml
index 1a202bb..7a71452 100644
--- a/toplevel/toploop.ml
+++ b/toplevel/toploop.ml
@@ -113,6 +113,13 @@ let toplevel_startup_hook = ref (fun () -> ())
let may_trace = ref false (* Global lock on tracing *)
type evaluation_outcome = Result of Obj.t | Exception of exn
+let backtrace = String.create 8192
+let backtrace_length = ref 0
+
+let capture_backtrace () =
+ if Printexc.backtrace_captured ()
+ then backtrace_length := Printexc.sprint_backtrace backtrace
+
let load_lambda ppf lam =
if !Clflags.dump_rawlambda then fprintf ppf "%a@." Printlambda.lambda lam;
let slam = Simplif.simplify_lambda lam in
@@ -122,7 +129,8 @@ let load_lambda ppf lam =
fprintf ppf "%a%a@."
Printinstr.instrlist init_code
Printinstr.instrlist fun_code;
- let (code, code_size, reloc) = Emitcode.to_memory init_code fun_code in
+ let (code, code_size, reloc, events) = Emitcode.to_memory init_code fun_code in
+ Meta.add_debug_info code code_size [| events |];
let can_free = (fun_code = []) in
let initial_symtable = Symtable.current_state() in
Symtable.patch_object code reloc;
@@ -133,13 +141,16 @@ let load_lambda ppf lam =
let retval = (Meta.reify_bytecode code code_size) () in
may_trace := false;
if can_free then begin
+ Meta.remove_debug_info code;
Meta.static_release_bytecode code code_size;
Meta.static_free code;
end;
Result retval
with x ->
+ capture_backtrace ();
may_trace := false;
if can_free then begin
+ Meta.remove_debug_info code;
Meta.static_release_bytecode code code_size;
Meta.static_free code;
end;
@@ -203,7 +214,13 @@ let print_out_exception ppf exn outv =
let print_exception_outcome ppf exn =
if exn = Out_of_memory then Gc.full_major ();
let outv = outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn in
- print_out_exception ppf exn outv
+ print_out_exception ppf exn outv;
+ if Printexc.backtrace_captured()
+ then begin
+ if !backtrace_length > 0
+ then print_string (String.sub backtrace 0 !backtrace_length);
+ backtrace_length := 0
+ end
(* The table of toplevel directives.
Filled by functions from module topdirs. *)
@@ -247,6 +264,15 @@ let execute_phrase print_outcome ppf phr =
Ophr_exception (exn, outv)
in
!print_out_phrase ppf out_phr;
+ if Printexc.backtrace_captured()
+ then begin
+ if !backtrace_length > 0
+ then begin
+ pp_print_string ppf (String.sub backtrace 0 !backtrace_length);
+ pp_print_flush ppf ();
+ backtrace_length := 0;
+ end;
+ end;
begin match out_phr with
| Ophr_eval (_, _) | Ophr_signature _ -> true
| Ophr_exception _ -> false
diff --git a/toplevel/toploop.mli b/toplevel/toploop.mli
index 7093f1b..48d5a9a 100644
--- a/toplevel/toploop.mli
+++ b/toplevel/toploop.mli
@@ -62,6 +62,7 @@ val use_silently : formatter -> string -> bool
[use_silently] does not print them. *)
val eval_path: Path.t -> Obj.t
(* Return the toplevel object referred to by the given path *)
+val capture_backtrace: unit -> unit
(* Printing of values *)