/* 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); }