CAMLexport value caml_callbackN_exn(value closure, int narg, value args[])
{
CAMLparam0();
CAMLlocal1(parent_stack);
int i;
value res;
parent_stack = Stack_parent(caml_current_stack);
Stack_parent(caml_current_stack) = Val_unit;
Assert(narg + 4 <= 256);
caml_extern_sp -= narg + 4;
for (i = 0; i < narg; i++) caml_extern_sp[i] = args[i]; /* arguments */
opcode_t code[7] = {
callback_code[0], narg + 3,
callback_code[2], narg,
callback_code[4], callback_code[5], callback_code[6]
};
caml_extern_sp[narg] = Val_pc (code + 4); /* return address */
caml_extern_sp[narg + 1] = Val_unit; /* environment */
caml_extern_sp[narg + 2] = Val_long(0); /* extra args */
caml_extern_sp[narg + 3] = closure;
res = caml_interprete(code, sizeof(code));
if (Is_exception_result(res)) caml_extern_sp += narg + 4; /* PR#1228 */
Assert(Stack_parent(caml_current_stack) == Val_unit);
Stack_parent(caml_current_stack) = parent_stack;
CAMLreturn (res);
}
CAMLprim value caml_clone_cont (value cont)
{
CAMLparam1(cont);
CAMLlocal3(new_cont, prev_target, source);
value target;
if (Field (cont, 0) == Val_unit)
caml_invalid_argument ("continuation already taken");
prev_target = Val_unit;
source = Field (cont, 0);
new_cont = caml_alloc (1, 0);
do {
Assert (Is_block (source) && Tag_val(source) == Stack_tag);
target = caml_alloc (Wosize_val(source), Stack_tag);
memcpy ((void*)target, (void*)source, Wosize_val(source) * sizeof(value));
if (prev_target == Val_unit) {
caml_modify (&Field(new_cont, 0), target);
} else {
caml_modify (&Stack_parent(prev_target), target);
}
prev_target = target;
source = Stack_parent(source);
} while (source != Val_unit);
CAMLreturn(new_cont);
}
CAMLexport value caml_callbackN_exn(value closure, int narg, value args[])
{
CAMLparam0();
struct stack_info* parent_stack;
int i;
value res;
caml_domain_state* domain_state = Caml_state;
parent_stack = Stack_parent(domain_state->current_stack);
Stack_parent(domain_state->current_stack) = NULL;
CAMLassert(narg + 4 <= 256);
domain_state->current_stack->sp -= narg + 4;
for (i = 0; i < narg; i++) domain_state->current_stack->sp[i] = args[i]; /* arguments */
opcode_t code[7] = {
callback_code[0], narg + 3,
callback_code[2], narg,
callback_code[4], callback_code[5], callback_code[6]
};
domain_state->current_stack->sp[narg] = Val_pc (code + 4); /* return address */
domain_state->current_stack->sp[narg + 1] = Val_unit; /* environment */
domain_state->current_stack->sp[narg + 2] = Val_long(0); /* extra args */
domain_state->current_stack->sp[narg + 3] = closure;
res = caml_interprete(code, sizeof(code));
if (Is_exception_result(res)) domain_state->current_stack->sp += narg + 4; /* PR#1228 */
Assert(Stack_parent(domain_state->current_stack) == NULL);
Stack_parent(domain_state->current_stack) = parent_stack;
CAMLreturn (res);
}
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_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_main_stack (uintnat init_size)
{
CAMLparam0();
CAMLlocal1(stack);
/* Create a stack for the main program.
The GC is not initialised yet, so we use caml_alloc_shr
which cannot trigger it */
stack = caml_alloc_shr(init_size, Stack_tag);
Stack_dirty(stack) = Val_long(0);
Stack_handle_value(stack) = Val_long(0);
Stack_handle_exception(stack) = Val_long(0);
Stack_handle_effect(stack) = Val_long(0);
Stack_parent(stack) = Val_unit;
Stack_sp(stack) = 0;
CAMLreturn(stack);
}
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);
}
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 {
