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; }