void caml_fatal_uncaught_exception(value exn)
{
char * msg;
value * at_exit;
int saved_backtrace_active, saved_backtrace_pos;
/* 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 = caml_backtrace_active;
saved_backtrace_pos = caml_backtrace_pos;
caml_backtrace_active = 0;
at_exit = caml_named_value("Pervasives.do_at_exit");
if (at_exit != NULL) caml_callback_exn(*at_exit, Val_unit);
caml_backtrace_active = saved_backtrace_active;
caml_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_backtrace_active
#ifndef NATIVE_CODE
&& !caml_debugger_in_use
#endif
) {
caml_print_exception_backtrace();
}
/* Terminate the process */
exit(2);
}
int cstr_post(value* in)
{
value v;
CLOSURE ("Cstr.post");
v = caml_callback_exn(*closure, *in);
return Is_exception_result(v);
}
/* Do a minor collection and a slice of major collection, call finalisation
functions, etc.
Leave the minor heap empty.
*/
CAMLexport void caml_minor_collection (void)
{
value *note_gc;
uint64_t start_time;
note_gc = caml_named_value("MProf.Trace.note_gc");
if (note_gc)
start_time = NOW();
intnat prev_alloc_words = caml_allocated_words;
caml_empty_minor_heap ();
caml_stat_promoted_words += caml_allocated_words - prev_alloc_words;
++ caml_stat_minor_collections;
caml_major_collection_slice (0);
caml_force_major_slice = 0;
caml_final_do_calls ();
if (note_gc){
double duration_ns = (double) (NOW () - start_time);
value result = caml_callback_exn(*note_gc, caml_copy_double(duration_ns / 1000000000));
if (Is_exception_result(result))
printk("warning: note_gc threw an exception!\n");
}
caml_empty_minor_heap ();
}
CAMLexport value caml_callbackN_exn(value closure, int narg, value args[])
{
CAMLparam1 (closure);
CAMLxparamN (args, narg);
CAMLlocal1 (res);
int i;
res = closure;
for (i = 0; i < narg; /*nothing*/) {
/* Pass as many arguments as possible */
switch (narg - i) {
case 1:
res = caml_callback_exn(res, args[i]);
if (Is_exception_result(res)) CAMLreturn (res);
i += 1;
break;
case 2:
res = caml_callback2_exn(res, args[i], args[i + 1]);
if (Is_exception_result(res)) CAMLreturn (res);
i += 2;
break;
default:
res = caml_callback3_exn(res, args[i], args[i + 1], args[i + 2]);
if (Is_exception_result(res)) CAMLreturn (res);
i += 3;
break;
}
}
CAMLreturn (res);
}
void caml_execute_signal(int signal_number, int in_signal_handler)
{
value res;
#ifdef POSIX_SIGNALS
sigset_t sigs;
/* Block the signal before executing the handler, and record in sigs
the original signal mask */
sigemptyset(&sigs);
sigaddset(&sigs, signal_number);
sigprocmask(SIG_BLOCK, &sigs, &sigs);
#endif
res = caml_callback_exn(
Field(caml_signal_handlers, signal_number),
Val_int(caml_rev_convert_signal_number(signal_number)));
#ifdef POSIX_SIGNALS
if (! in_signal_handler) {
/* Restore the original signal mask */
sigprocmask(SIG_SETMASK, &sigs, NULL);
} else if (Is_exception_result(res)) {
/* Restore the original signal mask and unblock the signal itself */
sigdelset(&sigs, signal_number);
sigprocmask(SIG_SETMASK, &sigs, NULL);
}
#endif
if (Is_exception_result(res)) caml_raise(Extract_exception(res));
}
static void
uwt_udp_recv_cb(uv_udp_t* handle,
ssize_t nread,
const uv_buf_t* buf,
const struct sockaddr* addr,
unsigned int flags)
{
HANDLE_CB_INIT_WITH_CLEAN(uh, handle);
value exn = Val_unit;
bool buf_not_cleaned = true;
if ( uh->close_called == 0 && ( nread != 0 || addr != NULL ) ){
/* nread == 0 && addr == NULL only means we need to clear
the buffer */
assert ( uh->cb_read != CB_INVALID );
value p = alloc_recv_result(nread,buf,addr,flags);
if ( buf->base ){
buf_not_cleaned = false;
uwt__free_uv_buf_t_const(buf);
}
exn = GET_CB_VAL(uh->cb_read);
exn = caml_callback_exn(exn,p);
}
if ( buf_not_cleaned && buf->base ){
uwt__free_uv_buf_t_const(buf);
}
HANDLE_CB_RET(exn);
}
/* 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();
}
value* fdarray_max(value* in1)
{
value a;
CLOSURE("FdArray.max");
a = caml_callback_exn(*closure, *in1);
if Is_exception_result(a) return 0;
return fcl_wrap(a);
}
value* cstr_boolean(value* cstr)
{
value a;
CLOSURE("Cstr.boolean");
a = caml_callback_exn(*closure, *cstr);
if Is_exception_result(a) return 0;
return fcl_wrap(a);
}
static void call_registered_value(char* name)
{
const value* f;
f = caml_named_value(name);
if (f != NULL)
caml_callback_exn(*f, Val_unit);
}
value* cstr_not(value* in)
{
value a;
CLOSURE("Cstr.not");
a = caml_callback_exn(*closure, *in);
if Is_exception_result(a) return 0;
return fcl_wrap(a);
}
static int callml_custom_initialize(SUNLinearSolver ls)
{
CAMLparam0();
CAMLlocal1(r);
r = caml_callback_exn(GET_OP(ls, INIT), Val_unit);
CAMLreturnT(int, CHECK_EXCEPTION_SUCCESS(r));
}
static int callml_custom_setup(SUNLinearSolver ls, SUNMatrix A)
{
CAMLparam0();
CAMLlocal1(r);
r = caml_callback_exn(GET_OP(ls, SETUP),
(A == NULL) ? Val_unit : MAT_BACKLINK(A));
CAMLreturnT(int, CHECK_EXCEPTION_SUCCESS(r));
}
static int callml_custom_numiters(SUNLinearSolver ls)
{
CAMLparam0();
CAMLlocal1(r);
r = caml_callback_exn(GET_OP(ls, GET_NUM_ITERS), Val_unit);
if (Is_exception_result (r)) {
sunml_warn_discarded_exn (Extract_exception (r),
"user-defined num iters handler");
CAMLreturnT(int, 0);
}
CAMLreturnT(int, Int_val(r));
}
static realtype callml_custom_resnorm(SUNLinearSolver ls)
{
CAMLparam0();
CAMLlocal1(r);
r = caml_callback_exn(GET_OP(ls, GET_RES_NORM), Val_unit);
if (Is_exception_result (r)) {
sunml_warn_discarded_exn (Extract_exception (r),
"user-defined res norm handler");
CAMLreturnT(realtype, 0.0);
}
CAMLreturnT(realtype, Double_val(r));
}
cairo_status_t
ml_cairo_read_func (void *closure, unsigned char *data, unsigned int length)
{
value s, res, *c = closure;
s = caml_alloc_string (length);
res = caml_callback_exn (Field (*c, 0), s);
if (Is_exception_result (res))
{
Store_field (*c, 1, res);
return CAIRO_STATUS_READ_ERROR;
}
memcpy (data, String_val (s), length);
return CAIRO_STATUS_SUCCESS;
}
static N_Vector callml_custom_resid(SUNLinearSolver ls)
{
CAMLparam0();
CAMLlocal1(r);
r = caml_callback_exn(GET_OP(ls, GET_RES_ID), Val_unit);
if (Is_exception_result (r)) {
sunml_warn_discarded_exn (Extract_exception (r),
"user-defined res id handler");
CAMLreturnT(N_Vector, NULL);
}
CAMLreturnT(N_Vector, NVEC_VAL(r));
}
/* Callout handler */
static int pcre_callout_handler(pcre_callout_block* cb)
{
struct cod *cod = (struct cod *) cb->callout_data;
if (cod != NULL) {
/* Callout is available */
value v_res;
/* Set up parameter array */
value v_callout_data = caml_alloc_small(6, 0);
const value v_substrings = *cod->v_substrings_p;
const int capture_top = cb->capture_top;
int subgroups2 = capture_top << 1;
const int subgroups2_1 = subgroups2 - 1;
const int *ovec_src = cb->offset_vector + subgroups2_1;
long int *ovec_dst = &Field(Field(v_substrings, 1), 0) + subgroups2_1;
/* Copy preliminary substring information */
while (subgroups2--) {
*ovec_dst = Val_int(*ovec_src);
--ovec_src; --ovec_dst;
}
Field(v_callout_data, 0) = Val_int(cb->callout_number);
Field(v_callout_data, 1) = v_substrings;
Field(v_callout_data, 2) = Val_int(cb->start_match);
Field(v_callout_data, 3) = Val_int(cb->current_position);
Field(v_callout_data, 4) = Val_int(capture_top);
Field(v_callout_data, 5) = Val_int(cb->capture_last);
Field(v_callout_data, 6) = Val_int(cb->pattern_position);
Field(v_callout_data, 7) = Val_int(cb->next_item_length);
/* Perform callout */
v_res = caml_callback_exn(*cod->v_cof_p, v_callout_data);
if (Is_exception_result(v_res)) {
/* Callout raised an exception */
const value v_exn = Extract_exception(v_res);
if (Field(v_exn, 0) == *pcre_exc_Backtrack) return 1;
cod->v_exn = v_exn;
return PCRE_ERROR_CALLOUT;
}
}
return 0;
}
static int callml_custom_setatimes(SUNLinearSolver ls, void* A_data,
ATimesFn ATimes)
{
CAMLparam0();
CAMLlocal2(vcptr, r);
vcptr = caml_alloc_final(
(sizeof(struct atimes_with_data) + sizeof(value) - 1)
/ sizeof(value),
NULL, 0, 1);
ATIMES_WITH_DATA(vcptr)->atimes_func = ATimes;
ATIMES_WITH_DATA(vcptr)->atimes_data = A_data;
r = caml_callback_exn(GET_OP(ls, SET_ATIMES), vcptr);
CAMLreturnT(int, CHECK_EXCEPTION_SUCCESS(r));
}
void caml_fatal_uncaught_exception(value exn)
{
char * msg;
value * at_exit;
/* 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 */
at_exit = caml_named_value("Pervasives.do_at_exit");
if (at_exit != NULL) caml_callback_exn(*at_exit, Val_unit);
/* Display the uncaught exception */
/*fprintf(stderr, "Fatal error: exception %s\n", msg);*/
free(msg);
/* Terminate the process */
exit(2);
}
void IDAOCaml_invoke_hotkey_callback(int i)
{
CAMLlocal1(ret);
ret = caml_callback_exn(*caml_named_value("HotkeyCallback"), Val_int(i));
if(Is_exception_result(ret))
{
char buf[1024];
char *exn = caml_format_exception(Extract_exception(ret));
sprintf(buf, "[E] Function bound to hotkey (internal %d) threw exception (value %08lx): %s\n",
i,
Extract_exception(ret),
exn);
wrap_msg(buf);
free(exn);
}
}
static int callml_custom_space(SUNLinearSolver ls,
long int *lenrwLS, long int *leniwLS)
{
CAMLparam0();
CAMLlocal1(r);
r = caml_callback_exn(GET_OP(ls, GET_WORK_SPACE), Val_unit);
if (Is_exception_result (r)) {
r = Extract_exception (r);
lenrwLS = 0;
leniwLS = 0;
CAMLreturnT(int, lsolver_translate_exception(r));
}
*lenrwLS = Long_val(Field(r, 0));
*leniwLS = Long_val(Field(r, 1));
CAMLreturnT(int, SUNLS_SUCCESS);
}
static inline int exec_callback_no_headers(
void *cbx_, int num_columns, char **row, char __unused **header)
{
callback_with_exn *cbx = cbx_;
value v_row, v_ret;
caml_leave_blocking_section();
v_row = copy_string_option_array((const char **) row, num_columns);
v_ret = caml_callback_exn(*cbx->cbp, v_row);
if (Is_exception_result(v_ret)) {
*cbx->exn = Extract_exception(v_ret);
caml_enter_blocking_section();
return 1;
}
caml_enter_blocking_section();
return 0;
}
void caml_run_at_context_exit_functions_r(CAML_R){
CAMLparam0();
CAMLlocal1(run_at_context_exit_functions);
value *run_at_context_exit_functions_pointer;
run_at_context_exit_functions_pointer = caml_named_value_r(ctx, "Context.run_at_context_exit_functions");
/* Normally Context.run_at_context_exit_functions should have been
register at initialization time from OCaml in the Context module;
however run_at_context_exit_functions_pointer is allowed to be
NULL, if the standard library has been disabled. In that case
we simply won't run cleanup functions. */
if(run_at_context_exit_functions_pointer != NULL){
run_at_context_exit_functions = *run_at_context_exit_functions_pointer;
//DUMP("Context.run_at_context_exit_functions is %p", (void*)(long)run_at_context_exit_functions);
#if !defined(NATIVE_CODE) || defined(SUPPORTS_MULTICONTEXT)
caml_callback_exn_r(ctx, run_at_context_exit_functions, Val_unit);
#else
caml_callback_exn(run_at_context_exit_functions, Val_unit);
#endif // #if !defined(NATIVE_CODE) || defined(SUPPORTS_MULTICONTEXT)
}
CAMLreturn0;
}
// Called by the host app to receive a packet
void * FFI_mitls_receive(/* in */ mitls_state *state, /* out */ size_t *packet_size, /* out */ char **outmsg, /* out */ char **errmsg)
{
CAMLparam0();
CAMLlocal1(result);
void *p = NULL;
*outmsg = NULL;
*errmsg = NULL;
caml_acquire_runtime_system();
result = caml_callback_exn(*g_mitls_FFI_Recv, state->fstar_state);
if (Is_exception_result(result)) {
// call caml_format_exception(Extract_exception(result)) to extract the exception text
p = NULL;
} else {
// Return the plaintext data
p = copypacket(result, packet_size);
}
caml_release_runtime_system();
CAMLreturnT(void*,p);
}
static int bbbdcomm(sundials_ml_index nlocal, realtype t, N_Vector y,
N_Vector yb, void *user_data)
{
CAMLparam0();
CAMLlocal3(args, session, cb);
args = caml_alloc_tuple (RECORD_CVODES_ADJ_BRHSFN_ARGS_SIZE);
Store_field (args, RECORD_CVODES_ADJ_BRHSFN_ARGS_T, caml_copy_double (t));
Store_field (args, RECORD_CVODES_ADJ_BRHSFN_ARGS_Y, NVEC_BACKLINK (y));
Store_field (args, RECORD_CVODES_ADJ_BRHSFN_ARGS_YB, NVEC_BACKLINK (yb));
WEAK_DEREF (session, *(value*)user_data);
cb = CVODE_LS_PRECFNS_FROM_ML (session);
cb = Field (cb, 0);
cb = Field (cb, RECORD_CVODES_BBBD_PRECFNS_COMM_FN);
cb = Some_val (cb);
assert (Tag_val (cb) == Closure_tag);
/* NB: Don't trigger GC while processing this return value! */
value r = caml_callback_exn (cb, args);
CAMLreturnT(int, CHECK_EXCEPTION (session, r, RECOVERABLE));
}
CAMLexport value caml_callback (value closure, value arg)
{
value res = caml_callback_exn(closure, arg);
if (Is_exception_result(res)) caml_raise(Extract_exception(res));
return res;
}
