Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 652 lines (616 sloc) 22.308 kb
603e7f1 patch for 3.11.1
Jake Donham authored
1 diff --git a/.depend b/.depend
2 index b52df95..d8dbad3 100644
3 --- a/.depend
4 +++ b/.depend
5 @@ -295,7 +295,7 @@ bytecomp/lambda.cmi: typing/types.cmi typing/primitive.cmi typing/path.cmi \
6 parsing/location.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi
7 bytecomp/matching.cmi: typing/typedtree.cmi parsing/location.cmi \
8 bytecomp/lambda.cmi typing/ident.cmi parsing/asttypes.cmi
9 -bytecomp/meta.cmi:
10 +bytecomp/meta.cmi: bytecomp/instruct.cmi
11 bytecomp/printinstr.cmi: bytecomp/instruct.cmi
12 bytecomp/printlambda.cmi: bytecomp/lambda.cmi
13 bytecomp/runtimedef.cmi:
14 @@ -384,8 +384,8 @@ bytecomp/matching.cmx: typing/types.cmx bytecomp/typeopt.cmx \
15 parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \
16 utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
17 bytecomp/matching.cmi
18 -bytecomp/meta.cmo: bytecomp/meta.cmi
19 -bytecomp/meta.cmx: bytecomp/meta.cmi
20 +bytecomp/meta.cmo: bytecomp/instruct.cmi bytecomp/meta.cmi
21 +bytecomp/meta.cmx: bytecomp/instruct.cmx bytecomp/meta.cmi
22 bytecomp/opcodes.cmo:
23 bytecomp/opcodes.cmx:
24 bytecomp/printinstr.cmo: bytecomp/printlambda.cmi parsing/location.cmi \
25 diff --git a/Makefile b/Makefile
26 index c33a268..4e6bf74 100644
27 --- a/Makefile
28 +++ b/Makefile
29 @@ -19,8 +19,8 @@ include stdlib/StdlibModules
30
31 CAMLC=boot/ocamlrun boot/ocamlc -nostdlib -I boot
32 CAMLOPT=boot/ocamlrun ./ocamlopt -nostdlib -I stdlib -I otherlibs/dynlink
33 -COMPFLAGS=-warn-error A $(INCLUDES)
34 -LINKFLAGS=
35 +COMPFLAGS=-g -warn-error A $(INCLUDES)
36 +LINKFLAGS=-g
37
38 CAMLYACC=boot/ocamlyacc
39 YACCFLAGS=-v
40 diff --git a/asmrun/backtrace.c b/asmrun/backtrace.c
41 index 61e8d36..3db2f06 100644
42 --- a/asmrun/backtrace.c
43 +++ b/asmrun/backtrace.c
44 @@ -223,3 +223,12 @@ CAMLprim value caml_get_exception_backtrace(value unit)
45 CAMLreturn(res);
46 }
47
48 +CAMLprim value caml_add_debug_info(code_t start, value size, value events)
49 +{
50 + return Val_unit;
51 +}
52 +
53 +CAMLprim value caml_remove_debug_info(code_t start, value size, value events)
54 +{
55 + return Val_unit;
56 +}
57 diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml
58 index f607e7c..0da2e69 100644
59 --- a/bytecomp/emitcode.ml
60 +++ b/bytecomp/emitcode.ml
61 @@ -395,8 +395,9 @@ let to_memory init_code fun_code =
62 String.unsafe_blit !out_buffer 0 code 0 !out_position;
63 let reloc = List.rev !reloc_info
64 and code_size = !out_position in
65 + let events = !events in
66 init();
67 - (code, code_size, reloc)
68 + (code, code_size, reloc, events)
69
70 (* Emission to a file for a packed library *)
71
72 diff --git a/bytecomp/emitcode.mli b/bytecomp/emitcode.mli
73 index 5a09293..742009c 100644
74 --- a/bytecomp/emitcode.mli
75 +++ b/bytecomp/emitcode.mli
76 @@ -23,7 +23,7 @@ val to_file: out_channel -> string -> instruction list -> unit
77 name of compilation unit implemented
78 list of instructions to emit *)
79 val to_memory: instruction list -> instruction list ->
80 - string * int * (reloc_info * int) list
81 + string * int * (reloc_info * int) list * debug_event list
82 (* Arguments:
83 initialization code (terminated by STOP)
84 function code
85 diff --git a/bytecomp/meta.ml b/bytecomp/meta.ml
86 index 08cf707..bd5ebef 100644
87 --- a/bytecomp/meta.ml
88 +++ b/bytecomp/meta.ml
89 @@ -24,3 +24,7 @@ external invoke_traced_function : Obj.t -> Obj.t -> Obj.t -> Obj.t
90 = "caml_invoke_traced_function"
91 external get_section_table : unit -> (string * Obj.t) list
92 = "caml_get_section_table"
93 +external add_debug_info : string -> int -> Instruct.debug_event list array -> unit
94 + = "caml_add_debug_info"
95 +external remove_debug_info : string -> unit
96 + = "caml_remove_debug_info"
97 diff --git a/byterun/backtrace.c b/byterun/backtrace.c
98 index eb240fc..2c80eb3 100644
99 --- a/byterun/backtrace.c
100 +++ b/byterun/backtrace.c
101 @@ -39,6 +39,7 @@ CAMLexport int caml_backtrace_active = 0;
102 CAMLexport int caml_backtrace_pos = 0;
103 CAMLexport code_t * caml_backtrace_buffer = NULL;
104 CAMLexport value caml_backtrace_last_exn = Val_unit;
105 +CAMLexport value caml_debug_info = Val_emptylist;
106 #define BACKTRACE_BUFFER_SIZE 1024
107
108 /* Location of fields in the Instruct.debug_event record */
109 @@ -60,6 +61,49 @@ enum {
110 POS_CNUM = 3
111 };
112
113 +/* Location of fields in the caml_debug_info records */;
114 +enum {
115 + DI_START = 0,
116 + DI_SIZE = 1,
117 + DI_EVENTS = 2
118 +};
119 +
120 +CAMLprim value caml_add_debug_info(code_t start, value size, value events)
121 +{
122 + CAMLparam1(events);
123 + CAMLlocal1(debug_info);
124 + debug_info = caml_alloc(3, 0);
125 + Store_field(debug_info, DI_START, (value)start);
126 + Store_field(debug_info, DI_SIZE, size);
127 + Store_field(debug_info, DI_EVENTS, events);
128 + value cons = caml_alloc(2, 0);
129 + Store_field(cons, 0, debug_info);
130 + Store_field(cons, 1, caml_debug_info);
131 + caml_debug_info = cons;
132 + CAMLreturn(Val_unit);
133 +}
134 +
135 +CAMLprim value caml_remove_debug_info(code_t start)
136 +{
137 + CAMLparam0();
138 + value dis = caml_debug_info;
139 + value prev = 0;
140 + while (dis != Val_emptylist) {
141 + value di = Field(dis, 0);
142 + code_t di_start = (code_t)Field(di, DI_START);
143 + if (di_start == start) {
144 + if (prev)
145 + Store_field(prev, 1, Field(dis, 1));
146 + else
147 + caml_debug_info = Field(dis, 1);
148 + break;
149 + }
150 + prev = di;
151 + dis = Field(dis, 1);
152 + }
153 + CAMLreturn(Val_unit);
154 +}
155 +
156 /* Start or stop the backtrace machinery */
157
158 CAMLprim value caml_record_backtrace(value vflag)
159 @@ -93,7 +137,6 @@ CAMLprim value caml_backtrace_status(value vunit)
160
161 void caml_stash_backtrace(value exn, code_t pc, value * sp)
162 {
163 - code_t end_code = (code_t) ((char *) caml_start_code + caml_code_size);
164 if (pc != NULL) pc = pc - 1;
165 if (exn != caml_backtrace_last_exn) {
166 caml_backtrace_pos = 0;
167 @@ -104,14 +147,30 @@ void caml_stash_backtrace(value exn, code_t pc, value * sp)
168 if (caml_backtrace_buffer == NULL) return;
169 }
170 if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) return;
171 - if (pc >= caml_start_code && pc < end_code){
172 - caml_backtrace_buffer[caml_backtrace_pos++] = pc;
173 + value dis = caml_debug_info;
174 + while (dis != Val_emptylist) {
175 + value di = Field(dis, 0);
176 + code_t start = (code_t)Field(di, DI_START);
177 + code_t end = (code_t) ((char *) start + Int_val(Field(di, DI_SIZE)));
178 + if (pc >= start && pc < end){
179 + caml_backtrace_buffer[caml_backtrace_pos++] = pc;
180 + break;
181 + }
182 + dis = Field(dis, 1);
183 }
184 for (/*nothing*/; sp < caml_trapsp; sp++) {
185 + if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) break;
186 code_t p = (code_t) *sp;
187 - if (p >= caml_start_code && p < end_code) {
188 - if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) break;
189 + value dis = caml_debug_info;
190 + while (dis != Val_emptylist) {
191 + value di = Field(dis, 0);
192 + code_t start = (code_t)Field(di, DI_START);
193 + code_t end = (code_t) ((char *) start + Int_val(Field(di, DI_SIZE)));
194 + if (p >= start && p < end) {
195 caml_backtrace_buffer[caml_backtrace_pos++] = p;
196 + break;
197 + }
198 + dis = Field(dis, 1);
199 }
200 }
201 }
202 @@ -124,64 +183,72 @@ void caml_stash_backtrace(value exn, code_t pc, value * sp)
203 #define O_BINARY 0
204 #endif
205
206 -static value read_debug_info(void)
207 +CAMLexport void caml_read_debug_info(int fd, struct exec_trailer *trail)
208 {
209 CAMLparam0();
210 CAMLlocal1(events);
211 - char * exec_name;
212 - int fd;
213 - struct exec_trailer trail;
214 struct channel * chan;
215 uint32 num_events, orig, i;
216 value evl, l;
217
218 - exec_name = caml_exe_name;
219 - fd = caml_attempt_open(&exec_name, &trail, 1);
220 - if (fd < 0) CAMLreturn(Val_false);
221 - caml_read_section_descriptors(fd, &trail);
222 - if (caml_seek_optional_section(fd, &trail, "DBUG") == -1) {
223 - close(fd);
224 - CAMLreturn(Val_false);
225 - }
226 - chan = caml_open_descriptor_in(fd);
227 - num_events = caml_getword(chan);
228 - events = caml_alloc(num_events, 0);
229 - for (i = 0; i < num_events; i++) {
230 - orig = caml_getword(chan);
231 - evl = caml_input_val(chan);
232 - /* Relocate events in event list */
233 - for (l = evl; l != Val_int(0); l = Field(l, 1)) {
234 - value ev = Field(l, 0);
235 - Field(ev, EV_POS) = Val_long(Long_val(Field(ev, EV_POS)) + orig);
236 + caml_register_global_root(&caml_debug_info);
237 +
238 + if (caml_seek_optional_section(fd, trail, "DBUG") == -1)
239 + events = caml_alloc(0, 0);
240 +
241 + else {
242 + chan = caml_open_descriptor_in(fd);
243 + num_events = caml_getword(chan);
244 + events = caml_alloc(num_events, 0);
245 + for (i = 0; i < num_events; i++) {
246 + orig = caml_getword(chan);
247 + evl = caml_input_val_(chan, 1);
248 + /* Relocate events in event list */
249 + for (l = evl; l != Val_int(0); l = Field(l, 1)) {
250 + value ev = Field(l, 0);
251 + Field(ev, EV_POS) = Val_long(Long_val(Field(ev, EV_POS)) + orig);
252 + }
253 + /* Record event list */
254 + Store_field(events, i, evl);
255 }
256 - /* Record event list */
257 - Store_field(events, i, evl);
258 + caml_release_channel(chan);
259 }
260 - caml_close_channel(chan);
261 - CAMLreturn(events);
262 +
263 + caml_add_debug_info(caml_start_code, Val_int(caml_code_size), events);
264 + CAMLreturn0;
265 }
266
267 /* Search the event for the given PC. Return Val_false if not found. */
268
269 -static value event_for_location(value events, code_t pc)
270 +static value event_for_location(code_t pc)
271 {
272 mlsize_t i;
273 value pos, l, ev, ev_pos, best_ev;
274
275 best_ev = 0;
276 - Assert(pc >= caml_start_code && pc < caml_start_code + caml_code_size);
277 - pos = Val_long((char *) pc - (char *) caml_start_code);
278 - for (i = 0; i < Wosize_val(events); i++) {
279 - for (l = Field(events, i); l != Val_int(0); l = Field(l, 1)) {
280 - ev = Field(l, 0);
281 - ev_pos = Field(ev, EV_POS);
282 - if (ev_pos == pos) return ev;
283 - /* ocamlc sometimes moves an event past a following PUSH instruction;
284 - allow mismatch by 1 instruction. */
285 - if (ev_pos == pos + 8) best_ev = ev;
286 + value dis = caml_debug_info;
287 + while (dis != Val_emptylist) {
288 + value di = Field(dis, 0);
289 + code_t start = (code_t)Field(di, DI_START);
290 + code_t end = (code_t) ((char *) start + Int_val(Field(di, DI_SIZE)));
291 + if (start <= pc && pc < end) {
292 + value events = Field(di, DI_EVENTS);
293 + pos = Val_long((char *) pc - (char *) start);
294 + for (i = 0; i < Wosize_val(events); i++) {
295 + for (l = Field(events, i); l != Val_int(0); l = Field(l, 1)) {
296 + ev = Field(l, 0);
297 + ev_pos = Field(ev, EV_POS);
298 + if (ev_pos == pos) return ev;
299 + /* ocamlc sometimes moves an event past a following PUSH instruction;
300 + allow mismatch by 1 instruction. */
301 + if (ev_pos == pos + 8) best_ev = ev;
302 + }
303 + }
304 + if (best_ev != 0) return best_ev;
305 + return Val_false;
306 }
307 + dis = Field(dis, 1);
308 }
309 - if (best_ev != 0) return best_ev;
310 return Val_false;
311 }
312
313 @@ -196,12 +263,12 @@ struct loc_info {
314 int loc_endchr;
315 };
316
317 -static void extract_location_info(value events, code_t pc,
318 +static void extract_location_info(code_t pc,
319 /*out*/ struct loc_info * li)
320 {
321 value ev, ev_start;
322
323 - ev = event_for_location(events, pc);
324 + ev = event_for_location(pc);
325 li->loc_is_raise = caml_is_instruction(*pc, RAISE);
326 if (ev == Val_false) {
327 li->loc_valid = 0;
328 @@ -253,18 +320,16 @@ static void print_location(struct loc_info * li, int index)
329
330 CAMLexport void caml_print_exception_backtrace(void)
331 {
332 - value events;
333 int i;
334 struct loc_info li;
335
336 - events = read_debug_info();
337 - if (events == Val_false) {
338 + if (caml_debug_info == Val_emptylist) {
339 fprintf(stderr,
340 "(Program not linked with -g, cannot print stack backtrace)\n");
341 return;
342 }
343 for (i = 0; i < caml_backtrace_pos; i++) {
344 - extract_location_info(events, caml_backtrace_buffer[i], &li);
345 + extract_location_info(caml_backtrace_buffer[i], &li);
346 print_location(&li, i);
347 }
348 }
349 @@ -274,17 +339,16 @@ CAMLexport void caml_print_exception_backtrace(void)
350 CAMLprim value caml_get_exception_backtrace(value unit)
351 {
352 CAMLparam0();
353 - CAMLlocal5(events, res, arr, p, fname);
354 + CAMLlocal4(res, arr, p, fname);
355 int i;
356 struct loc_info li;
357
358 - events = read_debug_info();
359 - if (events == Val_false) {
360 + if (caml_debug_info == Val_emptylist) {
361 res = Val_int(0); /* None */
362 } else {
363 arr = caml_alloc(caml_backtrace_pos, 0);
364 for (i = 0; i < caml_backtrace_pos; i++) {
365 - extract_location_info(events, caml_backtrace_buffer[i], &li);
366 + extract_location_info(caml_backtrace_buffer[i], &li);
367 if (li.loc_valid) {
368 fname = caml_copy_string(li.loc_filename);
369 p = caml_alloc_small(5, 0);
370 diff --git a/byterun/backtrace.h b/byterun/backtrace.h
371 index 25fbfb2..c7b4d8e 100644
372 --- a/byterun/backtrace.h
373 +++ b/byterun/backtrace.h
374 @@ -17,6 +17,7 @@
375 #define CAML_BACKTRACE_H
376
377 #include "mlvalues.h"
378 +#include "exec.h"
379
380 CAMLextern int caml_backtrace_active;
381 CAMLextern int caml_backtrace_pos;
382 @@ -28,5 +29,6 @@ CAMLprim value caml_record_backtrace(value vflag);
383 extern void caml_stash_backtrace(value exn, code_t pc, value * sp);
384 #endif
385 CAMLextern void caml_print_exception_backtrace(void);
386 +CAMLextern void caml_read_debug_info(int fd, struct exec_trailer *trail);
387
388 #endif /* CAML_BACKTRACE_H */
389 diff --git a/byterun/intern.c b/byterun/intern.c
390 index 8cb25e6..f774b05 100644
391 --- a/byterun/intern.c
392 +++ b/byterun/intern.c
393 @@ -324,7 +324,7 @@ static void intern_rec(value *dest)
394 *dest = v;
395 }
396
397 -static void intern_alloc(mlsize_t whsize, mlsize_t num_objects)
398 +static void intern_alloc_(mlsize_t whsize, mlsize_t num_objects, int out_of_heap)
399 {
400 mlsize_t wosize;
401
402 @@ -335,7 +335,7 @@ static void intern_alloc(mlsize_t whsize, mlsize_t num_objects)
403 return;
404 }
405 wosize = Wosize_whsize(whsize);
406 - if (wosize > Max_wosize) {
407 + if (wosize > Max_wosize || out_of_heap) {
408 /* Round desired size up to next page */
409 asize_t request =
410 ((Bsize_wsize(whsize) + Page_size - 1) >> Page_log) << Page_log;
411 @@ -367,6 +367,11 @@ static void intern_alloc(mlsize_t whsize, mlsize_t num_objects)
412 intern_obj_table = NULL;
413 }
414
415 +static void intern_alloc(mlsize_t whsize, mlsize_t num_objects)
416 +{
417 + intern_alloc_(whsize, num_objects, 0);
418 +}
419 +
420 static void intern_add_to_heap(mlsize_t whsize)
421 {
422 /* Add new heap chunk to heap if needed */
423 @@ -387,7 +392,7 @@ static void intern_add_to_heap(mlsize_t whsize)
424 }
425 }
426
427 -value caml_input_val(struct channel *chan)
428 +value caml_input_val_(struct channel *chan, int out_of_heap)
429 {
430 uint32 magic;
431 mlsize_t block_len, num_objects, size_32, size_64, whsize;
432 @@ -421,16 +426,22 @@ value caml_input_val(struct channel *chan)
433 #else
434 whsize = size_32;
435 #endif
436 - intern_alloc(whsize, num_objects);
437 + intern_alloc_(whsize, num_objects, out_of_heap);
438 /* Fill it in */
439 intern_rec(&res);
440 - intern_add_to_heap(whsize);
441 + if (!out_of_heap)
442 + intern_add_to_heap(whsize);
443 /* Free everything */
444 caml_stat_free(intern_input);
445 if (intern_obj_table != NULL) caml_stat_free(intern_obj_table);
446 return res;
447 }
448
449 +value caml_input_val(struct channel *chan)
450 +{
451 + return caml_input_val_(chan, 0);
452 +}
453 +
454 CAMLprim value caml_input_value(value vchan)
455 {
456 CAMLparam1 (vchan);
457 diff --git a/byterun/intext.h b/byterun/intext.h
458 index 7d8eb4c..a02713b 100644
459 --- a/byterun/intext.h
460 +++ b/byterun/intext.h
461 @@ -97,6 +97,7 @@ CAMLextern intnat caml_output_value_to_block(value v, value flags,
462 /* <private> */
463 value caml_input_val (struct channel * chan);
464 /* Read a structured value from the channel [chan]. */
465 +value caml_input_val_ (struct channel * chan, int out_of_heap);
466 /* </private> */
467
468 CAMLextern value caml_input_val_from_string (value str, intnat ofs);
469 diff --git a/byterun/io.c b/byterun/io.c
470 index 04b9746..58d2b07 100644
471 --- a/byterun/io.c
472 +++ b/byterun/io.c
473 @@ -103,6 +103,12 @@ static void unlink_channel(struct channel *channel)
474 CAMLexport void caml_close_channel(struct channel *channel)
475 {
476 close(channel->fd);
477 + caml_release_channel(channel);
478 +}
479 +
480 +/* release the channel but leave the file descriptor open */
481 +CAMLexport void caml_release_channel(struct channel *channel)
482 +{
483 if (channel->refcount > 0) return;
484 if (caml_channel_mutex_free != NULL) (*caml_channel_mutex_free)(channel);
485 unlink_channel(channel);
486 diff --git a/byterun/io.h b/byterun/io.h
487 index e0c5b36..4bd6b16 100644
488 --- a/byterun/io.h
489 +++ b/byterun/io.h
490 @@ -77,6 +77,7 @@ enum {
491 CAMLextern struct channel * caml_open_descriptor_in (int);
492 CAMLextern struct channel * caml_open_descriptor_out (int);
493 CAMLextern void caml_close_channel (struct channel *);
494 +CAMLextern void caml_release_channel (struct channel *);
495 CAMLextern int caml_channel_binary_mode (struct channel *);
496 CAMLextern value caml_alloc_channel(struct channel *chan);
497
498 diff --git a/byterun/startup.c b/byterun/startup.c
499 index 55be64e..5835feb 100644
500 --- a/byterun/startup.c
501 +++ b/byterun/startup.c
502 @@ -399,6 +399,7 @@ CAMLexport void caml_main(char **argv)
503 caml_stat_free(shared_lib_path);
504 caml_stat_free(shared_libs);
505 caml_stat_free(req_prims);
506 + caml_read_debug_info(fd, &trail);
507 /* Load the globals */
508 caml_seek_section(fd, &trail, "DATA");
509 chan = caml_open_descriptor_in(fd);
510 diff --git a/otherlibs/dynlink/dynlink.ml b/otherlibs/dynlink/dynlink.ml
511 index cbea117..361a356 100644
512 --- a/otherlibs/dynlink/dynlink.ml
513 +++ b/otherlibs/dynlink/dynlink.ml
514 @@ -188,6 +188,13 @@ let load_compunit ic file_name compunit =
515 | _ -> assert false in
516 raise(Error(Linking_error (file_name, new_error)))
517 end;
518 + let events =
519 + if compunit.cu_debug = 0 then [| |]
520 + else begin
521 + seek_in ic compunit.cu_debug;
522 + [| input_value ic |]
523 + end in
524 + Meta.add_debug_info code code_size events;
525 begin try
526 ignore((Meta.reify_bytecode code code_size) ())
527 with exn ->
528 diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml
529 index 50cbc4e..10f5ef2 100644
530 --- a/toplevel/topdirs.ml
531 +++ b/toplevel/topdirs.ml
532 @@ -74,11 +74,19 @@ let load_compunit ic filename ppf compunit =
533 let initial_symtable = Symtable.current_state() in
534 Symtable.patch_object code compunit.cu_reloc;
535 Symtable.update_global_table();
536 + let events =
537 + if compunit.cu_debug = 0 then [| |]
538 + else begin
539 + seek_in ic compunit.cu_debug;
540 + [| input_value ic |]
541 + end in
542 + Meta.add_debug_info code code_size events;
543 begin try
544 may_trace := true;
545 ignore((Meta.reify_bytecode code code_size) ());
546 may_trace := false;
547 with exn ->
548 + record_backtrace ();
549 may_trace := false;
550 Symtable.restore_state initial_symtable;
551 print_exception_outcome ppf exn;
552 @@ -301,4 +309,10 @@ let _ =
553 (Directive_string (parse_warnings std_out false));
554
555 Hashtbl.add directive_table "warn_error"
556 - (Directive_string (parse_warnings std_out true))
557 + (Directive_string (parse_warnings std_out true));
558 +
559 + Hashtbl.add directive_table "debug"
560 + (Directive_bool(fun b -> Clflags.debug := b));
561 +
562 + Hashtbl.add directive_table "record_backtrace"
563 + (Directive_bool(fun b -> Printexc.record_backtrace b))
564 diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml
565 index 42f4a84..485e8c9 100644
566 --- a/toplevel/toploop.ml
567 +++ b/toplevel/toploop.ml
568 @@ -114,6 +114,12 @@ let toplevel_startup_hook = ref (fun () -> ())
569 let may_trace = ref false (* Global lock on tracing *)
570 type evaluation_outcome = Result of Obj.t | Exception of exn
571
572 +let backtrace = ref None
573 +
574 +let record_backtrace () =
575 + if Printexc.backtrace_status ()
576 + then backtrace := Some (Printexc.get_backtrace ())
577 +
578 let load_lambda ppf lam =
579 if !Clflags.dump_rawlambda then fprintf ppf "%a@." Printlambda.lambda lam;
580 let slam = Simplif.simplify_lambda lam in
581 @@ -123,7 +129,8 @@ let load_lambda ppf lam =
582 fprintf ppf "%a%a@."
583 Printinstr.instrlist init_code
584 Printinstr.instrlist fun_code;
585 - let (code, code_size, reloc) = Emitcode.to_memory init_code fun_code in
586 + let (code, code_size, reloc, events) = Emitcode.to_memory init_code fun_code in
587 + Meta.add_debug_info code code_size [| events |];
588 let can_free = (fun_code = []) in
589 let initial_symtable = Symtable.current_state() in
590 Symtable.patch_object code reloc;
591 @@ -134,13 +141,16 @@ let load_lambda ppf lam =
592 let retval = (Meta.reify_bytecode code code_size) () in
593 may_trace := false;
594 if can_free then begin
595 + Meta.remove_debug_info code;
596 Meta.static_release_bytecode code code_size;
597 Meta.static_free code;
598 end;
599 Result retval
600 with x ->
601 + record_backtrace ();
602 may_trace := false;
603 if can_free then begin
604 + Meta.remove_debug_info code;
605 Meta.static_release_bytecode code code_size;
606 Meta.static_free code;
607 end;
608 @@ -204,7 +214,14 @@ let print_out_exception ppf exn outv =
609 let print_exception_outcome ppf exn =
610 if exn = Out_of_memory then Gc.full_major ();
611 let outv = outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn in
612 - print_out_exception ppf exn outv
613 + print_out_exception ppf exn outv;
614 + if Printexc.backtrace_status ()
615 + then
616 + match !backtrace with
617 + | None -> ()
618 + | Some b ->
619 + print_string b;
620 + backtrace := None
621
622 (* The table of toplevel directives.
623 Filled by functions from module topdirs. *)
624 @@ -249,6 +266,15 @@ let execute_phrase print_outcome ppf phr =
625 Ophr_exception (exn, outv)
626 in
627 !print_out_phrase ppf out_phr;
628 + if Printexc.backtrace_status ()
629 + then begin
630 + match !backtrace with
631 + | None -> ()
632 + | Some b ->
633 + pp_print_string ppf b;
634 + pp_print_flush ppf ();
635 + backtrace := None;
636 + end;
637 begin match out_phr with
638 | Ophr_eval (_, _) | Ophr_signature _ -> true
639 | Ophr_exception _ -> false
640 diff --git a/toplevel/toploop.mli b/toplevel/toploop.mli
641 index 06c7d71..1e53559 100644
642 --- a/toplevel/toploop.mli
643 +++ b/toplevel/toploop.mli
644 @@ -62,6 +62,7 @@ val use_silently : formatter -> string -> bool
645 [use_silently] does not print them. *)
646 val eval_path: Path.t -> Obj.t
647 (* Return the toplevel object referred to by the given path *)
648 +val record_backtrace: unit -> unit
649
650 (* Printing of values *)
651
Something went wrong with that request. Please try again.