void ml_payment_init(value pubkey, value scb, value ecb) {
if (successCb == 0) {
successCb = scb;
caml_register_generational_global_root(&successCb);
errorCb = ecb;
caml_register_generational_global_root(&errorCb);
} else {
caml_modify_generational_global_root(&successCb,scb);
caml_modify_generational_global_root(&errorCb,ecb);
}
if (!Is_long(pubkey)) {
JNIEnv *env;
(*gJavaVM)->GetEnv(gJavaVM, (void**) &env, JNI_VERSION_1_4);
jclass securityCls = (*env)->FindClass(env, "ru/redspell/lightning/payments/Security");
jmethodID setPubkey = (*env)->GetStaticMethodID(env, securityCls, "setPubkey", "(Ljava/lang/String;)V");
char* cpubkey = String_val(Field(pubkey, 0));
jstring jpubkey = (*env)->NewStringUTF(env, cpubkey);
(*env)->CallStaticVoidMethod(env, securityCls, setPubkey, jpubkey);
(*env)->DeleteLocalRef(env, securityCls);
(*env)->DeleteLocalRef(env, jpubkey);
}
}
CAMLprim void stub_init () {
CAMLparam0 ();
CAMLlocal3 (poll_in_list, poll_out_list, poll_in_out_list);
POLL_IN_HASH = caml_hash_variant("Poll_in");
POLL_OUT_HASH = caml_hash_variant("Poll_out");
ZMQ_EXCEPTION_NAME = caml_named_value("zmq exception");
POOL_LIST_CACHE[0] = EMPTY_LIST;
poll_out_list = caml_alloc_small(2, 0);
Field(poll_out_list, 0) = POLL_OUT_HASH;
Field(poll_out_list, 1) = EMPTY_LIST;
caml_register_generational_global_root(&POOL_LIST_CACHE[POLL_OUT]);
POOL_LIST_CACHE[POLL_OUT] = poll_out_list;
poll_in_out_list = caml_alloc_small(2, 0);
Field(poll_in_out_list, 0) = POLL_IN_HASH;
Field(poll_in_out_list, 1) = poll_out_list;
caml_register_generational_global_root(&POOL_LIST_CACHE[POLL_IN|POLL_OUT]);
POOL_LIST_CACHE[POLL_IN|POLL_OUT] = poll_in_out_list;
poll_in_list = caml_alloc_small(2, 0);
Field(poll_in_list, 0) = POLL_IN_HASH;
Field(poll_in_list, 1) = EMPTY_LIST;
caml_register_generational_global_root(&POOL_LIST_CACHE[POLL_IN]);
POOL_LIST_CACHE[POLL_IN] = poll_in_list;
CAMLreturn0;
}
/* Guestfs.set_event_callback */
value
ocaml_guestfs_set_event_callback (value gv, value closure, value events)
{
CAMLparam3 (gv, closure, events);
char key[64];
int eh;
uint64_t event_bitmask;
guestfs_h *g = Guestfs_val (gv);
event_bitmask = event_bitmask_of_event_list (events);
value *root = guestfs_int_safe_malloc (g, sizeof *root);
*root = closure;
eh = guestfs_set_event_callback (g, event_callback_wrapper,
event_bitmask, 0, root);
if (eh == -1) {
free (root);
ocaml_guestfs_raise_error (g, "set_event_callback");
}
caml_register_generational_global_root (root);
snprintf (key, sizeof key, "_ocaml_event_%d", eh);
guestfs_set_private (g, key, root);
CAMLreturn (Val_int (eh));
}
// Called by the host app to configure miTLS ahead of creating a connection
int FFI_mitls_configure(mitls_state **state, const char *tls_version, const char *host_name, char **outmsg, char **errmsg)
{
CAMLparam0();
CAMLlocal3(config, version, host);
int ret = 0;
*state = NULL;
*outmsg = NULL;
*errmsg = NULL;
version = caml_copy_string(tls_version);
host = caml_copy_string(host_name);
caml_acquire_runtime_system();
config = caml_callback2_exn(*g_mitls_FFI_Config, version, host);
if (Is_exception_result(config)) {
// call caml_format_exception(Extract_exception(config)) to extract the exception information
} else {
mitls_state * s;
// Allocate space on the heap, to store an OCaml value
s = (mitls_state*)malloc(sizeof(mitls_state));
if (s) {
// Tell the OCaml GC about the heap address, so it is treated
// as a GC root, keeping the config object live.
s->fstar_state = config;
caml_register_generational_global_root(&s->fstar_state);
*state = s;
ret = 1;
}
}
caml_release_runtime_system();
CAMLreturnT(int,ret);
}
CAMLprim value PQocaml_init(value __unused v_unit)
{
v_empty_string = caml_alloc_string(0);
caml_register_generational_global_root(&v_empty_string);
v_exc_Oid = caml_named_value("Postgresql.Oid");
v_null_param = caml_named_value("Postgresql.null");
return Val_unit;
}
static inline np_callback * np_new(value v_handler)
{
np_callback *c;
c = (np_callback *) caml_stat_alloc(sizeof(np_callback));
c->v_cb = v_handler;
c->cnt = 1;
caml_register_generational_global_root(&(c->v_cb));
return c;
}
CAMLprim value sunml_lsolver_make_custom(value vid, value vops, value vhasops)
{
CAMLparam3(vid, vops, vhasops);
#if SUNDIALS_LIB_VERSION >= 300
SUNLinearSolver ls;
SUNLinearSolver_Ops ops;
ls = (SUNLinearSolver)malloc(sizeof *ls);
if (ls == NULL) caml_raise_out_of_memory();
ops = (SUNLinearSolver_Ops) malloc(
sizeof(struct _generic_SUNLinearSolver_Ops));
if (ops == NULL) {
free(ls);
caml_raise_out_of_memory();
}
/* Attach operations */
ops->gettype = (Int_val(vid) == 0)
? callml_custom_gettype_direct
: callml_custom_gettype_iterative;
ops->initialize = callml_custom_initialize;
ops->setup = callml_custom_setup;
ops->solve = callml_custom_solve;
ops->lastflag = NULL;
ops->free = callml_custom_free;
ops->setatimes =
Bool_val(Field(vhasops, RECORD_LSOLVER_HASOPS_SET_ATIMES))
? callml_custom_setatimes : NULL;
ops->setpreconditioner =
Bool_val(Field(vhasops, RECORD_LSOLVER_HASOPS_SET_PRECONDITIONER))
? callml_custom_setpreconditioner : NULL;
ops->setscalingvectors =
Bool_val(Field(vhasops, RECORD_LSOLVER_HASOPS_SET_SCALING_VECTORS))
? callml_custom_setscalingvectors : NULL;
ops->numiters =
Bool_val(Field(vhasops, RECORD_LSOLVER_HASOPS_GET_NUM_ITERS))
? callml_custom_numiters : NULL;
ops->resnorm =
Bool_val(Field(vhasops, RECORD_LSOLVER_HASOPS_GET_RES_NORM))
? callml_custom_resnorm : NULL;
ops->resid =
Bool_val(Field(vhasops, RECORD_LSOLVER_HASOPS_GET_RES_ID))
? callml_custom_resid : NULL;
ops->space =
Bool_val(Field(vhasops, RECORD_LSOLVER_HASOPS_GET_WORK_SPACE))
? callml_custom_space : NULL;
ls->ops = ops;
ls->content = (void *)vops;
caml_register_generational_global_root((void *)&(ls->content));
CAMLreturn(alloc_lsolver(ls));
#else
CAMLreturn(Val_unit);
#endif
}
CAMLprim value
caml_tcp_set_state(value v_tw, value v_arg)
{
CAMLparam2(v_tw, v_arg);
tcp_wrap *tw = tcp_wrap_of_value(v_tw);
if (tw->v)
failwith("caml_tcp_set_state: cannot change tw->v");
tw->v = v_arg;
caml_register_generational_global_root(&tw->v);
CAMLreturn(Val_unit);
}
CAMLprim value lwt_unix_read_job(value val_fd, value val_string, value val_offset, value val_length)
{
struct filedescr *fd = (struct filedescr *)Data_custom_val(val_fd);
long length = Long_val(val_length);
LWT_UNIX_INIT_JOB(job, read, length);
job->kind = fd->kind;
if (fd->kind == KIND_HANDLE)
job->fd.handle = fd->fd.handle;
else
job->fd.socket = fd->fd.socket;
job->length = length;
job->error_code = 0;
job->string = val_string;
job->offset = Long_val(val_offset);
caml_register_generational_global_root(&(job->string));
return lwt_unix_alloc_job(&(job->job));
}
CAMLprim value
caml_tcp_listen(value v_tw, value v_accept_cb)
{
CAMLparam2(v_tw, v_accept_cb);
tcp_wrap *tw = tcp_wrap_of_value(v_tw);
struct tcp_pcb *new_pcb;
LWIP_STUB_DPRINTF("caml_tcp_listen");
new_pcb = tcp_listen(tw->pcb);
if (new_pcb == NULL)
caml_failwith("tcp_listen: unable to listen");
/* XXX realloc a new tcp pcb wrapper so we can construct tcp_listen_pcb in ocaml */
tw->pcb = new_pcb; /* tcp_listen will deallocate the old pcb */
tw->v = v_accept_cb;
caml_register_generational_global_root(&tw->v);
tcp_arg(tw->pcb, &tw->v);
tw->desc->state = TCP_LISTEN;
tcp_accept(tw->pcb, tcp_accept_cb);
CAMLreturn(Val_unit);
}
UWT_LOCAL void
uwt__gr_enlarge__(void)
{
CAMLparam0();
CAMLlocal1(nroot);
cb_t i;
cb_t * t;
if ( uwt__global_caml_root == Val_unit ){
enum { AR_INIT_SIZE = 2};
nroot = caml_alloc(GR_ROOT_INIT_SIZE,0);
for ( i = 0 ; i < GR_ROOT_INIT_SIZE ; ++i ){
Field(nroot,i) = Val_unit;
}
uwt__global_caml_root = caml_alloc_small(AR_INIT_SIZE,0);
Field(uwt__global_caml_root,0) = nroot;
for ( i = 1 ; i < AR_INIT_SIZE ; ++i ){
Field(uwt__global_caml_root,i) = Val_unit;
}
t = malloc(AR_INIT_SIZE * GR_ROOT_INIT_SIZE * sizeof(*t));
if ( t == NULL ){
caml_raise_out_of_memory();
}
for ( i = 0; i < GR_ROOT_INIT_SIZE; ++i ){
t[i] = i;
}
uwt__global_caml_root_free_pos = t;
uwt__global_caml_root_size = GR_ROOT_INIT_SIZE;
caml_register_generational_global_root(&uwt__global_caml_root);
}
else {
const cb_t ri = (uwt__global_caml_root_size + (GR_ROOT_INIT_SIZE - 1))
/ GR_ROOT_INIT_SIZE;
const size_t ar_size = Wosize_val(uwt__global_caml_root);
const cb_t nroot_size =
uwt__global_caml_root_size + GR_ROOT_INIT_SIZE;
if ( uwt__global_caml_root_size > nroot_size ){
caml_failwith("too many lwt threads waiting for i/o");
}
if ( ri >= ar_size ){
uint64_t cn_size = ar_size * (uint64_t)(2 * GR_ROOT_INIT_SIZE);
if ( cn_size > UINT_MAX ){
cn_size = UINT_MAX;
}
nroot = caml_alloc(ar_size*2,0);
for ( i = 0 ; i < ar_size ; ++i ){
Store_field(nroot,i,Field(uwt__global_caml_root,i));
}
for ( i = ar_size ; i < ar_size * 2 ; ++i ){
Field(nroot,i) = Val_unit;
}
t = realloc(uwt__global_caml_root_free_pos,cn_size * sizeof(*t));
if ( t == NULL ){
caml_raise_out_of_memory();
}
caml_modify_generational_global_root(&uwt__global_caml_root,nroot);
uwt__global_caml_root_free_pos = t;
}
nroot = caml_alloc(GR_ROOT_INIT_SIZE,0);
cb_t j;
for ( i = 0, j = uwt__global_caml_root_size ;
i < GR_ROOT_INIT_SIZE ;
++i, ++j ){
Field(nroot,i) = Val_unit;
uwt__global_caml_root_free_pos[j] = j;
}
Store_field(uwt__global_caml_root,ri,nroot);
uwt__global_caml_root_size = nroot_size;
}
CAMLreturn0;
}
