1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
|
/***********************************************************************/
/* */
/* OCaml */
/* */
/* Xavier Leroy, projet Gallium, INRIA Rocquencourt */
/* */
/* Copyright 2006 Institut National de Recherche en Informatique et */
/* en Automatique. All rights reserved. This file is distributed */
/* under the terms of the GNU Library General Public License, with */
/* the special exception on linking described in file ../LICENSE. */
/* */
/***********************************************************************/
/* Stack backtrace for uncaught exceptions */
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include "caml/alloc.h"
#include "caml/backtrace.h"
#include "caml/backtrace_prim.h"
#include "caml/memory.h"
#include "caml/misc.h"
#include "caml/mlvalues.h"
#include "stack.h"
/* In order to prevent the GC from walking through the debug information
(which have no headers), we transform frame_descr pointers into
31/63 bits ocaml integers by shifting them by 1 to the right. We do
not lose information as descr pointers are aligned. */
value caml_val_raw_backtrace_slot(backtrace_slot pc)
{
return Val_long((uintnat)pc>>1);
}
backtrace_slot caml_raw_backtrace_slot_val(value v)
{
return ((backtrace_slot)(Long_val(v)<<1));
}
/* Returns the next frame descriptor (or NULL if none is available),
and updates *pc and *sp to point to the following one. */
frame_descr * caml_next_frame_descriptor(uintnat * pc, char ** sp)
{
frame_descr * d;
uintnat h;
while (1) {
h = Hash_retaddr(*pc);
while (1) {
d = caml_frame_descriptors[h];
if (d == NULL) return NULL; /* happens if some code compiled without -g */
if (d->retaddr == *pc) break;
h = (h+1) & caml_frame_descriptors_mask;
}
/* Skip to next frame */
if (d->frame_size != 0xFFFF) {
/* Regular frame, update sp/pc and return the frame descriptor */
#ifndef Stack_grows_upwards
*sp += (d->frame_size & 0xFFFC);
#else
*sp -= (d->frame_size & 0xFFFC);
#endif
*pc = Saved_return_address(*sp);
#ifdef Mask_already_scanned
*pc = Mask_already_scanned(*pc);
#endif
return d;
} else {
/* Special frame marking the top of a stack chunk for an ML callback.
Skip C portion of stack and continue with next ML stack chunk. */
struct caml_context * next_context = Callback_link(*sp);
*sp = next_context->bottom_of_stack;
*pc = next_context->last_retaddr;
/* A null sp means no more ML stack chunks; stop here. */
if (*sp == NULL) return NULL;
}
}
}
/* Stores the return addresses contained in the given stack fragment
into the backtrace array ; this version is performance-sensitive as
it is called at each [raise] in a program compiled with [-g], so we
preserved the global, statically bounded buffer of the old
implementation -- before the more flexible
[caml_get_current_callstack] was implemented. */
void caml_stash_backtrace(value exn, uintnat pc, char * sp, char * trapsp)
{
if (exn != caml_backtrace_last_exn) {
caml_backtrace_pos = 0;
caml_backtrace_last_exn = exn;
}
if (caml_backtrace_buffer == NULL) {
Assert(caml_backtrace_pos == 0);
caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(backtrace_slot));
if (caml_backtrace_buffer == NULL) return;
}
/* iterate on each frame */
while (1) {
frame_descr * descr = caml_next_frame_descriptor(&pc, &sp);
if (descr == NULL) return;
/* store its descriptor in the backtrace buffer */
if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) return;
caml_backtrace_buffer[caml_backtrace_pos++] = (backtrace_slot) descr;
/* Stop when we reach the current exception handler */
#ifndef Stack_grows_upwards
if (sp > trapsp) return;
#else
if (sp < trapsp) return;
#endif
}
}
/* Stores upto [max_frames_value] frames of the current call stack to
return to the user. This is used not in an exception-raising
context, but only when the user requests to save the trace
(hopefully less often). Instead of using a bounded buffer as
[caml_stash_backtrace], we first traverse the stack to compute the
right size, then allocate space for the trace. */
CAMLprim value caml_get_current_callstack(value max_frames_value)
{
CAMLparam1(max_frames_value);
CAMLlocal1(trace);
/* we use `intnat` here because, were it only `int`, passing `max_int`
from the OCaml side would overflow on 64bits machines. */
intnat max_frames = Long_val(max_frames_value);
intnat trace_size;
/* first compute the size of the trace */
{
uintnat pc = caml_last_return_address;
/* note that [caml_bottom_of_stack] always points to the most recent
* frame, independently of the [Stack_grows_upwards] setting */
char * sp = caml_bottom_of_stack;
char * limitsp = caml_top_of_stack;
trace_size = 0;
while (1) {
frame_descr * descr = caml_next_frame_descriptor(&pc, &sp);
if (descr == NULL) break;
if (trace_size >= max_frames) break;
++trace_size;
#ifndef Stack_grows_upwards
if (sp > limitsp) break;
#else
if (sp < limitsp) break;
#endif
}
}
trace = caml_alloc((mlsize_t) trace_size, 0);
/* then collect the trace */
{
uintnat pc = caml_last_return_address;
char * sp = caml_bottom_of_stack;
intnat trace_pos;
for (trace_pos = 0; trace_pos < trace_size; trace_pos++) {
frame_descr * descr = caml_next_frame_descriptor(&pc, &sp);
Assert(descr != NULL);
Store_field(trace, trace_pos, caml_val_raw_backtrace_slot((backtrace_slot) descr));
}
}
CAMLreturn(trace);
}
/* Extract location information for the given frame descriptor */
void caml_extract_location_info(backtrace_slot slot, /*out*/ struct caml_loc_info * li)
{
uintnat infoptr;
uint32_t info1, info2;
frame_descr * d = (frame_descr *)slot;
/* 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) {
li->loc_valid = 0;
li->loc_is_raise = 1;
return;
}
/* Recover debugging info */
infoptr = ((uintnat) d +
sizeof(char *) + sizeof(short) + sizeof(short) +
sizeof(short) * d->num_live + sizeof(frame_descr *) - 1)
& -sizeof(frame_descr *);
info1 = ((uint32_t *)infoptr)[0];
info2 = ((uint32_t *)infoptr)[1];
/* Format of the two info words:
llllllllllllllllllll aaaaaaaa bbbbbbbbbb nnnnnnnnnnnnnnnnnnnnnnnn kk
44 36 26 2 0
(32+12) (32+4)
k ( 2 bits): 0 if it's a call, 1 if it's a raise
n (24 bits): offset (in 4-byte words) of file name relative to infoptr
l (20 bits): line number
a ( 8 bits): beginning of character range
b (10 bits): end of character range */
li->loc_valid = 1;
li->loc_is_raise = (info1 & 3) != 0;
li->loc_filename = (char *) infoptr + (info1 & 0x3FFFFFC);
li->loc_lnum = info2 >> 12;
li->loc_startchr = (info2 >> 4) & 0xFF;
li->loc_endchr = ((info2 & 0xF) << 6) | (info1 >> 26);
}
CAMLprim value caml_add_debug_info(backtrace_slot start, value size, value events)
{
return Val_unit;
}
CAMLprim value caml_remove_debug_info(backtrace_slot start)
{
return Val_unit;
}
int caml_debug_info_available(void)
{
return 1;
}
|
