Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 654 lines (618 sloc) 22.263 kb
4d08635 cleaned up patch, split out post-boostrap part
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 80c6824..548cbcf 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 a875822..228f6e6 100644
42 --- a/asmrun/backtrace.c
43 +++ b/asmrun/backtrace.c
44 @@ -223,3 +223,12 @@ CAMLprim value caml_get_exception_backtrace(value unit)
8076b51 original patch for 3.11.2
Jake Donham authored
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 +}
4d08635 cleaned up patch, split out post-boostrap part
Jake Donham authored
57 diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml
58 index 755873d..11cbce7 100644
59 --- a/bytecomp/emitcode.ml
60 +++ b/bytecomp/emitcode.ml
61 @@ -395,8 +395,9 @@ let to_memory init_code fun_code =
8076b51 original patch for 3.11.2
Jake Donham authored
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
4d08635 cleaned up patch, split out post-boostrap part
Jake Donham authored
72 diff --git a/bytecomp/emitcode.mli b/bytecomp/emitcode.mli
73 index 6c78f04..7d7f71c 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
8076b51 original patch for 3.11.2
Jake Donham authored
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
4d08635 cleaned up patch, split out post-boostrap part
Jake Donham authored
85 diff --git a/bytecomp/meta.ml b/bytecomp/meta.ml
86 index 3e2cdeb..53cd883 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
8076b51 original patch for 3.11.2
Jake Donham authored
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"
4d08635 cleaned up patch, split out post-boostrap part
Jake Donham authored
97 diff --git a/byterun/backtrace.c b/byterun/backtrace.c
98 index 304fe44..2d593af 100644
99 --- a/byterun/backtrace.c
100 +++ b/byterun/backtrace.c
101 @@ -39,6 +39,7 @@ CAMLexport int caml_backtrace_active = 0;
8076b51 original patch for 3.11.2
Jake Donham authored
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 CAMLexport char * caml_cds_file = NULL;
107 #define BACKTRACE_BUFFER_SIZE 1024
108
4d08635 cleaned up patch, split out post-boostrap part
Jake Donham authored
109 @@ -61,6 +62,49 @@ enum {
8076b51 original patch for 3.11.2
Jake Donham authored
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)
4d08635 cleaned up patch, split out post-boostrap part
Jake Donham authored
159 @@ -94,7 +138,6 @@ CAMLprim value caml_backtrace_status(value vunit)
8076b51 original patch for 3.11.2
Jake Donham authored
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;
4d08635 cleaned up patch, split out post-boostrap part
Jake Donham authored
167 @@ -105,14 +148,30 @@ void caml_stash_backtrace(value exn, code_t pc, value * sp)
8076b51 original patch for 3.11.2
Jake Donham authored
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);
78d904c oops, add code size in bytes
Jake Donham authored
177 + code_t end = (code_t) ((char *) start + Int_val(Field(di, DI_SIZE)));
8076b51 original patch for 3.11.2
Jake Donham authored
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);
78d904c oops, add code size in bytes
Jake Donham authored
193 + code_t end = (code_t) ((char *) start + Int_val(Field(di, DI_SIZE)));
8076b51 original patch for 3.11.2
Jake Donham authored
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 }
4d08635 cleaned up patch, split out post-boostrap part
Jake Donham authored
202 @@ -125,68 +184,72 @@ void caml_stash_backtrace(value exn, code_t pc, value * sp)
8076b51 original patch for 3.11.2
Jake Donham authored
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 - if (caml_cds_file != NULL) {
219 - exec_name = caml_cds_file;
220 - } else {
221 - exec_name = caml_exe_name;
222 - }
223 - fd = caml_attempt_open(&exec_name, &trail, 1);
224 - if (fd < 0) CAMLreturn(Val_false);
225 - caml_read_section_descriptors(fd, &trail);
226 - if (caml_seek_optional_section(fd, &trail, "DBUG") == -1) {
227 - close(fd);
228 - CAMLreturn(Val_false);
229 - }
230 - chan = caml_open_descriptor_in(fd);
231 - num_events = caml_getword(chan);
232 - events = caml_alloc(num_events, 0);
233 - for (i = 0; i < num_events; i++) {
234 - orig = caml_getword(chan);
235 - evl = caml_input_val(chan);
236 - /* Relocate events in event list */
237 - for (l = evl; l != Val_int(0); l = Field(l, 1)) {
238 + caml_register_global_root(&caml_debug_info);
239 +
240 + if (caml_seek_optional_section(fd, trail, "DBUG") == -1)
241 + events = caml_alloc(0, 0);
242 +
243 + else {
244 + chan = caml_open_descriptor_in(fd);
245 + num_events = caml_getword(chan);
246 + events = caml_alloc(num_events, 0);
247 + for (i = 0; i < num_events; i++) {
248 + orig = caml_getword(chan);
4d08635 cleaned up patch, split out post-boostrap part
Jake Donham authored
249 + evl = caml_input_val_(chan, 1);
8076b51 original patch for 3.11.2
Jake Donham authored
250 + /* Relocate events in event list */
251 + for (l = evl; l != Val_int(0); l = Field(l, 1)) {
252 value ev = Field(l, 0);
253 Field(ev, EV_POS) = Val_long(Long_val(Field(ev, EV_POS)) + orig);
254 + }
255 + /* Record event list */
256 + Store_field(events, i, evl);
257 }
258 - /* Record event list */
259 - Store_field(events, i, evl);
260 + caml_release_channel(chan);
261 }
262 - caml_close_channel(chan);
263 - CAMLreturn(events);
264 +
265 + caml_add_debug_info(caml_start_code, Val_int(caml_code_size), events);
266 + CAMLreturn0;
267 }
268
269 /* Search the event for the given PC. Return Val_false if not found. */
270
271 -static value event_for_location(value events, code_t pc)
272 +static value event_for_location(code_t pc)
273 {
274 mlsize_t i;
275 value pos, l, ev, ev_pos, best_ev;
276
277 best_ev = 0;
278 - Assert(pc >= caml_start_code && pc < caml_start_code + caml_code_size);
279 - pos = Val_long((char *) pc - (char *) caml_start_code);
280 - for (i = 0; i < Wosize_val(events); i++) {
281 - for (l = Field(events, i); l != Val_int(0); l = Field(l, 1)) {
282 - ev = Field(l, 0);
283 - ev_pos = Field(ev, EV_POS);
284 - if (ev_pos == pos) return ev;
285 - /* ocamlc sometimes moves an event past a following PUSH instruction;
286 - allow mismatch by 1 instruction. */
287 - if (ev_pos == pos + 8) best_ev = ev;
288 + value dis = caml_debug_info;
289 + while (dis != Val_emptylist) {
290 + value di = Field(dis, 0);
291 + code_t start = (code_t)Field(di, DI_START);
78d904c oops, add code size in bytes
Jake Donham authored
292 + code_t end = (code_t) ((char *) start + Int_val(Field(di, DI_SIZE)));
8076b51 original patch for 3.11.2
Jake Donham authored
293 + if (start <= pc && pc < end) {
294 + value events = Field(di, DI_EVENTS);
295 + pos = Val_long((char *) pc - (char *) start);
296 + for (i = 0; i < Wosize_val(events); i++) {
297 + for (l = Field(events, i); l != Val_int(0); l = Field(l, 1)) {
298 + ev = Field(l, 0);
299 + ev_pos = Field(ev, EV_POS);
300 + if (ev_pos == pos) return ev;
301 + /* ocamlc sometimes moves an event past a following PUSH instruction;
302 + allow mismatch by 1 instruction. */
303 + if (ev_pos == pos + 8) best_ev = ev;
304 + }
305 + }
306 + if (best_ev != 0) return best_ev;
307 + return Val_false;
308 }
309 + dis = Field(dis, 1);
310 }
311 - if (best_ev != 0) return best_ev;
312 return Val_false;
313 }
314
4d08635 cleaned up patch, split out post-boostrap part
Jake Donham authored
315 @@ -201,12 +264,12 @@ struct loc_info {
8076b51 original patch for 3.11.2
Jake Donham authored
316 int loc_endchr;
317 };
318
319 -static void extract_location_info(value events, code_t pc,
320 +static void extract_location_info(code_t pc,
321 /*out*/ struct loc_info * li)
322 {
323 value ev, ev_start;
324
325 - ev = event_for_location(events, pc);
326 + ev = event_for_location(pc);
327 li->loc_is_raise = caml_is_instruction(*pc, RAISE);
328 if (ev == Val_false) {
329 li->loc_valid = 0;
4d08635 cleaned up patch, split out post-boostrap part
Jake Donham authored
330 @@ -258,18 +321,16 @@ static void print_location(struct loc_info * li, int index)
8076b51 original patch for 3.11.2
Jake Donham authored
331
332 CAMLexport void caml_print_exception_backtrace(void)
333 {
334 - value events;
335 int i;
336 struct loc_info li;
337
338 - events = read_debug_info();
339 - if (events == Val_false) {
340 + if (caml_debug_info == Val_emptylist) {
341 fprintf(stderr,
342 "(Program not linked with -g, cannot print stack backtrace)\n");
343 return;
344 }
345 for (i = 0; i < caml_backtrace_pos; i++) {
346 - extract_location_info(events, caml_backtrace_buffer[i], &li);
347 + extract_location_info(caml_backtrace_buffer[i], &li);
348 print_location(&li, i);
349 }
350 }
4d08635 cleaned up patch, split out post-boostrap part
Jake Donham authored
351 @@ -279,17 +340,16 @@ CAMLexport void caml_print_exception_backtrace(void)
8076b51 original patch for 3.11.2
Jake Donham authored
352 CAMLprim value caml_get_exception_backtrace(value unit)
353 {
354 CAMLparam0();
355 - CAMLlocal5(events, res, arr, p, fname);
356 + CAMLlocal4(res, arr, p, fname);
357 int i;
358 struct loc_info li;
359
360 - events = read_debug_info();
361 - if (events == Val_false) {
362 + if (caml_debug_info == Val_emptylist) {
363 res = Val_int(0); /* None */
364 } else {
365 arr = caml_alloc(caml_backtrace_pos, 0);
366 for (i = 0; i < caml_backtrace_pos; i++) {
367 - extract_location_info(events, caml_backtrace_buffer[i], &li);
368 + extract_location_info(caml_backtrace_buffer[i], &li);
369 if (li.loc_valid) {
370 fname = caml_copy_string(li.loc_filename);
371 p = caml_alloc_small(5, 0);
4d08635 cleaned up patch, split out post-boostrap part
Jake Donham authored
372 diff --git a/byterun/backtrace.h b/byterun/backtrace.h
373 index f3327d0..ef39061 100644
374 --- a/byterun/backtrace.h
375 +++ b/byterun/backtrace.h
8076b51 original patch for 3.11.2
Jake Donham authored
376 @@ -17,6 +17,7 @@
377 #define CAML_BACKTRACE_H
378
379 #include "mlvalues.h"
380 +#include "exec.h"
381
382 CAMLextern int caml_backtrace_active;
383 CAMLextern int caml_backtrace_pos;
4d08635 cleaned up patch, split out post-boostrap part
Jake Donham authored
384 @@ -29,5 +30,6 @@ CAMLprim value caml_record_backtrace(value vflag);
8076b51 original patch for 3.11.2
Jake Donham authored
385 extern void caml_stash_backtrace(value exn, code_t pc, value * sp);
386 #endif
387 CAMLextern void caml_print_exception_backtrace(void);
388 +CAMLextern void caml_read_debug_info(int fd, struct exec_trailer *trail);
389
390 #endif /* CAML_BACKTRACE_H */
4d08635 cleaned up patch, split out post-boostrap part
Jake Donham authored
391 diff --git a/byterun/intern.c b/byterun/intern.c
392 index 78972f6..7361a67 100644
393 --- a/byterun/intern.c
394 +++ b/byterun/intern.c
395 @@ -324,7 +324,7 @@ static void intern_rec(value *dest)
396 *dest = v;
397 }
398
399 -static void intern_alloc(mlsize_t whsize, mlsize_t num_objects)
400 +static void intern_alloc_(mlsize_t whsize, mlsize_t num_objects, int out_of_heap)
401 {
402 mlsize_t wosize;
403
404 @@ -335,7 +335,7 @@ static void intern_alloc(mlsize_t whsize, mlsize_t num_objects)
405 return;
406 }
407 wosize = Wosize_whsize(whsize);
408 - if (wosize > Max_wosize) {
409 + if (wosize > Max_wosize || out_of_heap) {
410 /* Round desired size up to next page */
411 asize_t request =
412 ((Bsize_wsize(whsize) + Page_size - 1) >> Page_log) << Page_log;
413 @@ -367,6 +367,11 @@ static void intern_alloc(mlsize_t whsize, mlsize_t num_objects)
414 intern_obj_table = NULL;
415 }
416
417 +static void intern_alloc(mlsize_t whsize, mlsize_t num_objects)
418 +{
419 + intern_alloc_(whsize, num_objects, 0);
420 +}
421 +
422 static void intern_add_to_heap(mlsize_t whsize)
423 {
424 /* Add new heap chunk to heap if needed */
425 @@ -387,7 +392,7 @@ static void intern_add_to_heap(mlsize_t whsize)
426 }
427 }
428
429 -value caml_input_val(struct channel *chan)
430 +value caml_input_val_(struct channel *chan, int out_of_heap)
431 {
432 uint32 magic;
433 mlsize_t block_len, num_objects, size_32, size_64, whsize;
434 @@ -421,16 +426,22 @@ value caml_input_val(struct channel *chan)
435 #else
436 whsize = size_32;
437 #endif
438 - intern_alloc(whsize, num_objects);
439 + intern_alloc_(whsize, num_objects, out_of_heap);
440 /* Fill it in */
441 intern_rec(&res);
442 - intern_add_to_heap(whsize);
443 + if (!out_of_heap)
444 + intern_add_to_heap(whsize);
445 /* Free everything */
446 caml_stat_free(intern_input);
447 if (intern_obj_table != NULL) caml_stat_free(intern_obj_table);
448 return res;
449 }
450
451 +value caml_input_val(struct channel *chan)
452 +{
453 + return caml_input_val_(chan, 0);
454 +}
455 +
456 CAMLprim value caml_input_value(value vchan)
457 {
458 CAMLparam1 (vchan);
459 diff --git a/byterun/intext.h b/byterun/intext.h
460 index de0ef68..93642ba 100644
461 --- a/byterun/intext.h
462 +++ b/byterun/intext.h
463 @@ -97,6 +97,7 @@ CAMLextern intnat caml_output_value_to_block(value v, value flags,
464 /* <private> */
465 value caml_input_val (struct channel * chan);
466 /* Read a structured value from the channel [chan]. */
467 +value caml_input_val_ (struct channel * chan, int out_of_heap);
468 /* </private> */
469
470 CAMLextern value caml_input_val_from_string (value str, intnat ofs);
471 diff --git a/byterun/io.c b/byterun/io.c
472 index c72fc4d..f9feb82 100644
473 --- a/byterun/io.c
474 +++ b/byterun/io.c
475 @@ -103,6 +103,12 @@ static void unlink_channel(struct channel *channel)
8076b51 original patch for 3.11.2
Jake Donham authored
476 CAMLexport void caml_close_channel(struct channel *channel)
477 {
478 close(channel->fd);
479 + caml_release_channel(channel);
480 +}
481 +
482 +/* release the channel but leave the file descriptor open */
483 +CAMLexport void caml_release_channel(struct channel *channel)
484 +{
485 if (channel->refcount > 0) return;
486 if (caml_channel_mutex_free != NULL) (*caml_channel_mutex_free)(channel);
487 unlink_channel(channel);
4d08635 cleaned up patch, split out post-boostrap part
Jake Donham authored
488 diff --git a/byterun/io.h b/byterun/io.h
489 index e43d5ec..a0c12fc 100644
490 --- a/byterun/io.h
491 +++ b/byterun/io.h
492 @@ -77,6 +77,7 @@ enum {
8076b51 original patch for 3.11.2
Jake Donham authored
493 CAMLextern struct channel * caml_open_descriptor_in (int);
494 CAMLextern struct channel * caml_open_descriptor_out (int);
495 CAMLextern void caml_close_channel (struct channel *);
496 +CAMLextern void caml_release_channel (struct channel *);
497 CAMLextern int caml_channel_binary_mode (struct channel *);
498 CAMLextern value caml_alloc_channel(struct channel *chan);
499
4d08635 cleaned up patch, split out post-boostrap part
Jake Donham authored
500 diff --git a/byterun/startup.c b/byterun/startup.c
501 index ecddfe4..3c9441a 100644
502 --- a/byterun/startup.c
503 +++ b/byterun/startup.c
504 @@ -399,6 +399,7 @@ CAMLexport void caml_main(char **argv)
8076b51 original patch for 3.11.2
Jake Donham authored
505 caml_stat_free(shared_lib_path);
506 caml_stat_free(shared_libs);
507 caml_stat_free(req_prims);
508 + caml_read_debug_info(fd, &trail);
509 /* Load the globals */
510 caml_seek_section(fd, &trail, "DATA");
511 chan = caml_open_descriptor_in(fd);
4d08635 cleaned up patch, split out post-boostrap part
Jake Donham authored
512 diff --git a/otherlibs/dynlink/dynlink.ml b/otherlibs/dynlink/dynlink.ml
513 index e340615..40f8979 100644
514 --- a/otherlibs/dynlink/dynlink.ml
515 +++ b/otherlibs/dynlink/dynlink.ml
516 @@ -188,6 +188,13 @@ let load_compunit ic file_name compunit =
8076b51 original patch for 3.11.2
Jake Donham authored
517 | _ -> assert false in
518 raise(Error(Linking_error (file_name, new_error)))
519 end;
520 + let events =
521 + if compunit.cu_debug = 0 then [| |]
522 + else begin
523 + seek_in ic compunit.cu_debug;
524 + [| input_value ic |]
525 + end in
526 + Meta.add_debug_info code code_size events;
527 begin try
528 ignore((Meta.reify_bytecode code code_size) ())
529 with exn ->
4d08635 cleaned up patch, split out post-boostrap part
Jake Donham authored
530 diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml
531 index d45b4f7..363e419 100644
532 --- a/toplevel/topdirs.ml
533 +++ b/toplevel/topdirs.ml
534 @@ -74,11 +74,19 @@ let load_compunit ic filename ppf compunit =
8076b51 original patch for 3.11.2
Jake Donham authored
535 let initial_symtable = Symtable.current_state() in
536 Symtable.patch_object code compunit.cu_reloc;
537 Symtable.update_global_table();
538 + let events =
539 + if compunit.cu_debug = 0 then [| |]
540 + else begin
541 + seek_in ic compunit.cu_debug;
542 + [| input_value ic |]
543 + end in
544 + Meta.add_debug_info code code_size events;
545 begin try
546 may_trace := true;
547 ignore((Meta.reify_bytecode code code_size) ());
548 may_trace := false;
549 with exn ->
550 + record_backtrace ();
551 may_trace := false;
552 Symtable.restore_state initial_symtable;
553 print_exception_outcome ppf exn;
4d08635 cleaned up patch, split out post-boostrap part
Jake Donham authored
554 @@ -301,4 +309,10 @@ let _ =
8076b51 original patch for 3.11.2
Jake Donham authored
555 (Directive_string (parse_warnings std_out false));
556
557 Hashtbl.add directive_table "warn_error"
558 - (Directive_string (parse_warnings std_out true))
559 + (Directive_string (parse_warnings std_out true));
560 +
561 + Hashtbl.add directive_table "debug"
562 + (Directive_bool(fun b -> Clflags.debug := b));
563 +
564 + Hashtbl.add directive_table "record_backtrace"
565 + (Directive_bool(fun b -> Printexc.record_backtrace b))
4d08635 cleaned up patch, split out post-boostrap part
Jake Donham authored
566 diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml
567 index 2a6ff83..898123b 100644
568 --- a/toplevel/toploop.ml
569 +++ b/toplevel/toploop.ml
570 @@ -114,6 +114,12 @@ let toplevel_startup_hook = ref (fun () -> ())
8076b51 original patch for 3.11.2
Jake Donham authored
571 let may_trace = ref false (* Global lock on tracing *)
572 type evaluation_outcome = Result of Obj.t | Exception of exn
573
574 +let backtrace = ref None
575 +
576 +let record_backtrace () =
577 + if Printexc.backtrace_status ()
578 + then backtrace := Some (Printexc.get_backtrace ())
579 +
580 let load_lambda ppf lam =
581 if !Clflags.dump_rawlambda then fprintf ppf "%a@." Printlambda.lambda lam;
582 let slam = Simplif.simplify_lambda lam in
4d08635 cleaned up patch, split out post-boostrap part
Jake Donham authored
583 @@ -123,7 +129,8 @@ let load_lambda ppf lam =
8076b51 original patch for 3.11.2
Jake Donham authored
584 fprintf ppf "%a%a@."
585 Printinstr.instrlist init_code
586 Printinstr.instrlist fun_code;
587 - let (code, code_size, reloc) = Emitcode.to_memory init_code fun_code in
588 + let (code, code_size, reloc, events) = Emitcode.to_memory init_code fun_code in
589 + Meta.add_debug_info code code_size [| events |];
590 let can_free = (fun_code = []) in
591 let initial_symtable = Symtable.current_state() in
592 Symtable.patch_object code reloc;
4d08635 cleaned up patch, split out post-boostrap part
Jake Donham authored
593 @@ -134,13 +141,16 @@ let load_lambda ppf lam =
8076b51 original patch for 3.11.2
Jake Donham authored
594 let retval = (Meta.reify_bytecode code code_size) () in
595 may_trace := false;
596 if can_free then begin
597 + Meta.remove_debug_info code;
598 Meta.static_release_bytecode code code_size;
599 Meta.static_free code;
600 end;
601 Result retval
602 with x ->
603 + record_backtrace ();
604 may_trace := false;
605 if can_free then begin
606 + Meta.remove_debug_info code;
607 Meta.static_release_bytecode code code_size;
608 Meta.static_free code;
609 end;
4d08635 cleaned up patch, split out post-boostrap part
Jake Donham authored
610 @@ -204,7 +214,14 @@ let print_out_exception ppf exn outv =
8076b51 original patch for 3.11.2
Jake Donham authored
611 let print_exception_outcome ppf exn =
612 if exn = Out_of_memory then Gc.full_major ();
613 let outv = outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn in
614 - print_out_exception ppf exn outv
615 + print_out_exception ppf exn outv;
616 + if Printexc.backtrace_status ()
617 + then
618 + match !backtrace with
619 + | None -> ()
620 + | Some b ->
621 + print_string b;
622 + backtrace := None
623
624 (* The table of toplevel directives.
625 Filled by functions from module topdirs. *)
4d08635 cleaned up patch, split out post-boostrap part
Jake Donham authored
626 @@ -249,6 +266,15 @@ let execute_phrase print_outcome ppf phr =
8076b51 original patch for 3.11.2
Jake Donham authored
627 Ophr_exception (exn, outv)
628 in
629 !print_out_phrase ppf out_phr;
630 + if Printexc.backtrace_status ()
631 + then begin
632 + match !backtrace with
633 + | None -> ()
634 + | Some b ->
635 + pp_print_string ppf b;
636 + pp_print_flush ppf ();
637 + backtrace := None;
638 + end;
639 begin match out_phr with
640 | Ophr_eval (_, _) | Ophr_signature _ -> true
641 | Ophr_exception _ -> false
4d08635 cleaned up patch, split out post-boostrap part
Jake Donham authored
642 diff --git a/toplevel/toploop.mli b/toplevel/toploop.mli
643 index be9c27b..83a8eb5 100644
644 --- a/toplevel/toploop.mli
645 +++ b/toplevel/toploop.mli
646 @@ -62,6 +62,7 @@ val use_silently : formatter -> string -> bool
8076b51 original patch for 3.11.2
Jake Donham authored
647 [use_silently] does not print them. *)
648 val eval_path: Path.t -> Obj.t
649 (* Return the toplevel object referred to by the given path *)
650 +val record_backtrace: unit -> unit
651
652 (* Printing of values *)
653
Something went wrong with that request. Please try again.