Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

patch for 3.11.1

  • Loading branch information...
commit 603e7f17e9b3e55679c67e5cb7fa63454c5b18b8 1 parent f7eabd9
Jake Donham authored
Showing with 663 additions and 0 deletions.
  1. +651 −0 patch-3.11.1
  2. +12 −0 patch2-3.11.1
651 patch-3.11.1
View
@@ -0,0 +1,651 @@
+diff --git a/.depend b/.depend
+index b52df95..d8dbad3 100644
+--- a/.depend
++++ b/.depend
+@@ -295,7 +295,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/meta.cmi: bytecomp/instruct.cmi
+ bytecomp/printinstr.cmi: bytecomp/instruct.cmi
+ bytecomp/printlambda.cmi: bytecomp/lambda.cmi
+ bytecomp/runtimedef.cmi:
+@@ -384,8 +384,8 @@ bytecomp/matching.cmx: typing/types.cmx bytecomp/typeopt.cmx \
+ parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \
+ utils/clflags.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/opcodes.cmo:
+ bytecomp/opcodes.cmx:
+ bytecomp/printinstr.cmo: bytecomp/printlambda.cmi parsing/location.cmi \
+diff --git a/Makefile b/Makefile
+index c33a268..4e6bf74 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 -I otherlibs/dynlink
+-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 61e8d36..3db2f06 100644
+--- a/asmrun/backtrace.c
++++ b/asmrun/backtrace.c
+@@ -223,3 +223,12 @@ CAMLprim value caml_get_exception_backtrace(value unit)
+ CAMLreturn(res);
+ }
+
++CAMLprim value caml_add_debug_info(code_t start, value size, value events)
++{
++ return Val_unit;
++}
++
++CAMLprim value caml_remove_debug_info(code_t start, value size, value events)
++{
++ return Val_unit;
++}
+diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml
+index f607e7c..0da2e69 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..bd5ebef 100644
+--- a/bytecomp/meta.ml
++++ b/bytecomp/meta.ml
+@@ -24,3 +24,7 @@ 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/backtrace.c b/byterun/backtrace.c
+index eb240fc..2c80eb3 100644
+--- a/byterun/backtrace.c
++++ b/byterun/backtrace.c
+@@ -39,6 +39,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 */
+@@ -60,6 +61,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);
++}
++
+ /* Start or stop the backtrace machinery */
+
+ CAMLprim value caml_record_backtrace(value vflag)
+@@ -93,7 +137,6 @@ CAMLprim value caml_backtrace_status(value vunit)
+
+ 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;
+@@ -104,14 +147,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);
+ }
+ }
+ }
+@@ -124,64 +183,72 @@ 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)) {
+- value ev = Field(l, 0);
+- Field(ev, EV_POS) = Val_long(Long_val(Field(ev, EV_POS)) + orig);
++ 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;
+ }
+
+@@ -196,12 +263,12 @@ 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);
++ ev = event_for_location(pc);
+ li->loc_is_raise = caml_is_instruction(*pc, RAISE);
+ if (ev == Val_false) {
+ li->loc_valid = 0;
+@@ -253,18 +320,16 @@ 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) {
++ if (caml_debug_info == Val_emptylist) {
+ fprintf(stderr,
+ "(Program not linked with -g, cannot print stack backtrace)\n");
+ 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);
+ }
+ }
+@@ -274,17 +339,16 @@ CAMLexport void caml_print_exception_backtrace(void)
+ CAMLprim value caml_get_exception_backtrace(value unit)
+ {
+ CAMLparam0();
+- CAMLlocal5(events, res, arr, p, fname);
++ CAMLlocal4(res, arr, p, fname);
+ int i;
+ struct loc_info li;
+
+- events = read_debug_info();
+- if (events == Val_false) {
++ if (caml_debug_info == Val_emptylist) {
+ res = Val_int(0); /* None */
+ } else {
+ arr = caml_alloc(caml_backtrace_pos, 0);
+ 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);
+ if (li.loc_valid) {
+ fname = caml_copy_string(li.loc_filename);
+ p = caml_alloc_small(5, 0);
+diff --git a/byterun/backtrace.h b/byterun/backtrace.h
+index 25fbfb2..c7b4d8e 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 @@ CAMLprim value caml_record_backtrace(value vflag);
+ 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 8cb25e6..f774b05 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 e0c5b36..4bd6b16 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 55be64e..5835feb 100644
+--- a/byterun/startup.c
++++ b/byterun/startup.c
+@@ -399,6 +399,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 cbea117..361a356 100644
+--- a/otherlibs/dynlink/dynlink.ml
++++ b/otherlibs/dynlink/dynlink.ml
+@@ -188,6 +188,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/toplevel/topdirs.ml b/toplevel/topdirs.ml
+index 50cbc4e..10f5ef2 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 ->
++ record_backtrace ();
+ may_trace := false;
+ Symtable.restore_state initial_symtable;
+ print_exception_outcome ppf exn;
+@@ -301,4 +309,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 "record_backtrace"
++ (Directive_bool(fun b -> Printexc.record_backtrace b))
+diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml
+index 42f4a84..485e8c9 100644
+--- a/toplevel/toploop.ml
++++ b/toplevel/toploop.ml
+@@ -114,6 +114,12 @@ 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 = ref None
++
++let record_backtrace () =
++ if Printexc.backtrace_status ()
++ then backtrace := Some (Printexc.get_backtrace ())
++
+ let load_lambda ppf lam =
+ if !Clflags.dump_rawlambda then fprintf ppf "%a@." Printlambda.lambda lam;
+ let slam = Simplif.simplify_lambda lam in
+@@ -123,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;
+@@ -134,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 ->
++ record_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;
+@@ -204,7 +214,14 @@ 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_status ()
++ then
++ match !backtrace with
++ | None -> ()
++ | Some b ->
++ print_string b;
++ backtrace := None
+
+ (* The table of toplevel directives.
+ Filled by functions from module topdirs. *)
+@@ -249,6 +266,15 @@ let execute_phrase print_outcome ppf phr =
+ Ophr_exception (exn, outv)
+ in
+ !print_out_phrase ppf out_phr;
++ if Printexc.backtrace_status ()
++ then begin
++ match !backtrace with
++ | None -> ()
++ | Some b ->
++ pp_print_string ppf b;
++ pp_print_flush ppf ();
++ backtrace := None;
++ 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 06c7d71..1e53559 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 record_backtrace: unit -> unit
+
+ (* Printing of values *)
+
12 patch2-3.11.1
View
@@ -0,0 +1,12 @@
+diff --git a/bytecomp/meta.mli b/bytecomp/meta.mli
+index 0cbe85a..8c33f61 100644
+--- a/bytecomp/meta.mli
++++ b/bytecomp/meta.mli
+@@ -26,3 +26,7 @@ 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"
Please sign in to comment.
Something went wrong with that request. Please try again.