CAMLexport char * caml_strdup(const char * s)
{
size_t slen = strlen(s);
char * res = caml_stat_alloc(slen + 1);
memcpy(res, s, slen + 1);
return res;
}
void caml_realloc_stack(asize_t required_space)
{
asize_t size;
value * new_low, * new_high, * new_sp;
value * p;
size = caml_stack_high - caml_stack_low;
do {
if (size >= caml_max_stack_size) caml_raise_stack_overflow();
size *= 2;
} while (size < caml_stack_high - caml_extern_sp + required_space);
new_low = (value *) caml_stat_alloc(size * sizeof(value));
new_high = new_low + size;
#define shift(ptr) \
((char *) new_high - ((char *) caml_stack_high - (char *) (ptr)))
new_sp = (value *) shift(caml_extern_sp);
memmove((char *) new_sp,
(char *) caml_extern_sp,
(caml_stack_high - caml_extern_sp) * sizeof(value));
caml_stat_free(caml_stack_low);
caml_trapsp = (value *) shift(caml_trapsp);
caml_trap_barrier = (value *) shift(caml_trap_barrier);
for (p = caml_trapsp; p < new_high; p = Trap_link(p))
Trap_link(p) = (value *) shift(Trap_link(p));
caml_stack_low = new_low;
caml_stack_high = new_high;
caml_stack_threshold = caml_stack_low + Stack_threshold / sizeof (value);
caml_extern_sp = new_sp;
#undef shift
}
struct caml_minor_tables* caml_alloc_minor_tables()
{
struct caml_minor_tables* r =
caml_stat_alloc(sizeof(struct caml_minor_tables));
memset(r, 0, sizeof(*r));
return r;
}
CAMLprim value PQexecPrepared_stub(
value v_conn, value v_stm_name, value v_params, value v_binary_params)
{
CAMLparam1(v_conn);
PGconn *conn = get_conn(v_conn);
np_callback *np_cb = get_conn_cb(v_conn);
PGresult *res;
size_t len = caml_string_length(v_stm_name) + 1;
char *stm_name = caml_stat_alloc(len);
size_t nparams = Wosize_val(v_params);
const char * const *params = copy_params(v_params, nparams);
int *formats, *lengths;
copy_binary_params(v_params, v_binary_params, nparams, &formats, &lengths);
memcpy(stm_name, String_val(v_stm_name), len);
caml_enter_blocking_section();
res = PQexecPrepared(conn, stm_name, nparams, params, lengths, formats, 0);
free(stm_name);
free_binary_params(formats, lengths);
free_params(params, nparams);
caml_leave_blocking_section();
CAMLreturn(alloc_result(res, np_cb));
#else
CAMLprim value PQexecPrepared_stub(
value __unused v_conn, value __unused v_stm_name, value __unused v_params,
value __unused v_binary_params)
{
caml_failwith("Postgresql.exec_prepared: not supported");
return Val_unit;
#endif
}
/*CAMLprim*/ value caml_float_of_substring(value vs, value idx, value l)
{
char parse_buffer[64];
char * buf, * src, * dst, * end;
mlsize_t len, lenvs;
double d;
intnat flen = Long_val(l);
intnat fidx = Long_val(idx);
lenvs = caml_string_length(vs);
len =
fidx >= 0 && fidx < lenvs && flen > 0 && flen <= lenvs - fidx
? flen : 0;
buf = len < sizeof(parse_buffer) ? parse_buffer : caml_stat_alloc(len + 1);
src = String_val(vs) + fidx;
dst = buf;
while (len--) {
char c = *src++;
if (c != '_') *dst++ = c;
}
*dst = 0;
if (dst == buf) goto error;
d = strtod((const char *) buf, &end);
if (end != dst) goto error;
if (buf != parse_buffer) caml_stat_free(buf);
return caml_copy_double(d);
error:
if (buf != parse_buffer) caml_stat_free(buf);
caml_failwith("float_of_string");
}
CAMLprim value PQconnectdb_stub(value v_conn_info, value v_startonly)
{
PGconn *conn;
value v_conn;
PGcancel *cancel;
if (Bool_val(v_startonly)) {
conn = PQconnectStart(String_val(v_conn_info));
cancel = PQgetCancel(conn);
}
else {
size_t len = caml_string_length(v_conn_info) + 1;
char *conn_info = caml_stat_alloc(len);
memcpy(conn_info, String_val(v_conn_info), len);
caml_enter_blocking_section();
conn = PQconnectdb(conn_info);
cancel = PQgetCancel(conn);
free(conn_info);
caml_leave_blocking_section();
}
/* One may raise this 30 to 500 for instance if the program takes
responsibility of closing connections */
v_conn = caml_alloc_small(3, Abstract_tag);
set_conn(v_conn, conn);
set_conn_cb(v_conn, NULL);
set_cancel_obj(v_conn, cancel);
return v_conn;
}
CAMLprim value PQexecParams_stub(
value v_conn, value v_query, value v_params, value v_binary_params)
{
CAMLparam1(v_conn);
PGconn *conn = get_conn(v_conn);
np_callback *np_cb = get_conn_cb(v_conn);
PGresult *res;
size_t len = caml_string_length(v_query) + 1;
char *query = caml_stat_alloc(len);
size_t nparams = Wosize_val(v_params);
const char * const *params = copy_params(v_params, nparams);
int *formats, *lengths;
copy_binary_params(v_params, v_binary_params, nparams, &formats, &lengths);
memcpy(query, String_val(v_query), len);
caml_enter_blocking_section();
res =
(nparams == 0)
? PQexec(conn, query)
: PQexecParams(conn, query, nparams, NULL, params, lengths, formats, 0);
free_binary_params(formats, lengths);
free_params(params, nparams);
free(query);
caml_leave_blocking_section();
CAMLreturn(alloc_result(res, np_cb));
}
/* Processes a (Instruct.debug_event list array) into a form suitable
for quick lookup and registers it for the (code_start,code_size) pc range. */
CAMLprim value caml_add_debug_info(code_t code_start, value code_size,
value events_heap)
{
CAMLparam1(events_heap);
struct debug_info *debug_info;
/* build the OCaml-side debug_info value */
debug_info = caml_stat_alloc(sizeof(struct debug_info));
debug_info->start = code_start;
debug_info->end = (code_t)((char*) code_start + Long_val(code_size));
if (events_heap == Val_unit) {
debug_info->events = NULL;
debug_info->num_events = 0;
debug_info->already_read = 0;
} else {
debug_info->events =
process_debug_events(code_start, events_heap, &debug_info->num_events);
debug_info->already_read = 1;
}
caml_ext_table_add(&caml_debug_info, debug_info);
CAMLreturn(Val_unit);
}
CAMLprim value caml_float_of_string(value vs)
{
char parse_buffer[64];
char * buf, * src, * dst, * end;
mlsize_t len;
double d;
len = caml_string_length(vs);
buf = len < sizeof(parse_buffer) ? parse_buffer : caml_stat_alloc(len + 1);
src = String_val(vs);
dst = buf;
while (len--) {
char c = *src++;
if (c != '_') *dst++ = c;
}
*dst = 0;
if (dst == buf) goto error;
d = strtod((const char *) buf, &end);
if (end != dst) goto error;
if (buf != parse_buffer) caml_stat_free(buf);
return caml_copy_double(d);
error:
if (buf != parse_buffer) caml_stat_free(buf);
caml_failwith("float_of_string");
}
CAMLprim value mmdb_ml_open(value s)
{
CAMLparam1(s);
CAMLlocal1(mmdb_handle);
if (polymorphic_variants.poly_bool == 0 ||
polymorphic_variants.poly_float == 0 ||
polymorphic_variants.poly_int == 0 ||
polymorphic_variants.poly_string == 0) {
polymorphic_variants.poly_bool = caml_hash_variant("Bool");
polymorphic_variants.poly_float = caml_hash_variant("Float");
polymorphic_variants.poly_int = caml_hash_variant("Int");
polymorphic_variants.poly_string = caml_hash_variant("String");
}
unsigned int len = caml_string_length(s);
char *copied = caml_strdup(String_val(s));
if (strlen(copied) != (size_t)len) {
caml_failwith("Could not open MMDB database");
}
MMDB_s *this_db = caml_stat_alloc(sizeof(*this_db));
int status = MMDB_open(copied, MMDB_MODE_MMAP, this_db);
mmdb_handle = caml_alloc_custom(&mmdb_custom_ops, sizeof(*this_db), 0, 1);
check_status(status);
memcpy(Data_custom_val(mmdb_handle), this_db, sizeof(*this_db));
caml_stat_free(this_db);
caml_stat_free(copied);
CAMLreturn(mmdb_handle);
}
CAMLprim value mmdb_ml_dump_per_ip(value ip, value mmdb)
{
CAMLparam2(ip, mmdb);
CAMLlocal1(pulled_string);
unsigned int len = caml_string_length(ip);
char *as_string = caml_strdup(String_val(ip));
if (strlen(as_string) != (size_t)len) {
caml_failwith("Could not copy IP address properly");
}
MMDB_s *as_mmdb = (MMDB_s*)Data_custom_val(mmdb);
int gai_error = 0, mmdb_error = 0;
MMDB_lookup_result_s *result = caml_stat_alloc(sizeof(*result));
*result = MMDB_lookup_string(as_mmdb, as_string, &gai_error, &mmdb_error);
MMDB_entry_data_list_s *entry_data_list = NULL;
int status = MMDB_get_entry_data_list(&result->entry, &entry_data_list);
check_status(status);
char *pulled_from_db = data_from_dump(entry_data_list);
pulled_string = caml_copy_string(pulled_from_db);
caml_stat_free(result);
caml_stat_free(as_string);
caml_stat_free(pulled_from_db);
free(entry_data_list);
as_mmdb = NULL;
CAMLreturn(pulled_string);
}
static segment *segment_cons(void *begin, void *end, segment *tl) {
segment *lnk = caml_stat_alloc(sizeof(segment));
lnk->begin = begin;
lnk->end = end;
lnk->next = tl;
return lnk;
}
CAMLprim value caml_register_named_value(value vname, value val)
{
struct named_value * nv;
const char * name = String_val(vname);
size_t namelen = strlen(name);
unsigned int h = hash_value_name(name);
int found = 0;
caml_plat_lock(&named_value_lock);
for (nv = named_value_table[h]; nv != NULL; nv = nv->next) {
if (strcmp(name, nv->name) == 0) {
caml_modify_root(nv->val, val);
found = 1;
break;
}
}
if (!found) {
nv = (struct named_value *)
caml_stat_alloc(sizeof(struct named_value) + namelen);
memcpy(nv->name, name, namelen + 1);
nv->val = caml_create_root(val);
nv->next = named_value_table[h];
named_value_table[h] = nv;
}
caml_plat_unlock(&named_value_lock);
return Val_unit;
}
CAMLexport char * caml_strconcat(int n, ...)
{
va_list args;
char * res, * p;
size_t len;
int i;
len = 0;
va_start(args, n);
for (i = 0; i < n; i++) {
const char * s = va_arg(args, const char *);
len += strlen(s);
}
va_end(args);
res = caml_stat_alloc(len + 1);
va_start(args, n);
p = res;
for (i = 0; i < n; i++) {
const char * s = va_arg(args, const char *);
size_t l = strlen(s);
memcpy(p, s, l);
p += l;
}
va_end(args);
*p = 0;
return res;
}
/* Create data associated with a select operation */
LPSELECTDATA select_data_new (LPSELECTDATA lpSelectData, SELECTTYPE EType)
{
/* Allocate the data structure */
LPSELECTDATA res;
DWORD i;
res = (LPSELECTDATA)caml_stat_alloc(sizeof(SELECTDATA));
/* Init common data */
list_init((LPLIST)res);
list_next_set((LPLIST)res, (LPLIST)lpSelectData);
res->EType = EType;
res->nResultsCount = 0;
/* Data following are dedicated to APC like call, they
will be initialized if required. For now they are set to
invalid values.
*/
res->funcWorker = NULL;
res->nQueriesCount = 0;
res->EState = SELECT_STATE_NONE;
res->nError = 0;
res->lpWorker = NULL;
return res;
}
CAMLprim value statvfs_stub (value v_path)
{
CAMLparam1(v_path);
CAMLlocal1(v_stat);
struct statvfs s;
int ret, len = caml_string_length(v_path) + 1;
char *pathname = caml_stat_alloc(len);
memcpy(pathname, String_val(v_path), len);
caml_enter_blocking_section();
ret = statvfs(pathname,&s);
caml_leave_blocking_section();
caml_stat_free(pathname);
if (ret != 0) uerror("statvfs",v_path);
v_stat = caml_alloc(11, 0);
Store_field(v_stat, 0, Val_int(s.f_bsize));
Store_field(v_stat, 1, Val_int(s.f_frsize));
Store_field(v_stat, 2, Val_int(s.f_blocks));
Store_field(v_stat, 3, Val_int(s.f_bfree));
Store_field(v_stat, 4, Val_int(s.f_bavail));
Store_field(v_stat, 5, Val_int(s.f_files));
Store_field(v_stat, 6, Val_int(s.f_ffree));
Store_field(v_stat, 7, Val_int(s.f_favail));
Store_field(v_stat, 8, Val_int(s.f_fsid));
Store_field(v_stat, 9, Val_int(s.f_flag));
Store_field(v_stat,10, Val_int(s.f_namemax));
CAMLreturn(v_stat);
}
static void caml_split_and_wait_r(CAML_R, char *blob, caml_global_context **split_contexts, size_t how_many, sem_t *semaphore)
{
//DUMP();
//#ifdef NATIVE_CODE
// fprintf(stderr, "@@@@@ In the parent context caml_bottom_of_stack is %p\n", caml_bottom_of_stack);
//#endif // #ifdef NATIVE_CODE
//DUMP();
caml_gc_compaction_r(ctx, Val_unit); //!!!!!
//DUMP();
struct caml_thread_arguments *argument_struct_array =
caml_stat_alloc(sizeof(struct caml_thread_arguments) * how_many);
int i;
for(i = 0; i < how_many; i ++){
//sleep(10); // FIXME: !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
pthread_t thread;
// struct caml_thread_arguments *args = caml_stat_alloc(sizeof(struct caml_thread_arguments));
struct caml_thread_arguments *args = argument_struct_array + i;
int pthread_create_result;
args->parent_context = ctx;
args->blob = blob;
args->semaphore = semaphore;
args->split_contexts = split_contexts;
args->index = i;
pthread_create_result =
pthread_create(&thread, NULL, caml_deserialize_and_run_in_this_thread_as_thread_function, args);
if(pthread_create_result != 0)
caml_failwith_r(ctx, "pthread_create failed"); // FIXME: blob is leaked is this case. Maybe we should just make this a fatal error
} /* for */
/* Wait for the last thread to use the blob: */
DUMP("waiting for all %i threads to deserialize", (int)how_many);
for(i = 0; i < how_many; i ++){
DUMP("about to P");
caml_enter_blocking_section_r(ctx);
caml_p_semaphore(semaphore);
//int sem_wait_result = sem_wait(semaphore);
caml_leave_blocking_section_r(ctx);
/* DUMP("right after P: sem_wait returned %i, errno is %i", sem_wait_result, (int)errno); */
/* DUMP("is errno EINTR? %i", errno == EINTR); */
/* DUMP("is errno EINVAL? %i", errno == EINVAL); */
/* DUMP("is errno EAGAIN? %i", errno == EAGAIN); */
/* DUMP("is errno ETIMEDOUT? %i", errno == ETIMEDOUT); */
/* assert(sem_wait_result == 0); // !!!!!!!!!!!!!!!!!!!!!!!!!!! */
DUMP("one child finished with the blob; waiting for %i more", (int)(how_many - i - 1));
}
DUMP("every thread has deserialized");
/* Now we can free the argument structures, since all threads have started. */
free(argument_struct_array);
// !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
/* #define MAXK 0 */
/* int k; for(k = MAXK; k > 0; k --) { sleep(1); DUMP("countdown: %i", k); DUMP("GC'ing"); caml_gc_compaction_r(ctx, Val_unit); DUMP("GC'd"); } */
/* // ???????????? Re-activate the following line when testing */
/* DUMP("the countdown is over"); */
//USLEEP("", 3);
DUMP("GC'ing"); caml_gc_compaction_r(ctx, Val_unit); DUMP("GC'd");
//DUMP("and now we're screwed. Aren't we?");
// !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
}
value *
ml_cairo_make_root (value v)
{
value *root = caml_stat_alloc (sizeof (value *));
*root = v;
caml_register_global_root (root);
return root;
}
static gnttab_wrap *
gnttab_wrap_alloc(grant_ref_t ref)
{
gnttab_wrap *gw = caml_stat_alloc(sizeof(gnttab_wrap));
gw->ref = ref;
gw->page = NULL;
return gw;
}
static value alloc_not_event(void) {
struct not_event *p;
value r;
p = caml_stat_alloc(sizeof(struct not_event));
r = caml_alloc_custom(¬_event_ops, sizeof(p), 0, 1);
*(Not_event_val(r)) = p;
return r;
};
static value alloc_poll_aggreg(void) {
struct poll_aggreg *p;
value r;
p = caml_stat_alloc(sizeof(struct poll_aggreg));
r = caml_alloc_custom(&poll_aggreg_ops, sizeof(p), 1, 0);
*(Poll_aggreg_val(r)) = p;
return r;
};
static value alloc_poll_mem(int n) {
struct pollfd *p;
value r;
p = caml_stat_alloc(n * sizeof(struct pollfd));
r = caml_alloc_custom(&poll_mem_ops, sizeof(p), n, 100000);
*(Poll_mem_val(r)) = p;
return r;
};
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;
}
/* XXX: WARNING: this function leaks memory! No way around that if
syslog is called in a multi-threaded environment!
Therefore it shouldn't be called too often. What for, anyway? */
CAMLprim value openlog_stub(value v_ident, value v_option, value v_facility) {
int len = caml_string_length(v_ident) + 1;
char *ident = caml_stat_alloc(len);
memcpy(ident, String_val(v_ident), len);
caml_enter_blocking_section();
openlog(ident, Int_val(v_option), Int_val(v_facility));
caml_leave_blocking_section();
return Val_unit;
}
static pbuf_list *
pbuf_list_alloc(struct pbuf *p)
{
pbuf_list *pl;
pl = caml_stat_alloc(sizeof(pbuf_list));
pl->next = NULL;
pl->p = p;
return pl;
}
PREFIX value ml_elm_naviframe_item_pop_cb_set(value v_it, value v_fun)
{
CAMLparam2(v_it, v_fun);
value* data = caml_stat_alloc(sizeof(value));
caml_register_global_root(data);
elm_naviframe_item_pop_cb_set((Elm_Object_Item*) v_it,
ml_Elm_Naviframe_Item_Pop_Cb, data);
CAMLreturn(Val_unit);
}
void caml_init_frame_descriptors_r(CAML_R)
{
//fprintf(stderr, "$$$$$ Context %p: caml_init_frame_descriptors_r: BEGIN\n", ctx);
caml_acquire_global_lock();
intnat num_descr, tblsize, i, j, len;
intnat * tbl;
frame_descr * d;
uintnat nextd;
uintnat h;
caml_link *lnk;
static int inited = 0;
if (!inited) {
for (i = 0; caml_frametable[i] != 0; i++)
caml_register_frametable_r(ctx, caml_frametable[i]);
inited = 1;
}
/* Count the frame descriptors */
num_descr = 0;
iter_list(frametables,lnk) {
num_descr += *((intnat*) lnk->data);
}
/* The size of the hashtable is a power of 2 greater or equal to
2 times the number of descriptors */
tblsize = 4;
while (tblsize < 2 * num_descr) tblsize *= 2;
/* Allocate the hash table */
caml_frame_descriptors =
(frame_descr **) caml_stat_alloc(tblsize * sizeof(frame_descr *));
for (i = 0; i < tblsize; i++) caml_frame_descriptors[i] = NULL;
caml_frame_descriptors_mask = tblsize - 1;
/* Fill the hash table */
iter_list(frametables,lnk) {
tbl = (intnat*) lnk->data;
len = *tbl;
d = (frame_descr *)(tbl + 1);
for (j = 0; j < len; j++) {
h = Hash_retaddr(d->retaddr);
while (caml_frame_descriptors[h] != NULL) {
h = (h+1) & caml_frame_descriptors_mask;
}
caml_frame_descriptors[h] = d;
nextd =
((uintnat)d +
sizeof(char *) + sizeof(short) + sizeof(short) +
sizeof(short) * d->num_live + sizeof(frame_descr *) - 1)
& -sizeof(frame_descr *);
if (d->frame_size & 1) nextd += 8;
d = (frame_descr *) nextd;
}
}
CAMLexport void caml_register_custom_operations(struct custom_operations * ops)
{
struct custom_operations_list * l =
caml_stat_alloc(sizeof(struct custom_operations_list));
Assert(ops->identifier != NULL);
Assert(ops->deserialize != NULL);
l->ops = ops;
l->next = custom_ops_table;
custom_ops_table = l;
}
struct custom_operations * caml_final_custom_operations(final_fun fn)
{
struct custom_operations_list * l;
struct custom_operations * ops;
for (l = custom_ops_final_table; l != NULL; l = l->next)
if (l->ops->finalize == fn) return l->ops;
ops = caml_stat_alloc(sizeof(struct custom_operations));
ops->identifier = "_final";
ops->finalize = fn;
ops->compare = custom_compare_default;
ops->hash = custom_hash_default;
ops->serialize = custom_serialize_default;
ops->deserialize = custom_deserialize_default;
l = caml_stat_alloc(sizeof(struct custom_operations_list));
l->ops = ops;
l->next = custom_ops_final_table;
custom_ops_final_table = l;
return ops;
}
CAMLprim value syslog_stub(value v_priority, value v_str) {
int len = caml_string_length(v_str) + 1;
char *str = caml_stat_alloc(len);
memcpy(str, String_val(v_str), len);
caml_enter_blocking_section();
syslog(Int_val(v_priority), str);
free(str);
caml_leave_blocking_section();
return Val_unit;
}
