CAMLprim value caml_thread_new(value clos)
{
caml_thread_t th;
value vthread = Val_unit;
value descr;
DWORD th_id;
Begin_roots2 (clos, vthread)
/* Create a finalized value to hold thread handle */
vthread = alloc_final(sizeof(struct caml_thread_handle) / sizeof(value),
caml_thread_finalize, 1, 1000);
((struct caml_thread_handle *)vthread)->handle = NULL;
/* Create a descriptor for the new thread */
descr = alloc_tuple(sizeof(struct caml_thread_descr) / sizeof(value));
Ident(descr) = Val_long(thread_next_ident);
Start_closure(descr) = clos;
Threadhandle(descr) = (struct caml_thread_handle *) vthread;
thread_next_ident++;
/* Create an info block for the current thread */
th = (caml_thread_t) stat_alloc(sizeof(struct caml_thread_struct));
th->descr = descr;
#ifdef NATIVE_CODE
th->bottom_of_stack = NULL;
th->exception_pointer = NULL;
th->local_roots = NULL;
#else
/* Allocate the stacks */
th->stack_low = (value *) stat_alloc(Thread_stack_size);
th->stack_high = th->stack_low + Thread_stack_size / sizeof(value);
th->stack_threshold = th->stack_low + Stack_threshold / sizeof(value);
th->sp = th->stack_high;
th->trapsp = th->stack_high;
th->local_roots = NULL;
th->external_raise = NULL;
th->backtrace_pos = 0;
th->backtrace_buffer = NULL;
th->backtrace_last_exn = Val_unit;
#endif
/* Add thread info block to the list of threads */
th->next = curr_thread->next;
th->prev = curr_thread;
curr_thread->next->prev = th;
curr_thread->next = th;
/* Fork the new thread */
th->wthread =
CreateThread(NULL, 0, caml_thread_start, (void *) th, 0, &th_id);
if (th->wthread == NULL) {
/* Fork failed, remove thread info block from list of threads */
th->next->prev = curr_thread;
curr_thread->next = th->next;
#ifndef NATIVE_CODE
stat_free(th->stack_low);
#endif
stat_free(th);
caml_wthread_error("Thread.create");
}
((struct caml_thread_handle *)vthread)->handle = th->wthread;
End_roots();
return descr;
}
value caml_mpi_alloc_group(MPI_Group g)
{
value res =
alloc_final(1 + (sizeof(MPI_Group) + sizeof(value) - 1) / sizeof(value),
caml_mpi_finalize_group, 1, 100);
Group_val(res) = g;
return res;
}
value caml_mpi_alloc_comm(MPI_Comm c)
{
value res =
alloc_final(1 + (sizeof(MPI_Comm) + sizeof(value) - 1) / sizeof(value),
caml_mpi_finalize_comm, 1, 100);
Comm_val(res) = c;
return res;
}
CAMLprim value caml_thread_initialize(value unit)
{
value vthread = Val_unit;
value descr;
HANDLE tick_thread;
DWORD th_id;
/* Protect against repeated initialization (PR#1325) */
if (curr_thread != NULL) return Val_unit;
Begin_root (vthread);
/* Initialize the main mutex and acquire it */
caml_mutex = CreateMutex(NULL, TRUE, NULL);
if (caml_mutex == NULL) caml_wthread_error("Thread.init");
/* Initialize the TLS keys */
thread_descriptor_key = TlsAlloc();
last_channel_locked_key = TlsAlloc();
/* Create a finalized value to hold thread handle */
vthread = alloc_final(sizeof(struct caml_thread_handle) / sizeof(value),
caml_thread_finalize, 1, 1000);
((struct caml_thread_handle *)vthread)->handle = NULL;
/* Create a descriptor for the current thread */
descr = alloc_tuple(sizeof(struct caml_thread_descr) / sizeof(value));
Ident(descr) = Val_long(thread_next_ident);
Start_closure(descr) = Val_unit;
Threadhandle(descr) = (struct caml_thread_handle *) vthread;
thread_next_ident++;
/* Create an info block for the current thread */
curr_thread =
(caml_thread_t) stat_alloc(sizeof(struct caml_thread_struct));
DuplicateHandle(GetCurrentProcess(), GetCurrentThread(),
GetCurrentProcess(), &(curr_thread->wthread),
0, FALSE, DUPLICATE_SAME_ACCESS);
if (curr_thread->wthread == NULL) caml_wthread_error("Thread.init");
((struct caml_thread_handle *)vthread)->handle = curr_thread->wthread;
curr_thread->descr = descr;
curr_thread->next = curr_thread;
curr_thread->prev = curr_thread;
/* The stack-related fields will be filled in at the next
enter_blocking_section */
/* Associate the thread descriptor with the thread */
TlsSetValue(thread_descriptor_key, (void *) curr_thread);
/* Set up the hooks */
prev_scan_roots_hook = scan_roots_hook;
scan_roots_hook = caml_thread_scan_roots;
enter_blocking_section_hook = caml_thread_enter_blocking_section;
leave_blocking_section_hook = caml_thread_leave_blocking_section;
try_leave_blocking_section_hook = caml_thread_try_leave_blocking_section;
caml_channel_mutex_free = caml_io_mutex_free;
caml_channel_mutex_lock = caml_io_mutex_lock;
caml_channel_mutex_unlock = caml_io_mutex_unlock;
caml_channel_mutex_unlock_exn = caml_io_mutex_unlock_exn;
/* Fork the tick thread */
tick_thread = CreateThread(NULL, 0, caml_thread_tick, NULL, 0, &th_id);
if (tick_thread == NULL) caml_wthread_error("Thread.init");
CloseHandle(tick_thread);
End_roots();
return Val_unit;
}
value camlidl_pack_interface(void * intf, camlidl_ctx ctx)
{
value res = alloc_final(2, camlidl_finalize_interface, 0, 1);
Field(res, 1) = (value) intf;
if (ctx != NULL && (ctx->flags & CAMLIDL_ADDREF)) {
struct IUnknown * i = (struct IUnknown *) intf;
i->lpVtbl->AddRef(i);
}
return res;
}
value svec_wrap_cptr(value cptr, value finalize, value lengthv)
{
value sv;
sv = alloc_final(SvecSize, &svec_finalize , SvecHeapSpace, MAX_FFI_ALLOC);
initialize((value *) Svec_val(sv),cptr);
initialize(&Field(sv,2),lengthv);
initialize(&Field(sv,3), finalize);
return sv;
}
value svec_make(value lengthv)
{
value sv;
sv = alloc_final(SvecSize, &svec_finalize, SvecHeapSpace, MAX_FFI_ALLOC);
initialize((value *) Svec_val(sv), (value) mosml_ffi_alloc((size_t) Long_val(lengthv)));
initialize(&Field(sv,2),lengthv);
initialize(&Field(sv,3),(value) &mosml_ffi_free);
return sv;
}
CAMLprim value ocaml_c_fastfield_dlopen(value ml_str)
{
CAMLparam1(ml_str);
CAMLlocal1(block);
block=alloc_final(2, &finalize_dl_handle,1,100);
fprintf(stderr,"Calling dlopen(\"%s\")\n",String_val(ml_str));fflush(stderr); /* DDD */
Store_c_field(block,1,dlopen(String_val(ml_str),RTLD_NOW));
fprintf(stderr,"Called dlopen(\"%s\")\n",String_val(ml_str));fflush(stderr);
/* Note: dlopen may have returned the NULL handle. This is okay. */
CAMLreturn(block);
}
value make_ht (void)
{
value block;
hash_table_t *ht = create_tab(256);
if (ht != NULL)
{
block = alloc_final(2, fin_ht, sizeof(addr_list_t *) * 256, 100000);
Field(block,1)=(value)ht;
return block;
}
failwith ("Could not allocate address table.");
return block;
}
value largeint_alloc()
{
value res;
int n;
/* adjust_gc_speed tweak */
if( gmp_memfunc_set == 0 )
{
mp_set_memory_functions( &mosml_gmp_allocate, &mosml_gmp_reallocate,
NULL ); /* NULL -> use default free() */
gmp_memfunc_set = 1;
}
/* inline MPINT tweak */
n = 1 + (sizeof(MP_INT) + sizeof(value) - 1) / sizeof(value);
res = alloc_final(n, &largeint_finalize, n, MAX_GMP_ALLOC);
return res;
}
value dbresult_alloc(MYSQL_RES* dbres) {
value res = alloc_final(3, &dbresult_finalize, 1, 10000);
MYSQL_ROW_OFFSET* index = NULL;
initialize(&Field(res, 1), (value)dbres);
if (dbres != NULL) {
int numrows = mysql_num_rows(dbres);
if (numrows > 0) {
int i = 0;
MYSQL_ROW row;
index = (MYSQL_ROW_OFFSET*)
(stat_alloc(sizeof(MYSQL_ROW_OFFSET) * numrows));
for (i=0; i<numrows; i++) {
index[i] = mysql_row_tell(dbres);
mysql_fetch_row(dbres);
}
}
}
initialize(&Field(res, 2), (value)index);
return res;
}
/* Similar, but calls the finalize fn with the pointer and the length,
as required by, e.g. munmap */
value svec_wrap_cptr2(value cptr, value finalize, value lengthv)
{
value sv, buffv;
size_t len;
len = Long_val(lengthv) - sizeof(header_t) - sizeof(value);
if (jit_ffi_debug)
fprintf(stderr,"svec_wrap_cptr2: calling alloc_final: finalize=%p buffer=%p(length=%ld[%d]).\n",
(void *) finalize,(void *)cptr,Long_val(lengthv),len);
sv = alloc_final(SvecSize + 1, &svec_finalize2 , SvecHeapSpace, MAX_FFI_ALLOC);
if (jit_ffi_debug)
fprintf(stderr,"svec_wrap_cptr2: calling mosml_ffi_alloc_wrap: buffer=%p(length=%d).\n",
(void *)cptr,len);
buffv = (value) mosml_ffi_alloc_wrap((void *)cptr,len);
if (jit_ffi_debug)
fprintf(stderr,"svec_wrap_cptr2: initializing: finalize=%p buffv=%p(length=%d[%ld]).\n",
(void *) finalize,(void *)buffv,len,string_length(buffv));
initialize((value *) Svec_val(sv), buffv);
initialize(&Field(sv,2), Val_long(len));
initialize(&Field(sv,3), finalize);
initialize(&Field(sv,4), Long_val(lengthv));
return sv;
}
value pgresult_alloc(PGresult* pgres)
{
value res = alloc_final(2, &pgresult_finalize, 1, 10000);
initialize(&Field(res, 1), (value)pgres);
return res;
}