/* Default C implementation in case the OCaml one is not registered. */
static void default_fatal_uncaught_exception(value exn)
{
char * msg;
caml_root at_exit;
int saved_backtrace_active;
intnat saved_backtrace_pos;
caml_domain_state* domain_state = Caml_state;
/* Build a string representation of the exception */
msg = caml_format_exception(exn);
/* Perform "at_exit" processing, ignoring all exceptions that may
be triggered by this */
saved_backtrace_active = domain_state->backtrace_active;
saved_backtrace_pos = domain_state->backtrace_pos;
domain_state->backtrace_active = 0;
at_exit = caml_named_root("Pervasives.do_at_exit");
if (at_exit) caml_callback_exn(caml_read_root(at_exit), Val_unit);
domain_state->backtrace_active = saved_backtrace_active;
domain_state->backtrace_pos = saved_backtrace_pos;
/* Display the uncaught exception */
fprintf(stderr, "Fatal error: exception %s\n", msg);
free(msg);
/* Display the backtrace if available */
if (Caml_state->backtrace_active && !DEBUGGER_IN_USE)
caml_print_exception_backtrace();
}
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_fatal_uncaught_exception(value exn)
{
caml_root handle_uncaught_exception =
caml_named_root("Printexc.handle_uncaught_exception");
if (handle_uncaught_exception)
/* [Printexc.handle_uncaught_exception] does not raise exception. */
caml_callback2(caml_read_root(handle_uncaught_exception), exn, Val_bool(DEBUGGER_IN_USE));
else
default_fatal_uncaught_exception(exn);
/* Terminate the process */
exit(2);
}
void caml_array_bound_error(void)
{
caml_root array_bound_error_exn;
array_bound_error_exn =
caml_named_root("Pervasives.array_bound_error");
if (!array_bound_error_exn) {
fprintf(stderr, "Fatal error: exception "
"Invalid_argument(\"index out of bounds\")\n");
exit(2);
}
caml_raise(caml_read_root(array_bound_error_exn));
}
CAMLexport const value* caml_named_value(char const *name)
{
struct named_value * nv;
caml_root ret = NULL;
caml_plat_lock(&named_value_lock);
for (nv = named_value_table[hash_value_name(name)];
nv != NULL;
nv = nv->next) {
if (strcmp(name, nv->name) == 0){
ret = nv->val;
break;
}
}
caml_plat_unlock(&named_value_lock);
/* *ret should never be a minor object, since caml_create_root promotes */
CAMLassert (!(ret && Is_minor(caml_read_root(ret))));
return Op_val(ret);
}
CAMLprim value caml_realloc_global(value size)
{
mlsize_t requested_size, actual_size, i;
value old_global_data = caml_read_root(caml_global_data);
value new_global_data;
requested_size = Long_val(size);
actual_size = Wosize_val(old_global_data);
if (requested_size >= actual_size) {
requested_size = (requested_size + 0x100) & 0xFFFFFF00;
caml_gc_log ("Growing global data to %u entries",
(unsigned)requested_size);
new_global_data = caml_alloc_shr(requested_size, 0);
for (i = 0; i < actual_size; i++)
caml_initialize_field(new_global_data, i, Field(old_global_data, i));
for (i = actual_size; i < requested_size; i++){
caml_initialize_field(new_global_data, i, Val_long(0));
}
caml_modify_root(caml_global_data, new_global_data);
}
return Val_unit;
}
char * format_result(int n)
{
value format_result_closure = caml_read_root(caml_named_root("format_result"));
return strdup(String_val(callback(format_result_closure, Val_int(n))));
}
int fib(int n)
{
value fib_closure = caml_read_root(caml_named_root("fib"));
return Int_val(callback(fib_closure, Val_int(n)));
}
value gb_get(value vblock)
{
CAMLparam1 (vblock);
CAMLreturn (caml_read_root(Root_val(vblock)));
}
CAMLprim value caml_get_global_data(value unit)
{
return caml_read_root(caml_global_data);
}
