Example #1
0
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);
}
Example #2
0
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);
}
Example #3
0
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;
      }
    }
  }
}
Example #5
0
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;
}
Example #6
0
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);
}
Example #7
0
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);
}
Example #8
0
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 {