CAMLprim value camltk_setvar(value var, value contents) { char *s; char *stable_var = NULL; char *utf_contents; CheckInit(); /* SetVar makes a copy of the contents. */ /* In case we have write traces in OCaml, it's better to make sure that var doesn't move... */ stable_var = string_to_c(var); utf_contents = caml_string_to_tcl(contents); s = (char *)Tcl_SetVar(cltclinterp,stable_var, utf_contents, TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG); stat_free(stable_var); if( s == utf_contents ){ tk_error("camltk_setvar: Tcl_SetVar returned strange result. Call the author of mlTk!"); } stat_free(utf_contents); if (s == NULL) tk_error(Tcl_GetStringResult(cltclinterp)); else return(Val_unit); }
static DWORD WINAPI caml_thread_start(void * arg) { caml_thread_t th = (caml_thread_t) arg; value clos; /* Associate the thread descriptor with the thread */ TlsSetValue(thread_descriptor_key, (void *) th); TlsSetValue(last_channel_locked_key, NULL); /* Acquire the global mutex and set up the stack variables */ leave_blocking_section(); /* Callback the closure */ clos = Start_closure(th->descr); modify(&(Start_closure(th->descr)), Val_unit); callback_exn(clos, Val_unit); /* Remove th from the doubly-linked list of threads */ th->next->prev = th->prev; th->prev->next = th->next; /* Release the main mutex (forever) */ ReleaseMutex(caml_mutex); #ifndef NATIVE_CODE /* Free the memory resources */ stat_free(th->stack_low); if (th->backtrace_buffer != NULL) free(th->backtrace_buffer); #endif /* Free the thread descriptor */ stat_free(th); /* The thread now stops running */ return 0; }
value string_mlval(value val) { value s; byteoffset_t res; extern_size = INITIAL_EXTERN_SIZE; extern_block = (byteoffset_t *) stat_alloc(extern_size * sizeof(unsigned long)); extern_pos = 0; extern_table_size = INITIAL_EXTERN_TABLE_SIZE; alloc_extern_table(); extern_table_used = 0; res = emit_all(val); stat_free((char *) extern_table); /* We can allocate a string in the heap since the argument value is not used from now on. */ if (extern_pos == 0) { s = alloc_string(8); ((size_t *)s)[0] = (size_t)extern_pos; ((size_t *)s)[1] = (size_t)res; } else { s = alloc_string(4 + extern_pos * sizeof(unsigned long)); ((size_t *)s)[0] = (size_t)extern_pos; memmove(&Byte(s, 4), (char *)extern_block, extern_pos * sizeof(unsigned long)); } stat_free((char *) extern_block); return s; }
/* Parsing results */ CAMLprim value camltk_splitlist (value v) { int argc; char **argv; int result; char *utf; CheckInit(); utf = caml_string_to_tcl(v); /* argv is allocated by Tcl, to be freed by us */ result = Tcl_SplitList(cltclinterp,utf,&argc,&argv); switch(result) { case TCL_OK: { value res = copy_string_list(argc,argv); Tcl_Free((char *)argv); /* only one large block was allocated */ /* argv points into utf: utf must be freed after argv are freed */ stat_free( utf ); return res; } case TCL_ERROR: default: stat_free( utf ); tk_error(Tcl_GetStringResult(cltclinterp)); } }
/* ML type: fddvar vector -> fddvar vector -> pairSet */ EXTERNML value mlfdd_setpairs(value oldvar, value newvar) /* ML */ { int size, i, *o, *n; bddPair *pairs; value result; size = Wosize_val(oldvar); /* we use stat_alloc which guarantee that we get the memory (or it will raise an exception). */ o = (int *) stat_alloc(sizeof(int) * size); n = (int *) stat_alloc(sizeof(int) * size); for (i=0; i<size; i++) { o[i] = Int_val(Field(oldvar, i)); n[i] = Int_val(Field(newvar, i)); } pairs = bdd_newpair(); fdd_setpairs(pairs, o, n, size); /* memory allocated with stat_alloc, should be freed with stat_free.*/ stat_free((char *) o); stat_free((char *) n); result = mlbdd_alloc_final(2, &mlbdd_pair_finalize); PairSet_val(result) = pairs; return result; }
static void mlbdd_freegcstrings() { if(printgc) { stat_free(pregc); stat_free(postgc); printgc = 0; } }
/* Fill a preallocated vector arguments, doing expansion and all. * Assumes Tcl will * not tamper with our strings * make copies if strings are "persistent" */ int fill_args (char **argv, int where, value v) { value l; switch (Tag_val(v)) { case 0: argv[where] = caml_string_to_tcl(Field(v,0)); /* must free by stat_free */ return (where + 1); case 1: for (l=Field(v,0); Is_block(l); l=Field(l,1)) where = fill_args(argv,where,Field(l,0)); return where; case 2: { char **tmpargv; char *merged; int i; int size = argv_size(Field(v,0)); tmpargv = (char **)stat_alloc((size + 1) * sizeof(char *)); fill_args(tmpargv,0,Field(v,0)); tmpargv[size] = NULL; merged = Tcl_Merge(size,tmpargv); for(i = 0; i<size; i++){ stat_free(tmpargv[i]); } stat_free((char *)tmpargv); /* must be freed by stat_free */ argv[where] = (char*)stat_alloc(strlen(merged)+1); strcpy(argv[where], merged); Tcl_Free(merged); return (where + 1); } default: tk_error("fill_args: illegal tag"); } }
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; }
void set_minor_heap_size (size_t size) { char *new_heap; value **new_table; assert (size >= Minor_heap_min); assert (size <= Minor_heap_max); assert (size % sizeof (value) == 0); if (young_ptr != young_start) minor_collection (); assert (young_ptr == young_start); new_heap = (char *) stat_alloc (size); if (young_start != NULL){ stat_free ((char *) young_start); } young_start = new_heap; young_end = new_heap + size; young_ptr = young_start; minor_heap_size = size; ref_table_size = minor_heap_size / sizeof (value) / 8; ref_table_reserve = 256; new_table = (value **) stat_alloc ((ref_table_size + ref_table_reserve) * sizeof (value *)); if (ref_table != NULL) stat_free ((char *) ref_table); ref_table = new_table; ref_table_ptr = ref_table; ref_table_threshold = ref_table + ref_table_size; ref_table_limit = ref_table_threshold; ref_table_end = ref_table + ref_table_size + ref_table_reserve; }
static void caml_thread_remove_info(caml_thread_t th) { if (th->next == th) all_threads = NULL; /* last Caml thread exiting */ th->next->prev = th->prev; th->prev->next = th->next; #ifndef NATIVE_CODE stat_free(th->stack_low); #endif if (th->backtrace_buffer != NULL) free(th->backtrace_buffer); stat_free(th); }
CAMLprim value ml_gsl_odeiv_free_system(value vsyst) { gsl_odeiv_system *syst = ODEIV_SYSTEM_VAL(vsyst); struct mlgsl_odeiv_params *p = syst->params; remove_global_root(&(p->closure)); remove_global_root(&(p->jac_closure)); remove_global_root(&(p->arr1)); remove_global_root(&(p->arr2)); remove_global_root(&(p->mat)); stat_free(p); stat_free(syst); return Val_unit; }
CAMLprim value unix_execve(value path, value args, value env) { char ** argv; char ** envp; argv = cstringvect(args); envp = cstringvect(env); (void) execve(String_val(path), argv, envp); stat_free((char *) argv); stat_free((char *) envp); uerror("execve", path); return Val_unit; /* never reached, but suppress warnings */ /* from smart compilers */ }
value caml_mpi_allgather(value sendbuf, value recvbuf, value recvlengths, value comm) { int * recvcounts, * displs; caml_mpi_counts_displs(recvlengths, &recvcounts, &displs); MPI_Allgatherv(String_val(sendbuf), string_length(sendbuf), MPI_BYTE, String_val(recvbuf), recvcounts, displs, MPI_BYTE, Comm_val(comm)); stat_free(recvcounts); stat_free(displs); return Val_unit; }
CAMLprim value unix_execvpe(value path, value args, value env) { char ** argv; char ** saved_environ; argv = cstringvect(args); saved_environ = environ; environ = cstringvect(env); (void) execvp(String_val(path), argv); stat_free((char *) argv); stat_free((char *) environ); environ = saved_environ; uerror("execvp", path); return Val_unit; /* never reached, but suppress warnings */ /* from smart compilers */ }
void realloc_stack() { size_t size; value * new_low, * new_high, * new_sp; value * p; assert(extern_sp >= stack_low); size = stack_high - stack_low; if (size >= Max_stack_size) raise_out_of_memory(); size *= 2; gc_message ("Growing stack to %ld kB.\n", (long) size * sizeof(value) / 1024); new_low = (value *) stat_alloc(size * sizeof(value)); new_high = new_low + size; #define shift(ptr) \ ((char *) new_high - ((char *) stack_high - (char *) (ptr))) new_sp = (value *) shift(extern_sp); memmove((char *)new_sp, (char *)extern_sp, (stack_high - extern_sp) * sizeof(value)); stat_free((char *) stack_low); trapsp = (value *) shift(trapsp); for (p = trapsp; p < new_high; p = Trap_link(p)) Trap_link(p) = (value *) shift(Trap_link(p)); stack_low = new_low; stack_high = new_high; stack_threshold = stack_low + Stack_threshold / sizeof (value); extern_sp = new_sp; #undef shift }
value format_int(value fmt, value arg) /* ML */ { char format_buffer[32]; int prec; char * p; char * dest; value res; prec = 32; for (p = String_val(fmt); *p != 0; p++) { if (*p >= '0' && *p <= '9') { prec = atoi(p) + 5; break; } } if (prec <= sizeof(format_buffer)) { dest = format_buffer; } else { dest = stat_alloc(prec); } sprintf(dest, String_val(fmt), Long_val(arg)); res = copy_string(dest); if (dest != format_buffer) { stat_free(dest); } return res; }
void caml_mpi_commit_floatarray(double * d, value data, mlsize_t len) { if (d != NULL) { bcopy(d, (double *) data, len * sizeof(double)); stat_free(d); } }
static void caml_thread_reinitialize(void) { caml_thread_t thr, next; struct channel * chan; /* Remove all other threads (now nonexistent) from the doubly-linked list of threads */ thr = curr_thread->next; while (thr != curr_thread) { next = thr->next; stat_free(thr); thr = next; } curr_thread->next = curr_thread; curr_thread->prev = curr_thread; all_threads = curr_thread; /* Reinitialize the master lock machinery, just in case the fork happened while other threads were doing leave_blocking_section */ st_masterlock_init(&caml_master_lock); /* Tick thread is not currently running in child process, will be re-created at next Thread.create */ caml_tick_thread_running = 0; /* Destroy all IO mutexes; will be reinitialized on demand */ for (chan = caml_all_opened_channels; chan != NULL; chan = chan->next) { if (chan->mutex != NULL) { st_mutex_destroy(chan->mutex); chan->mutex = NULL; } } }
CAMLprim value netsys_openat(value dirfd, value path, value flags, value perm) { #ifdef HAVE_AT CAMLparam4(dirfd, path, flags, perm); int ret, cv_flags; char * p; /* shamelessly copied from ocaml distro */ cv_flags = convert_flag_list(flags, open_flag_table); p = stat_alloc(string_length(path) + 1); strcpy(p, String_val(path)); enter_blocking_section(); ret = openat(Int_val(dirfd), p, cv_flags, Int_val(perm)); leave_blocking_section(); stat_free(p); if (ret == -1) uerror("openat", path); #if defined(NEED_CLOEXEC_EMULATION) && defined(FD_CLOEXEC) if (convert_flag_list(flags, open_cloexec_table) != 0) { int flags = fcntl(Int_val(dirfd), F_GETFD, 0); if (flags == -1 || fcntl(Int_val(dirfd), F_SETFD, flags | FD_CLOEXEC) == -1) uerror("openat", path); } #endif CAMLreturn (Val_int(ret)); #else invalid_argument("Netsys_posix.openat not available"); #endif }
value caml_mpi_scatter(value sendbuf, value sendlengths, value recvbuf, value root, value comm) { int * sendcounts, * displs; caml_mpi_counts_displs(sendlengths, &sendcounts, &displs); MPI_Scatterv(String_val(sendbuf), sendcounts, displs, MPI_BYTE, String_val(recvbuf), string_length(recvbuf), MPI_BYTE, Int_val(root), Comm_val(comm)); if (sendcounts != NULL) { stat_free(sendcounts); stat_free(displs); } return Val_unit; }
value format_float(value fmt, value arg) /* ML */ { char format_buffer[64]; int prec, i; char * p; char * dest; value res; prec = 64; for (p = String_val(fmt); *p != 0; p++) { if (*p >= '0' && *p <= '9') { i = atoi(p) + 15; if (i > prec) prec = i; break; } } for( ; *p != 0; p++) { if (*p == '.') { i = atoi(p+1) + 15; if (i > prec) prec = i; break; } } if (prec <= sizeof(format_buffer)) { dest = format_buffer; } else { dest = stat_alloc(prec); } sprintf(dest, String_val(fmt), Double_val(arg)); res = copy_string(dest); if (dest != format_buffer) { stat_free(dest); } return res; }
/* * Calling Tcl from Caml * this version works on an arbitrary Tcl command, * and does parsing and substitution */ CAMLprim value camltk_tcl_eval(value str) { int code; char *cmd = NULL; CheckInit(); /* Tcl_Eval may write to its argument, so we take a copy * If the evaluation raises a Caml exception, we have a space * leak */ Tcl_ResetResult(cltclinterp); cmd = caml_string_to_tcl(str); code = Tcl_Eval(cltclinterp, cmd); stat_free(cmd); switch (code) { case TCL_OK: return tcl_string_to_caml(Tcl_GetStringResult(cltclinterp)); case TCL_ERROR: tk_error(Tcl_GetStringResult(cltclinterp)); default: /* TCL_BREAK, TCL_CONTINUE, TCL_RETURN */ tk_error("bad tcl result"); } }
CAMLexport char * caml_search_exe_in_path(char * name) { char * fullname, * filepart; DWORD pathlen, retcode; pathlen = strlen(name) + 1; if (pathlen < 256) pathlen = 256; while (1) { fullname = stat_alloc(pathlen); retcode = SearchPath(NULL, /* use system search path */ name, ".exe", /* add .exe extension if needed */ pathlen, fullname, &filepart); if (retcode == 0) { caml_gc_message(0x100, "%s not found in search path\n", (uintnat) name); strcpy(fullname, name); break; } if (retcode < pathlen) break; stat_free(fullname); pathlen = retcode + 1; } return fullname; }
CAMLprim value ml_gsl_min_fminimizer_free(value s) { remove_global_root(&(Mparams_val(s)->closure)); stat_free(Mparams_val(s)); gsl_min_fminimizer_free(Minimizer_val(s)); return Val_unit; }
CAMLprim value ml_gdk_gc_set_dashes(value gc, value offset, value dashes) { CAMLparam3(gc, offset, dashes); CAMLlocal1(tmp); int l = 0; int i; gint8 *cdashes; for(tmp = dashes; tmp != Val_int(0); tmp = Field(tmp,1)){ l++; } if( l == 0 ){ ml_raise_gdk("line dashes must have at least one element"); } cdashes = stat_alloc(sizeof (gint8) * l); for(i=0, tmp= dashes; i<l; i++, tmp = Field(tmp,1)){ int d; d = Int_val(Field(tmp,0)); if( d<0 || d>255 ){ stat_free (cdashes); ml_raise_gdk("line dashes must be [0..255]"); } cdashes[i] = d; } gdk_gc_set_dashes( GdkGC_val(gc), Int_val(offset), cdashes, l); /* stat_free (cdashes); ? */ CAMLreturn(Val_unit); }
value format_int(value fmt, value arg) { char format_buffer[32]; size_t prec; char * p; char * dest; value res; prec = 32; for (p = String_val(fmt); *p != 0; p++) { if (*p >= '0' && *p <= '9') { prec = strtoul(p, NULL, 10); break; } } if (prec <= sizeof(format_buffer)) { dest = format_buffer; } else { dest = stat_alloc(prec); } sprintf(dest, String_val(fmt), VAL_TO_LONG(arg)); res = copy_string(dest); if (dest != format_buffer) { stat_free(dest); } return res; }
value caml_mpi_gather(value sendbuf, value recvbuf, value recvlengths, value root, value comm) { int * recvcounts, * displs; caml_mpi_counts_displs(recvlengths, &recvcounts, &displs); MPI_Gatherv(String_val(sendbuf), string_length(sendbuf), MPI_BYTE, String_val(recvbuf), recvcounts, displs, MPI_BYTE, Int_val(root), Comm_val(comm)); if (recvcounts != NULL) { stat_free(recvcounts); stat_free(displs); } return Val_unit; }
value caml_mpi_cart_create(value comm, value vdims, value vperiods, value reorder) { int ndims = Wosize_val(vdims); int * dims = stat_alloc(ndims * sizeof(int)); int * periods = stat_alloc(ndims * sizeof(int)); int i; MPI_Comm newcomm; for (i = 0; i < ndims; i++) dims[i] = Int_val(Field(vdims, i)); for (i = 0; i < ndims; i++) periods[i] = Int_val(Field(vperiods, i)); MPI_Cart_create(Comm_val(comm), ndims, dims, periods, Bool_val(reorder), &newcomm); stat_free(dims); stat_free(periods); return caml_mpi_alloc_comm(newcomm); }
value caml_mpi_group_translate_ranks(value group1, value ranks, value group2) { int n = Wosize_val(ranks); int * ranks1 = stat_alloc(n * sizeof(int)); int * ranks2 = stat_alloc(n * sizeof(int)); int i; value res; for (i = 0; i < n; i++) ranks1[i] = Int_val(Field(ranks, i)); MPI_Group_translate_ranks(Group_val(group1), n, ranks1, Group_val(group2), ranks2); res = alloc(n, 0); for (i = 0; i < n; i++) Field(res, i) = Val_int(ranks2[i]); stat_free(ranks1); stat_free(ranks2); return res; }
CAMLprim value ml_gsl_monte_plain_free(value s) { remove_global_root(&(CallbackParams_val(s)->closure)); remove_global_root(&(CallbackParams_val(s)->dbl)); stat_free(CallbackParams_val(s)); gsl_monte_plain_free(GSLPLAINSTATE_VAL(s)); return Val_unit; }