static void get_callstack(value* sp, intnat trap_spoff,
struct stack_info* stack,
intnat max_frames,
code_t** trace, intnat* trace_size)
{
CAMLnoalloc;
struct stack_info* parent = Stack_parent(stack);
value *stack_high = Stack_high(stack);
value* saved_sp = sp;
intnat saved_trap_spoff = trap_spoff;
/* first compute the size of the trace */
{
*trace_size = 0;
while (*trace_size < max_frames) {
code_t p = caml_next_frame_pointer(stack_high, &sp, &trap_spoff);
if (p == NULL) {
if (parent == NULL) break;
sp = parent->sp;
trap_spoff = Long_val(sp[0]);
stack_high = Stack_high(parent);
parent = Stack_parent(parent);
} else {
++*trace_size;
}
}
}
*trace = caml_stat_alloc(sizeof(code_t*) * *trace_size);
sp = saved_sp;
parent = Stack_parent(stack);
stack_high = Stack_high(stack);
trap_spoff = saved_trap_spoff;
/* then collect the trace */
{
uintnat trace_pos = 0;
while (trace_pos < *trace_size) {
code_t p = caml_next_frame_pointer(stack_high, &sp, &trap_spoff);
if (p == NULL) {
sp = parent->sp;
trap_spoff = Long_val(sp[0]);
stack_high = Stack_high(parent);
parent = Stack_parent(parent);
} else {
(*trace)[trace_pos] = p;
++trace_pos;
}
}
}
}
void caml_stash_backtrace(value exn, code_t pc, value * sp, int reraise)
{
if (pc != NULL) pc = pc - 1;
if (exn != caml_read_root(Caml_state->backtrace_last_exn) || !reraise) {
Caml_state->backtrace_pos = 0;
caml_modify_root(Caml_state->backtrace_last_exn, exn);
}
if (Caml_state->backtrace_buffer == NULL &&
caml_alloc_backtrace_buffer() == -1)
return;
if (Caml_state->backtrace_pos >= BACKTRACE_BUFFER_SIZE) return;
/* testing the code region is needed: PR#1554 */
if (find_debug_info(pc) != NULL)
Caml_state->backtrace_buffer[Caml_state->backtrace_pos++] = pc;
/* Traverse the stack and put all values pointing into bytecode
into the backtrace buffer. */
value *trap_sp = Stack_high(Caml_state->current_stack) + Caml_state->trap_sp_off;
for (/*nothing*/; sp < trap_sp; sp++) {
if (Is_long(*sp)) {
code_t p = Pc_val(*sp);
if (Caml_state->backtrace_pos >= BACKTRACE_BUFFER_SIZE) break;
if (find_debug_info(p) != NULL)
Caml_state->backtrace_buffer[Caml_state->backtrace_pos++] = p;
}
}
}
void caml_realloc_stack () {
CAMLparam0();
CAMLlocal2(old_stack, new_stack);
/* All sizes are in bytes */
asize_t size;
uintnat stack_used;
old_stack = caml_current_stack;
stack_used = Stack_sp(old_stack);
size = Wosize_val(old_stack);
size *= 2;
caml_gc_log ("Growing old_stack=0x%lx to %lu words\n", old_stack, size);
new_stack = caml_alloc(size, Stack_tag);
caml_gc_log ("New_stack=0x%lx\n", new_stack);
memcpy(Stack_high(new_stack) - stack_used,
Stack_high(old_stack) - stack_used,
stack_used);
Stack_sp(new_stack) = Stack_sp(old_stack);
Stack_handle_value(new_stack) = Stack_handle_value(old_stack);
Stack_handle_exception(new_stack) = Stack_handle_exception(old_stack);
Stack_handle_effect(new_stack) = Stack_handle_effect(old_stack);
Stack_parent(new_stack) = Stack_parent(old_stack);
Stack_dirty(new_stack) = Val_long(0);
if (Stack_dirty(old_stack) == Val_long(1)) {
dirty_stack(new_stack);
}
load_stack(new_stack);
/* Reset old stack */
Stack_sp(old_stack) = 0;
Stack_dirty(old_stack) = Val_long(0);
Stack_handle_value(old_stack) = Val_long(0);
Stack_handle_exception(old_stack) = Val_long(0);
Stack_handle_effect(old_stack) = Val_long(0);
Stack_parent(old_stack) = Val_unit;
CAMLreturn0;
}
value caml_alloc_stack (value hval, value hexn, value heff) {
CAMLparam3(hval, hexn, heff);
CAMLlocal1(stack);
char* sp;
struct caml_context *ctxt;
stack = caml_alloc(caml_init_fiber_wsz, Stack_tag);
Stack_dirty(stack) = Val_long(0);
Stack_handle_value(stack) = hval;
Stack_handle_exception(stack) = hexn;
Stack_handle_effect(stack) = heff;
Stack_parent(stack) = Val_unit;
sp = Stack_high(stack);
/* Fiber exception handler that returns to parent */
sp -= sizeof(value);
*(value**)sp = (value*)caml_fiber_exn_handler;
/* No previous exception frame */
sp -= sizeof(value);
*(uintnat*)sp = 0;
/* Value handler that returns to parent */
sp -= sizeof(value);
*(value**)sp = (value*)caml_fiber_val_handler;
/* Build a context */
sp -= sizeof(struct caml_context);
ctxt = (struct caml_context*)sp;
ctxt->exception_ptr_offset = 2 * sizeof(value);
ctxt->gc_regs = NULL;
Stack_sp(stack) = 3 * sizeof(value) + sizeof(struct caml_context);
caml_gc_log ("Allocate stack=0x%lx of %lu words\n",
stack, caml_init_fiber_wsz);
CAMLreturn (stack);
}
static void load_stack (value stack) {
caml_stack_threshold = Stack_base(stack) + Stack_threshold;
caml_top_of_stack = Stack_high(stack);
caml_current_stack = stack;
}
