summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--asmrun/backtrace.c90
-rw-r--r--byterun/backtrace.c241
-rw-r--r--stdlib/printexc.ml16
-rw-r--r--stdlib/printexc.mli27
4 files changed, 224 insertions, 150 deletions
diff --git a/asmrun/backtrace.c b/asmrun/backtrace.c
index 3854967cf..eada458a1 100644
--- a/asmrun/backtrace.c
+++ b/asmrun/backtrace.c
@@ -172,7 +172,7 @@ CAMLprim value caml_get_current_callstack(value max_frames_value) {
}
}
- trace = caml_alloc((mlsize_t) trace_size, Abstract_tag);
+ trace = caml_alloc((mlsize_t) trace_size, 0);
/* then collect the trace */
{
@@ -183,11 +183,15 @@ CAMLprim value caml_get_current_callstack(value max_frames_value) {
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
+ /* In order to prevent the GC to walk through the debug
+ information (which have no headers), we transform the descr
+ pointer to a 31/63 bits ocaml integer by shifting it by 1 to
+ the right. We do not lose information as descr is aligned.
+
+ 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;
+ we assign long values. */
+ Field(trace, trace_pos) = Val_long((uintnat)descr>>1);
}
}
@@ -295,31 +299,29 @@ void caml_print_exception_backtrace(void)
/* Convert the raw backtrace to a data structure usable from OCaml */
-CAMLprim value caml_convert_raw_backtrace(value backtrace) {
- CAMLparam1(backtrace);
- CAMLlocal4(res, arr, p, fname);
- int i;
+CAMLprim value caml_convert_raw_backtrace_slot(value backtrace_slot) {
+ CAMLparam1(backtrace_slot);
+ CAMLlocal2(p, fname);
struct loc_info li;
- arr = caml_alloc(Wosize_val(backtrace), 0);
- for (i = 0; i < Wosize_val(backtrace); i++) {
- extract_location_info((frame_descr *) Field(backtrace, i), &li);
- if (li.loc_valid) {
- fname = caml_copy_string(li.loc_filename);
- p = caml_alloc_small(5, 0);
- Field(p, 0) = Val_bool(li.loc_is_raise);
- Field(p, 1) = fname;
- Field(p, 2) = Val_int(li.loc_lnum);
- Field(p, 3) = Val_int(li.loc_startchr);
- Field(p, 4) = Val_int(li.loc_endchr);
- } else {
- p = caml_alloc_small(1, 1);
- Field(p, 0) = Val_bool(li.loc_is_raise);
- }
- caml_modify(&Field(arr, i), p);
+ /* We shift back the backtrace slot to a frame_descr pointer. It is
+ aligned, so we know the low-order bit is 0. */
+ extract_location_info((frame_descr *)(Long_val(backtrace_slot)<<1), &li);
+
+ if (li.loc_valid) {
+ fname = caml_copy_string(li.loc_filename);
+ p = caml_alloc_small(5, 0);
+ Field(p, 0) = Val_bool(li.loc_is_raise);
+ Field(p, 1) = fname;
+ Field(p, 2) = Val_int(li.loc_lnum);
+ Field(p, 3) = Val_int(li.loc_startchr);
+ Field(p, 4) = Val_int(li.loc_endchr);
+ } else {
+ p = caml_alloc_small(1, 1);
+ Field(p, 0) = Val_bool(li.loc_is_raise);
}
- res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */
- CAMLreturn(res);
+
+ CAMLreturn(p);
}
/* Get a copy of the latest backtrace */
@@ -328,28 +330,20 @@ CAMLprim value caml_get_exception_raw_backtrace(value unit)
{
CAMLparam0();
CAMLlocal1(res);
- res = caml_alloc(caml_backtrace_pos, Abstract_tag);
- if(caml_backtrace_buffer != NULL)
- memcpy(&Field(res, 0), caml_backtrace_buffer,
- caml_backtrace_pos * sizeof(code_t));
- CAMLreturn(res);
-}
-/* the function below is deprecated: we previously returned directly
- the OCaml-usable representation, instead of the raw backtrace as an
- abstract type, but this has a large performance overhead if you
- store a lot of backtraces and print only some of them.
+ res = caml_alloc(caml_backtrace_pos, 0);
+ if(caml_backtrace_buffer != NULL) {
+ intnat i;
+ for(i = 0; i < caml_backtrace_pos; i++)
+ /* In order to prevent the GC to walk through the debug
+ information (which have no headers), we transform the
+ pointer to a 31/63 bits ocaml integer by shifting it by 1 to
+ the right. We do not lose information the pointer is aligned.
- It is not used by the Printexc library anymore, or anywhere else in
- the compiler, but we have kept it in case some user still depends
- on it as an external.
-*/
-
-CAMLprim value caml_get_exception_backtrace(value unit)
-{
- CAMLparam0();
- CAMLlocal2(raw,res);
- raw = caml_get_exception_raw_backtrace(unit);
- res = caml_convert_raw_backtrace(raw);
+ The assignment below is safe without [caml_initialize], even
+ if the trace is large and allocated on the old heap, because
+ we assign long values. */
+ Field(res, i) = Val_long(((uintnat)caml_backtrace_buffer[i])>>1);
+ }
CAMLreturn(res);
}
diff --git a/byterun/backtrace.c b/byterun/backtrace.c
index d39e39529..c50425ca1 100644
--- a/byterun/backtrace.c
+++ b/byterun/backtrace.c
@@ -35,6 +35,7 @@
#include "stacks.h"
#include "sys.h"
#include "backtrace.h"
+#include "fail.h"
CAMLexport int caml_backtrace_active = 0;
CAMLexport int caml_backtrace_pos = 0;
@@ -165,7 +166,7 @@ CAMLprim value caml_get_current_callstack(value max_frames_value) {
}
}
- trace = caml_alloc(trace_size, Abstract_tag);
+ trace = caml_alloc(trace_size, 0);
/* then collect the trace */
{
@@ -176,36 +177,58 @@ CAMLprim value caml_get_current_callstack(value max_frames_value) {
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
+ /* In order to prevent the GC to walk through the debug
+ information (which have no headers), we transform the p code
+ pointer to a 31/63 bits ocaml integer by shifting it by 1 to
+ the right. We do not lose information because p is aligned.
+
+ 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;
+ we assign long values. */
+ Field(trace, trace_pos) = Val_long((uintnat)p>>1);
}
}
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. */
+/* Read the debugging info contained in the current bytecode executable. */
#ifndef O_BINARY
#define O_BINARY 0
#endif
+struct ev_info {
+ code_t ev_pc;
+ char * ev_filename;
+ int ev_lnum;
+ int ev_startchr;
+ int ev_endchr;
+};
+
+static int cmp_ev_info(const void *a, const void *b) {
+ if(((const struct ev_info*)a)->ev_pc > ((const struct ev_info*)b)->ev_pc)
+ return 1;
+ return -1;
+}
+
static char *read_debug_info_error = "";
-static value read_debug_info(void)
+static uintnat n_events;
+static struct ev_info *events = NULL;
+static void read_debug_info(void)
{
CAMLparam0();
- CAMLlocal1(events);
+ CAMLlocal1(events_heap);
char * exec_name;
int fd;
struct exec_trailer trail;
struct channel * chan;
uint32 num_events, orig, i;
- value evl, l;
+ uintnat j;
+ value evl, l, ev_start;
+
+ if(events != NULL)
+ CAMLreturn0;
if (caml_cds_file != NULL) {
exec_name = caml_cds_file;
@@ -215,17 +238,18 @@ static value read_debug_info(void)
fd = caml_attempt_open(&exec_name, &trail, 1);
if (fd < 0){
read_debug_info_error = "executable program file not found";
- CAMLreturn(Val_false);
+ CAMLreturn0;
}
caml_read_section_descriptors(fd, &trail);
if (caml_seek_optional_section(fd, &trail, "DBUG") == -1) {
close(fd);
read_debug_info_error = "program not linked with -g";
- CAMLreturn(Val_false);
+ CAMLreturn0;
}
chan = caml_open_descriptor_in(fd);
num_events = caml_getword(chan);
- events = caml_alloc(num_events, 0);
+ n_events = 0;
+ events_heap = caml_alloc(num_events, 0);
for (i = 0; i < num_events; i++) {
orig = caml_getword(chan);
evl = caml_input_val(chan);
@@ -234,36 +258,82 @@ static value read_debug_info(void)
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);
+ n_events++;
}
/* Record event list */
- Store_field(events, i, evl);
+ Store_field(events_heap, i, evl);
}
caml_close_channel(chan);
- CAMLreturn(events);
+
+ events = (struct ev_info*)malloc(n_events * sizeof(struct ev_info));
+ if(events == NULL) {
+ read_debug_info_error = "out of memory";
+ CAMLreturn0;
+ }
+
+ j = 0;
+ for (i = 0; i < num_events; i++) {
+ for (l = Field(events_heap, i); l != Val_int(0); l = Field(l, 1)) {
+ uintnat fnsz;
+ value ev = Field(l, 0);
+
+ events[j].ev_pc =
+ (code_t)((char*)caml_start_code + Long_val(Field(ev, EV_POS)));
+
+ ev_start = Field (Field (ev, EV_LOC), LOC_START);
+
+ fnsz = caml_string_length(Field (ev_start, POS_FNAME))+1;
+ events[j].ev_filename = (char*)malloc(fnsz);
+ if(events[j].ev_filename == NULL) {
+ for(j--; j >= 0; j--)
+ free(events[j].ev_filename);
+ free(events);
+ events = NULL;
+ read_debug_info_error = "out of memory";
+ CAMLreturn0;
+ }
+ memcpy(events[j].ev_filename, String_val (Field (ev_start, POS_FNAME)), fnsz);
+
+ events[j].ev_lnum = Int_val (Field (ev_start, POS_LNUM));
+ events[j].ev_startchr =
+ Int_val (Field (ev_start, POS_CNUM))
+ - Int_val (Field (ev_start, POS_BOL));
+ events[j].ev_endchr =
+ Int_val (Field (Field (Field (ev, EV_LOC), LOC_END), POS_CNUM))
+ - Int_val (Field (ev_start, POS_BOL));
+
+ j++;
+ }
+ }
+
+ Assert(j == n_events);
+
+ qsort(events, n_events, sizeof(struct ev_info), cmp_ev_info);
+
+ CAMLreturn0;
}
-/* Search the event for the given PC. Return Val_false if not found. */
+/* Search the event index for the given PC. Return -1 if not found. */
-static value event_for_location(value events, code_t pc)
+static intnat event_for_location(code_t pc)
{
- mlsize_t i;
- value pos, l, ev, ev_pos, best_ev;
-
- best_ev = 0;
+ uintnat low = 0, high = n_events;
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;
- }
+ Assert(events != NULL);
+ while(low+1 < high) {
+ uintnat m = (low+high)/2;
+ if(pc < events[m].ev_pc) high = m;
+ else low = m;
}
- if (best_ev != 0) return best_ev;
- return Val_false;
+ if(events[low].ev_pc == pc)
+ return low;
+ /* ocamlc sometimes moves an event past a following PUSH instruction;
+ allow mismatch by 1 instruction. */
+ if(events[low].ev_pc == pc + 1)
+ return low;
+ if(low+1 < n_events && events[low+1].ev_pc == pc + 1)
+ return low+1;
+ return -1;
}
/* Extract location information for the given PC */
@@ -277,28 +347,21 @@ struct loc_info {
int loc_endchr;
};
-static void extract_location_info(value events, code_t pc,
+static void extract_location_info(code_t pc,
/*out*/ struct loc_info * li)
{
- value ev, ev_start;
-
- ev = event_for_location(events, pc);
+ intnat ev = event_for_location(pc);
li->loc_is_raise = caml_is_instruction(*pc, RAISE) ||
caml_is_instruction(*pc, RERAISE);
- if (ev == Val_false) {
+ if (ev == -1) {
li->loc_valid = 0;
return;
}
li->loc_valid = 1;
- ev_start = Field (Field (ev, EV_LOC), LOC_START);
- li->loc_filename = String_val (Field (ev_start, POS_FNAME));
- li->loc_lnum = Int_val (Field (ev_start, POS_LNUM));
- li->loc_startchr =
- Int_val (Field (ev_start, POS_CNUM))
- - Int_val (Field (ev_start, POS_BOL));
- li->loc_endchr =
- Int_val (Field (Field (Field (ev, EV_LOC), LOC_END), POS_CNUM))
- - Int_val (Field (ev_start, POS_BOL));
+ li->loc_filename = events[ev].ev_filename;
+ li->loc_lnum = events[ev].ev_lnum;
+ li->loc_startchr = events[ev].ev_startchr;
+ li->loc_endchr = events[ev].ev_endchr;
}
/* Print location information -- same behavior as in Printexc */
@@ -335,55 +398,49 @@ static void print_location(struct loc_info * li, int index)
CAMLexport void caml_print_exception_backtrace(void)
{
- value events;
int i;
struct loc_info li;
- events = read_debug_info();
- if (events == Val_false) {
+ read_debug_info();
+ if (events == NULL) {
fprintf(stderr, "(Cannot print stack backtrace: %s)\n",
read_debug_info_error);
return;
}
for (i = 0; i < caml_backtrace_pos; i++) {
- extract_location_info(events, caml_backtrace_buffer[i], &li);
+ extract_location_info(caml_backtrace_buffer[i], &li);
print_location(&li, i);
}
}
/* Convert the backtrace to a data structure usable from OCaml */
-CAMLprim value caml_convert_raw_backtrace(value backtrace)
-{
- CAMLparam1(backtrace);
- CAMLlocal5(events, res, arr, p, fname);
- int i;
+CAMLprim value caml_convert_raw_backtrace_slot(value backtrace_slot) {
+ CAMLparam1(backtrace_slot);
+ CAMLlocal2(p, fname);
struct loc_info li;
- events = read_debug_info();
- if (events == Val_false) {
- res = Val_int(0); /* None */
+ read_debug_info();
+ if (events == NULL)
+ caml_failwith(read_debug_info_error);
+
+ /* We shift back the backtrace slot to a code_t. It is aligned, so
+ we know the low-order bit is 0. */
+ extract_location_info((code_t)(Long_val(backtrace_slot)<<1), &li);
+
+ if (li.loc_valid) {
+ fname = caml_copy_string(li.loc_filename);
+ p = caml_alloc_small(5, 0);
+ Field(p, 0) = Val_bool(li.loc_is_raise);
+ Field(p, 1) = fname;
+ Field(p, 2) = Val_int(li.loc_lnum);
+ Field(p, 3) = Val_int(li.loc_startchr);
+ Field(p, 4) = Val_int(li.loc_endchr);
} else {
- arr = caml_alloc(Wosize_val(backtrace), 0);
- for (i = 0; i < Wosize_val(backtrace); i++) {
- extract_location_info(events, (code_t)Field(backtrace, i), &li);
- if (li.loc_valid) {
- fname = caml_copy_string(li.loc_filename);
- p = caml_alloc_small(5, 0);
- Field(p, 0) = Val_bool(li.loc_is_raise);
- Field(p, 1) = fname;
- Field(p, 2) = Val_int(li.loc_lnum);
- Field(p, 3) = Val_int(li.loc_startchr);
- Field(p, 4) = Val_int(li.loc_endchr);
- } else {
- p = caml_alloc_small(1, 1);
- Field(p, 0) = Val_bool(li.loc_is_raise);
- }
- caml_modify(&Field(arr, i), p);
- }
- res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */
+ p = caml_alloc_small(1, 1);
+ Field(p, 0) = Val_bool(li.loc_is_raise);
}
- CAMLreturn(res);
+ CAMLreturn(p);
}
/* Get a copy of the latest backtrace */
@@ -392,20 +449,20 @@ CAMLprim value caml_get_exception_raw_backtrace(value unit)
{
CAMLparam0();
CAMLlocal1(res);
- res = caml_alloc(caml_backtrace_pos, Abstract_tag);
- if(caml_backtrace_buffer != NULL)
- memcpy(&Field(res, 0), caml_backtrace_buffer,
- caml_backtrace_pos * sizeof(code_t));
- CAMLreturn(res);
-}
-/* the function below is deprecated: see asmrun/backtrace.c */
+ res = caml_alloc(caml_backtrace_pos, 0);
+ if(caml_backtrace_buffer != NULL) {
+ intnat i;
+ for(i = 0; i < caml_backtrace_pos; i++)
+ /* In order to prevent the GC to walk through the debug
+ information (which have no headers), we transform the
+ pointer to a 31/63 bits ocaml integer by shifting it by 1 to
+ the right. We do not lose information as descr is aligned.
-CAMLprim value caml_get_exception_backtrace(value unit)
-{
- CAMLparam0();
- CAMLlocal2(raw, res);
- raw = caml_get_exception_raw_backtrace(unit);
- res = caml_convert_raw_backtrace(raw);
+ The assignment below is safe without [caml_initialize], even
+ if the trace is large and allocated on the old heap, because
+ we assign long values. */
+ Field(res, i) = Val_long(((uintnat)caml_backtrace_buffer[i])>>1);
+ }
CAMLreturn(res);
}
diff --git a/stdlib/printexc.ml b/stdlib/printexc.ml
index 285308b79..b983e3693 100644
--- a/stdlib/printexc.ml
+++ b/stdlib/printexc.ml
@@ -82,12 +82,13 @@ let catch fct arg =
eprintf "Uncaught exception: %s\n" (to_string x);
exit 2
-type raw_backtrace
+type raw_backtrace_slot
+type raw_backtrace = raw_backtrace_slot array
external get_raw_backtrace:
unit -> raw_backtrace = "caml_get_exception_raw_backtrace"
-type loc_info =
+type backtrace_slot =
| Known_location of bool (* is_raise *)
* string (* filename *)
* int (* line number *)
@@ -98,10 +99,12 @@ type loc_info =
(* to avoid warning *)
let _ = [Known_location (false, "", 0, 0, 0); Unknown_location false]
-type backtrace = loc_info array
+external convert_raw_backtrace_slot:
+ raw_backtrace_slot -> backtrace_slot = "caml_convert_raw_backtrace_slot"
-external convert_raw_backtrace:
- raw_backtrace -> backtrace option = "caml_convert_raw_backtrace"
+let convert_raw_backtrace rbckt =
+ try Some (Array.map convert_raw_backtrace_slot rbckt)
+ with Failure _ -> None
let format_loc_info pos li =
let is_raise =
@@ -158,9 +161,6 @@ let raw_backtrace_to_string 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"
diff --git a/stdlib/printexc.mli b/stdlib/printexc.mli
index 2916bf143..53cf81566 100644
--- a/stdlib/printexc.mli
+++ b/stdlib/printexc.mli
@@ -85,15 +85,20 @@ val register_printer: (exn -> string option) -> unit
(** {6 Raw backtraces} *)
-type raw_backtrace
+type raw_backtrace_slot
+type raw_backtrace = raw_backtrace_slot array
-(** The abstract type [backtrace] stores exception backtraces in
+(** The abstract type [raw_backtrace_slot] stores a slot of a backtrace in
a low-level format, instead of directly exposing them as string as
the [get_backtrace()] function does.
This allows delaying the formatting of backtraces to when they are
actually printed, which might be useful if you record more
backtraces than you print.
+
+ Elements of type raw_backtrace_slot can be compared and hashed: when two
+ elements are equal, then they represent the same source location (the
+ converse is not necessarily true in presence of inlining, for example).
*)
val get_raw_backtrace: unit -> raw_backtrace
@@ -116,6 +121,24 @@ val set_uncaught_exception_handler: (exn -> raw_backtrace -> unit) -> unit
@since 4.02.0
*)
+(** {6 Backtrace slots processing} *)
+
+type backtrace_slot =
+ | Known_location of bool (* is_raise *)
+ * string (* filename *)
+ * int (* line number *)
+ * int (* start char *)
+ * int (* end char *)
+ | Unknown_location of bool (*is_raise*)
+
+(** [convert_raw_backtrace_slot] converts one slot of a raw backtrace
+ to an Ocaml algebraic datatype representing to location
+ information in the source file.
+
+ Raises [Failure] if not able to load debug information.
+*)
+val convert_raw_backtrace_slot: raw_backtrace_slot -> backtrace_slot
+
(** {6 Current call stack} *)
val get_callstack: int -> raw_backtrace
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-04-08 17:19:56 +0000