void caml_stash_backtrace(value exn, uintnat pc, char * sp, char * trapsp)
{
frame_descr * d;
uintnat h;
if (exn != caml_backtrace_last_exn) {
caml_backtrace_pos = 0;
caml_backtrace_last_exn = exn;
}
if (caml_backtrace_buffer == NULL) {
caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t));
if (caml_backtrace_buffer == NULL) return;
}
if (caml_frame_descriptors == NULL) caml_init_frame_descriptors();
while (1) {
/* Find the descriptor corresponding to the return address */
h = Hash_retaddr(pc);
while(1) {
d = caml_frame_descriptors[h];
if (d == 0) return; /* can happen if some code not compiled with -g */
if (d->retaddr == pc) break;
h = (h+1) & caml_frame_descriptors_mask;
}
/* Skip to next frame */
if (d->frame_size != 0xFFFF) {
/* Regular frame, store its descriptor in the backtrace buffer */
if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) return;
caml_backtrace_buffer[caml_backtrace_pos++] = (code_t) d;
#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
} 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;
}
/* Stop when we reach the current exception handler */
#ifndef Stack_grows_upwards
if (sp > trapsp) return;
#else
if (sp < trapsp) return;
#endif
}
}
frame_descr * caml_next_frame_descriptor(uintnat * pc, char ** sp)
{
frame_descr * d;
uintnat h;
if (caml_frame_descriptors == NULL) caml_init_frame_descriptors();
while (1) {
h = Hash_retaddr(*pc);
while (1) {
d = caml_frame_descriptors[h];
if (d == 0) return NULL; /* can happen 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;
}
}
}
void caml_scan_stack_high (scanning_action f, value stack, value* stack_high)
{
char * sp;
uintnat retaddr;
value * regs;
frame_descr * d;
uintnat h;
int n, ofs;
#ifdef Stack_grows_upwards
short * p; /* PR#4339: stack offsets are negative in this case */
#else
unsigned short * p;
#endif
value *root;
struct caml_context* context;
if (caml_frame_descriptors == NULL) caml_init_frame_descriptors();
f(Stack_handle_value(stack), &Stack_handle_value(stack));
f(Stack_handle_exception(stack), &Stack_handle_exception(stack));
f(Stack_handle_effect(stack), &Stack_handle_effect(stack));
f(Stack_parent(stack), &Stack_parent(stack));
if (Stack_sp(stack) == 0) return;
sp = ((char*)stack_high) - Stack_sp(stack);
next_chunk:
if (sp == (char*)stack_high) return;
context = (struct caml_context*)sp;
regs = context->gc_regs;
sp += sizeof(struct caml_context);
if (sp == (char*)stack_high) return;
retaddr = *(uintnat*)sp;
sp += sizeof(value);
while(1) {
/* Find the descriptor corresponding to the return address */
h = Hash_retaddr(retaddr);
while(1) {
d = caml_frame_descriptors[h];
if (d->retaddr == retaddr) break;
h = (h+1) & caml_frame_descriptors_mask;
}
if (d->frame_size != 0xFFFF) {
/* Scan the roots in this frame */
for (p = d->live_ofs, n = d->num_live; n > 0; n--, p++) {
ofs = *p;
if (ofs & 1) {
root = regs + (ofs >> 1);
} else {
root = (value *)(sp + ofs);
}
f (*root, root);
}
/* Move to next frame */
#ifndef Stack_grows_upwards
sp += (d->frame_size & 0xFFFC);
#else
sp -= (d->frame_size & 0xFFFC);
#endif
retaddr = Saved_return_address(sp);
/* XXX KC: disabled already scanned optimization. */
} else {
