CAMLprim value caml_extunix_openat(value v_dirfd, value path, value flags, value perm)
{
CAMLparam4(v_dirfd, path, flags, perm);
int ret, cv_flags;
char * p;
cv_flags = extunix_open_flags(flags);
p = caml_stat_alloc(caml_string_length(path) + 1);
strcpy(p, String_val(path));
/* open on a named FIFO can block (PR#1533) */
caml_enter_blocking_section();
ret = openat(Int_val(v_dirfd), p, cv_flags, Int_val(perm));
caml_leave_blocking_section();
caml_stat_free(p);
if (ret == -1) uerror("openat", path);
CAMLreturn (Val_int(ret));
}
char * caml_search_exe_in_path(const char * name)
{
struct ext_table path;
char * tofree;
char * res;
caml_ext_table_init(&path, 8);
tofree = caml_decompose_path(&path, getenv("PATH"));
#ifndef __CYGWIN32__
res = caml_search_in_path(&path, name);
#else
res = cygwin_search_exe_in_path(&path, name);
#endif
caml_stat_free(tofree);
caml_ext_table_free(&path, 0);
return res;
}
CAMLprim value caml_extunix_readlinkat(value v_dirfd, value v_name)
{
CAMLparam2(v_dirfd, v_name);
CAMLlocal1(v_link);
char* res;
char* p = caml_stat_alloc(caml_string_length(v_name) + 1);
strcpy(p, String_val(v_name));
caml_enter_blocking_section();
res = readlinkat_malloc(Int_val(v_dirfd), p);
caml_leave_blocking_section();
caml_stat_free(p);
if (res == NULL) uerror("readlinkat", v_name);
v_link = caml_copy_string(res);
free(res);
CAMLreturn(v_link);
}
CAMLprim value unix_execvpe(value path, value args, value env)
{
char_os ** argv;
char_os ** envp;
char_os * wpath;
caml_unix_check_path(path, "execvpe");
argv = cstringvect(args, "execvpe");
envp = cstringvect(env, "execvpe");
wpath = caml_stat_strdup_to_os(String_val(path));
(void) execvpe_os((const char_os *)wpath, EXECV_CAST argv, EXECV_CAST envp);
caml_stat_free(wpath);
cstringvect_free(argv);
cstringvect_free(envp);
uerror("execvpe", path);
return Val_unit; /* never reached, but suppress warnings */
/* from smart compilers */
}
CAMLprim value unix_opendir(value path)
{
CAMLparam1(path);
DIR * d;
value res;
char * p;
p = caml_strdup(String_val(path));
caml_enter_blocking_section();
d = opendir(p);
caml_leave_blocking_section();
caml_stat_free(p);
if (d == (DIR *) NULL) uerror("opendir", path);
res = alloc_small(1, Abstract_tag);
DIR_Val(res) = d;
CAMLreturn(res);
}
void
caml_close_all_channels(void)
{
struct channel * ch, *p;
ch = p = caml_all_opened_channels;
while (ch != NULL) {
p = ch;
ch = ch->prev;
}
ch = p;
while (ch != NULL) {
p = ch->next;
caml_stat_free(ch);
ch = p;
}
}
CAMLprim value connect_stub(value sock, value string_address) {
CAMLparam2 (sock, string_address);
char buffer[BUFF_THRESHOLD];
struct wrap *socket = Socket_val(sock);
int alloced = 0;
char *strcopy = copy_with_stack_buffer(buffer,
sizeof(buffer),
string_address,
&alloced);
caml_release_runtime_system();
int result = zmq_connect(socket->wrapped, strcopy);
caml_acquire_runtime_system();
if (alloced) caml_stat_free(strcopy);
stub_raise_if (result == -1);
CAMLreturn(Val_unit);
}
CAMLprim value caml_dynlink_open_lib(value mode, value filename)
{
void * handle;
value result;
char * p;
caml_gc_log("Opening shared library %s", String_val(filename));
p = caml_strdup(String_val(filename));
caml_enter_blocking_section();
handle = caml_dlopen(p, Int_val(mode), 1);
caml_leave_blocking_section();
caml_stat_free(p);
if (handle == NULL) caml_failwith(caml_dlerror());
result = caml_alloc_small(1, Abstract_tag);
Handle_val(result) = handle;
return result;
}
CAMLprim value caml_sys_system_command(value command)
{
CAMLparam1 (command);
int status, retcode;
char *buf;
buf = caml_strdup(String_val(command));
caml_enter_blocking_section ();
status = system(buf);
caml_leave_blocking_section ();
caml_stat_free(buf);
if (status == -1) caml_sys_error(command);
if (WIFEXITED(status))
retcode = WEXITSTATUS(status);
else
retcode = 255;
CAMLreturn (Val_int(retcode));
}
CAMLprim value unix_lstat_64(value path)
{
CAMLparam1(path);
int ret;
struct stat buf;
char * p;
p = caml_strdup(String_val(path));
caml_enter_blocking_section();
#ifdef HAS_SYMLINK
ret = lstat(p, &buf);
#else
ret = stat(p, &buf);
#endif
caml_leave_blocking_section();
caml_stat_free(p);
if (ret == -1) uerror("lstat", path);
CAMLreturn(stat_aux(1, &buf));
}
CAMLprim value caml_extunix_fstatat(value v_dirfd, value v_name, value v_flags)
{
CAMLparam3(v_dirfd, v_name, v_flags);
int ret;
struct stat buf;
char* p = caml_stat_alloc(caml_string_length(v_name) + 1);
int flags = caml_convert_flag_list(v_flags, at_flags_table);
flags &= (AT_SYMLINK_NOFOLLOW | AT_NO_AUTOMOUNT); /* only allowed flags here */
strcpy(p, String_val(v_name));
caml_enter_blocking_section();
ret = fstatat(Int_val(v_dirfd), p, &buf, flags);
caml_leave_blocking_section();
caml_stat_free(p);
if (ret != 0) uerror("fstatat", v_name);
if (buf.st_size > Max_long && (buf.st_mode & S_IFMT) == S_IFREG)
unix_error(EOVERFLOW, "fstatat", v_name);
CAMLreturn(stat_aux(/*0,*/ &buf));
}
/* Free select data */
void select_data_free (LPSELECTDATA lpSelectData)
{
DWORD i;
DEBUG_PRINT("Freeing data of %x", lpSelectData);
/* Free APC related data, if they exists */
if (lpSelectData->lpWorker != NULL)
{
worker_job_finish(lpSelectData->lpWorker);
lpSelectData->lpWorker = NULL;
};
/* Make sure results/queries cannot be accessed */
lpSelectData->nResultsCount = 0;
lpSelectData->nQueriesCount = 0;
caml_stat_free(lpSelectData);
}
value ep_wait(value v_epfd, value v_maxevents, value v_timeout)
{
CAMLparam3(v_epfd, v_maxevents, v_timeout);
CAMLlocal2(v_res, v_flags);
int maxevents = Int_val(v_maxevents);
struct epoll_event *evs;
int nb;
if (maxevents <= 0) caml_invalid_argument("epoll_wait: maxevents <= 0");
/* evs = caml_stat_alloc(maxevents); */
evs = malloc(maxevents * sizeof (struct epoll_event));
caml_release_runtime_system();
nb = epoll_wait(Int_val(v_epfd), evs, maxevents, Int_val(v_timeout));
caml_acquire_runtime_system();
if (nb == -1) {
caml_stat_free(evs);
int err = errno;
errno = 0;
caml_failwith(strerror(err));
}
v_res = caml_alloc(nb, 0);
/* FIXME? */
while (--nb >= 0) {
value v_ev;
struct epoll_event *ev = &evs[nb];
//v_flags = caml_copy_int32(ev->events); WHY THIS ??
v_ev = caml_alloc_small(2, 0);
Field(v_ev, 0) = Val_int(ev->data.fd);
Field(v_ev, 1) = Val_int(ev->events); // v_flags replaced with ev->events
Store_field(v_res, nb, v_ev);
}
free(evs);
/* caml_stat_free(evs); */
CAMLreturn(v_res);
}
value
ocaml_shm_open(value v_name, value v_rw, value v_creat, value v_excl, value v_trunc)
{
CAMLparam5(v_name, v_rw, v_creat, v_excl, v_trunc);
char *path;
int fd;
int flags = (Bool_val(v_rw)) ? O_RDWR : O_RDONLY;
if (Bool_val(v_creat)) flags |= O_CREAT;
if (Bool_val(v_excl)) flags |= O_EXCL;
if (Bool_val(v_trunc)) flags |= O_TRUNC;
path = caml_stat_alloc(caml_string_length(v_name)+1);
strcpy(path, String_val(v_name));
enter_blocking_section();
fd = shm_open(path, flags, S_IRUSR | S_IWUSR);
leave_blocking_section();
caml_stat_free(path);
if (fd == -1)
uerror("shm_open", v_name);
CAMLreturn(Val_int(fd));
}
CAMLprim value unix_lstat(value path)
{
CAMLparam1(path);
int ret;
struct stat buf;
char * p;
p = caml_strdup(String_val(path));
caml_enter_blocking_section();
#ifdef HAS_SYMLINK
ret = lstat(p, &buf);
#else
ret = stat(p, &buf);
#endif
caml_leave_blocking_section();
caml_stat_free(p);
if (ret == -1) uerror("lstat", path);
if (buf.st_size > Max_long && (buf.st_mode & S_IFMT) == S_IFREG)
unix_error(EOVERFLOW, "lstat", path);
CAMLreturn(stat_aux(0, &buf));
}
char * caml_search_in_path(struct ext_table * path, char * name)
{
char * p, * dir, * fullname;
int i;
struct stat st;
for (p = name; *p != 0; p++) {
if (*p == '/') goto not_found;
}
for (i = 0; i < path->size; i++) {
dir = path->contents[i];
if (dir[0] == 0) dir = "."; /* empty path component = current dir */
fullname = caml_strconcat(3, dir, "/", name);
if (stat(fullname, &st) == 0 && S_ISREG(st.st_mode))
return fullname;
caml_stat_free(fullname);
}
not_found:
return caml_strdup(name);
}
CAMLexport value caml_promote(struct domain* domain, value root)
{
struct promotion_stack stk = {0};
if (Is_long(root))
/* Integers are already shared */
return root;
if (Tag_val(root) == Stack_tag)
/* Stacks are handled specially */
return promote_stack(domain, root);
if (!Is_minor(root))
/* This value is already shared */
return root;
Assert(caml_owner_of_young_block(root) == domain);
value ret = caml_promote_one(&stk, domain, root);
while (stk.sp > 0) {
struct promotion_stack_entry* curr = &stk.stack[stk.sp - 1];
value local = curr->local;
value global = curr->global;
int field = curr->field;
Assert(field < Wosize_val(local));
curr->field++;
if (curr->field == Wosize_val(local))
stk.sp--;
value x = Op_val(local)[field];
if (Is_block(x) && Tag_val(x) == Stack_tag) {
/* stacks are not promoted unless explicitly requested */
Ref_table_add(&domain->state->remembered_set->ref, global, field);
} else {
x = caml_promote_one(&stk, domain, x);
}
Op_val(local)[field] = Op_val(global)[field] = x;
}
caml_stat_free(stk.stack);
return ret;
}
CAMLprim value caml_sys_open(value path, value vflags, value vperm)
{
CAMLparam3(path, vflags, vperm);
int fd, flags, perm;
char * p;
p = caml_stat_alloc(caml_string_length(path) + 1);
strcpy(p, String_val(path));
flags = caml_convert_flag_list(vflags, sys_open_flags);
perm = Int_val(vperm);
/* open on a named FIFO can block (PR#1533) */
caml_enter_blocking_section();
fd = open(p, flags, perm);
caml_leave_blocking_section();
caml_stat_free(p);
if (fd == -1) caml_sys_error(path);
#if defined(F_SETFD) && defined(FD_CLOEXEC)
fcntl(fd, F_SETFD, FD_CLOEXEC);
#endif
CAMLreturn(Val_long(fd));
}
CAMLprim value caml_format_float(value fmt, value arg)
{
#define MAX_DIGITS 350
/* Max number of decimal digits in a "natural" (not artificially padded)
representation of a float. Can be quite big for %f format.
Max exponent for IEEE format is 308 decimal digits.
Rounded up for good measure. */
char format_buffer[MAX_DIGITS + 20];
int prec, i;
char * p;
char * dest;
value res;
prec = MAX_DIGITS;
for (p = String_val(fmt); *p != 0; p++) {
if (*p >= '0' && *p <= '9') {
i = atoi(p) + MAX_DIGITS;
if (i > prec) prec = i;
break;
}
}
for( ; *p != 0; p++) {
if (*p == '.') {
i = atoi(p+1) + MAX_DIGITS;
if (i > prec) prec = i;
break;
}
}
if (prec < sizeof(format_buffer)) {
dest = format_buffer;
} else {
dest = caml_stat_alloc(prec);
}
sprintf(dest, String_val(fmt), Double_val(arg));
res = caml_copy_string(dest);
if (dest != format_buffer) {
caml_stat_free(dest);
}
return res;
}
CAMLprim value caml_format_int(value fmt, value arg)
{
char format_string[FORMAT_BUFFER_SIZE];
char default_format_buffer[FORMAT_BUFFER_SIZE];
char * buffer;
char conv;
value res;
buffer = parse_format(fmt, ARCH_INTNAT_PRINTF_FORMAT,
format_string, default_format_buffer, &conv);
switch (conv) {
case 'u': case 'x': case 'X': case 'o':
sprintf(buffer, format_string, Unsigned_long_val(arg));
break;
default:
sprintf(buffer, format_string, Long_val(arg));
break;
}
res = caml_copy_string(buffer);
if (buffer != default_format_buffer) caml_stat_free(buffer);
return res;
}
static void caml_ba_finalize(value v)
{
struct caml_ba_array * b = Caml_ba_array_val(v);
switch (b->flags & CAML_BA_MANAGED_MASK) {
case CAML_BA_EXTERNAL:
break;
case CAML_BA_MANAGED:
if (b->proxy == NULL) {
__free(b->data);
} else {
if (-- b->proxy->refcount == 0) {
__free(b->proxy->data);
caml_stat_free(b->proxy);
}
}
break;
case CAML_BA_MAPPED_FILE:
caml_failwith("CAML_BA_MAPPED_FILE: unsupported");
break;
}
}
CAMLprim value caml_sys_file_exists(value name)
{
#ifdef _WIN32
struct _stati64 st;
#else
struct stat st;
#endif
char * p;
int ret;
p = caml_strdup(String_val(name));
caml_enter_blocking_section();
#ifdef _WIN32
ret = _stati64(p, &st);
#else
ret = stat(p, &st);
#endif
caml_leave_blocking_section();
caml_stat_free(p);
return Val_bool(ret == 0);
}
char * caml_search_in_path(struct ext_table * path, char * name)
{
char * p, * fullname;
int i;
struct stat st;
for (p = name; *p != 0; p++) {
if (*p == '/') goto not_found;
}
for (i = 0; i < path->size; i++) {
fullname = caml_stat_alloc(strlen((char *)(path->contents[i])) +
strlen(name) + 2);
strcpy(fullname, (char *)(path->contents[i]));
if (fullname[0] != 0) strcat(fullname, "/");
strcat(fullname, name);
if (stat(fullname, &st) == 0 && S_ISREG(st.st_mode)) return fullname;
caml_stat_free(fullname);
}
not_found:
fullname = caml_stat_alloc(strlen(name) + 1);
strcpy(fullname, name);
return fullname;
}
CAMLprim value caml_sys_read_directory(value path)
{
CAMLparam1(path);
CAMLlocal1(result);
struct ext_table tbl;
char * p;
int ret;
caml_ext_table_init(&tbl, 50);
p = caml_strdup(String_val(path));
caml_enter_blocking_section();
ret = caml_read_directory(p, &tbl);
caml_leave_blocking_section();
caml_stat_free(p);
if (ret == -1){
caml_ext_table_free(&tbl, 1);
caml_sys_error(path);
}
caml_ext_table_add(&tbl, NULL);
result = caml_copy_string_array((char const **) tbl.contents);
caml_ext_table_free(&tbl, 1);
CAMLreturn(result);
}
char * caml_search_in_path(struct ext_table * path, char * name)
{
char * p, * dir, * fullname;
int i;
struct stat st;
for (p = name; *p != 0; p++) {
if (*p == '/' || *p == '\\') goto not_found;
}
for (i = 0; i < path->size; i++) {
dir = path->contents[i];
if (dir[0] == 0) continue;
/* not sure what empty path components mean under Windows */
fullname = caml_strconcat(3, dir, "\\", name);
caml_gc_message(0x100, "Searching %s\n", (uintnat) fullname);
if (stat(fullname, &st) == 0 && S_ISREG(st.st_mode))
return fullname;
caml_stat_free(fullname);
}
not_found:
caml_gc_message(0x100, "%s not found in search path\n", (uintnat) name);
return caml_strdup(name);
}
void caml_realloc_stack(asize_t required_space)
{
asize_t size;
value * new_low, * new_high, * new_sp;
value * p;
Assert(caml_extern_sp >= caml_stack_low);
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);
caml_gc_message (0x08, "Growing stack to %"
ARCH_INTNAT_PRINTF_FORMAT "uk bytes\n",
(uintnat) size * sizeof(value) / 1024);
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
}
CAMLprim value pcre_exec_stub0(
intnat v_opt, value v_rex, intnat v_pos, intnat v_subj_start, value v_subj,
value v_ovec, value v_maybe_cof, value v_workspace)
{
int ret;
int is_dfa = v_workspace != (value) NULL;
long
pos = v_pos,
len = caml_string_length(v_subj),
subj_start = v_subj_start;
long ovec_len = Wosize_val(v_ovec);
if (pos > len || pos < subj_start)
caml_invalid_argument("Pcre.pcre_exec_stub: illegal position");
if (subj_start > len || subj_start < 0)
caml_invalid_argument("Pcre.pcre_exec_stub: illegal subject start");
pos -= subj_start;
len -= subj_start;
{
const pcre *code = get_rex(v_rex); /* Compiled pattern */
const pcre_extra *extra = get_extra(v_rex); /* Extra info */
const char *ocaml_subj =
String_val(v_subj) + subj_start; /* Subject string */
const int opt = v_opt; /* Runtime options */
/* Special case when no callout functions specified */
if (v_maybe_cof == None) {
int *ovec = (int *) &Field(v_ovec, 0);
/* Performs the match */
if (is_dfa)
ret =
pcre_dfa_exec(code, extra, ocaml_subj, len, pos, opt, ovec, ovec_len,
(int *) &Field(v_workspace, 0), Wosize_val(v_workspace));
else
ret = pcre_exec(code, extra, ocaml_subj, len, pos, opt, ovec, ovec_len);
if (ret < 0) handle_exec_error("pcre_exec_stub", ret);
else handle_pcre_exec_result(ovec, v_ovec, ovec_len, subj_start, ret);
}
/* There are callout functions */
else {
value v_cof = Field(v_maybe_cof, 0);
value v_substrings;
char *subj = caml_stat_alloc(sizeof(char) * len);
int *ovec = caml_stat_alloc(sizeof(int) * ovec_len);
int workspace_len;
int *workspace;
struct cod cod = { 0, (value *) NULL, (value *) NULL, (value) NULL };
struct pcre_extra new_extra =
#ifdef PCRE_EXTRA_MATCH_LIMIT_RECURSION
# ifdef PCRE_EXTRA_MARK
# ifdef PCRE_EXTRA_EXECUTABLE_JIT
{ PCRE_EXTRA_CALLOUT_DATA, NULL, 0, NULL, NULL, 0, NULL, NULL };
# else
{ PCRE_EXTRA_CALLOUT_DATA, NULL, 0, NULL, NULL, 0, NULL };
# endif
# else
{ PCRE_EXTRA_CALLOUT_DATA, NULL, 0, NULL, NULL, 0 };
# endif
#else
{ PCRE_EXTRA_CALLOUT_DATA, NULL, 0, NULL, NULL };
#endif
cod.subj_start = subj_start;
memcpy(subj, ocaml_subj, len);
Begin_roots4(v_rex, v_cof, v_substrings, v_ovec);
Begin_roots1(v_subj);
v_substrings = caml_alloc_small(2, 0);
End_roots();
Field(v_substrings, 0) = v_subj;
Field(v_substrings, 1) = v_ovec;
cod.v_substrings_p = &v_substrings;
cod.v_cof_p = &v_cof;
new_extra.callout_data = &cod;
if (extra != NULL) {
new_extra.flags = PCRE_EXTRA_CALLOUT_DATA | extra->flags;
new_extra.study_data = extra->study_data;
new_extra.match_limit = extra->match_limit;
new_extra.tables = extra->tables;
#ifdef PCRE_EXTRA_MATCH_LIMIT_RECURSION
new_extra.match_limit_recursion = extra->match_limit_recursion;
#endif
}
if (is_dfa) {
workspace_len = Wosize_val(v_workspace);
workspace = caml_stat_alloc(sizeof(int) * workspace_len);
ret =
pcre_dfa_exec(code, extra, subj, len, pos, opt, ovec, ovec_len,
(int *) &Field(v_workspace, 0), workspace_len);
} else
ret =
pcre_exec(code, &new_extra, subj, len, pos, opt, ovec, ovec_len);
caml_stat_free(subj);
End_roots();
if (ret < 0) {
if (is_dfa) caml_stat_free(workspace);
caml_stat_free(ovec);
if (ret == PCRE_ERROR_CALLOUT) caml_raise(cod.v_exn);
else handle_exec_error("pcre_exec_stub(callout)", ret);
} else {
handle_pcre_exec_result(ovec, v_ovec, ovec_len, subj_start, ret);
if (is_dfa) {
caml_int_ptr ocaml_workspace_dst =
(caml_int_ptr) &Field(v_workspace, 0);
const int *workspace_src = workspace;
const int *workspace_src_stop = workspace + workspace_len;
while (workspace_src != workspace_src_stop) {
*ocaml_workspace_dst = *workspace_src;
ocaml_workspace_dst++;
workspace_src++;
}
caml_stat_free(workspace);
}
caml_stat_free(ovec);
}
}
}
return Val_unit;
}
CAMLprim value pcre_exec_stub(
intnat v_opt, value v_rex, intnat v_pos, intnat v_subj_start, value v_subj,
value v_ovec, value v_maybe_cof)
{
return pcre_exec_stub0(v_opt, v_rex, v_pos, v_subj_start, v_subj,
v_ovec, v_maybe_cof, (value) NULL);
}
/* Byte-code hook for pcre_exec_stub
Needed, because there are more than 5 arguments */
CAMLprim value pcre_exec_stub_bc(value *argv, int __unused argn)
{
return
pcre_exec_stub0(
Int_val(argv[0]), argv[1], Int_val(argv[2]), Int_val(argv[3]),
argv[4], argv[5], argv[6], (value) NULL);
}
/* Byte-code hook for pcre_dfa_exec_stub
Needed, because there are more than 5 arguments */
CAMLprim value pcre_dfa_exec_stub_bc(value *argv, int __unused argn)
{
return
pcre_exec_stub0(
Int_val(argv[0]), argv[1], Int_val(argv[2]), Int_val(argv[3]),
argv[4], argv[5], argv[6], argv[7]);
}
static struct custom_operations tables_ops = {
"pcre_ocaml_tables",
pcre_dealloc_tables,
custom_compare_default,
custom_hash_default,
custom_serialize_default,
custom_deserialize_default,
custom_compare_ext_default
};
/* Generates a new set of chartables for the current locale (see man
page of PCRE */
CAMLprim value pcre_maketables_stub(value __unused v_unit)
{
/* GC will do a full cycle every 1_000_000 table set allocations (one
table set consumes 864 bytes -> maximum of 864_000_000 bytes unreclaimed
table sets) */
const value v_tables =
caml_alloc_custom(
&tables_ops, sizeof(struct pcre_ocaml_tables), 1, 1000000);
set_tables(v_tables, pcre_maketables());
return v_tables;
}
/* Wraps around the isspace-function */
CAMLprim value pcre_isspace_stub(value v_c)
{
return Val_bool(isspace(Int_val(v_c)));
}
/* Returns number of substring associated with a name */
CAMLprim intnat pcre_get_stringnumber_stub(value v_rex, value v_name)
{
const int ret = pcre_get_stringnumber(get_rex(v_rex), String_val(v_name));
if (ret == PCRE_ERROR_NOSUBSTRING)
caml_invalid_argument("Named string not found");
return ret;
}
CAMLprim value pcre_get_stringnumber_stub_bc(value v_rex, value v_name)
{
return Val_int(pcre_get_stringnumber_stub(v_rex, v_name));
}
/* Returns array of names of named substrings in a regexp */
CAMLprim value pcre_names_stub(value v_rex)
{
CAMLparam0();
CAMLlocal1(v_res);
int name_count;
int entry_size;
const char *tbl_ptr;
int i;
int ret = pcre_fullinfo_stub(v_rex, PCRE_INFO_NAMECOUNT, &name_count);
if (ret != 0) raise_internal_error("pcre_names_stub: namecount");
ret = pcre_fullinfo_stub(v_rex, PCRE_INFO_NAMEENTRYSIZE, &entry_size);
if (ret != 0) raise_internal_error("pcre_names_stub: nameentrysize");
ret = pcre_fullinfo_stub(v_rex, PCRE_INFO_NAMETABLE, &tbl_ptr);
if (ret != 0) raise_internal_error("pcre_names_stub: nametable");
v_res = caml_alloc(name_count, 0);
for (i = 0; i < name_count; ++i) {
value v_name = caml_copy_string(tbl_ptr + 2);
Store_field(v_res, i, v_name);
tbl_ptr += entry_size;
}
CAMLreturn(v_res);
}
/* Generic stub for getting integer results from pcre_config */
static inline int pcre_config_int(int what)
{
int ret;
pcre_config(what, (void *) &ret);
return ret;
}
/* Generic stub for getting long integer results from pcre_config */
static inline int pcre_config_long(int what)
{
long ret;
pcre_config(what, (void *) &ret);
return ret;
}
/* The bytecode interpreter for the NFA */
static int re_match(value re,
unsigned char * starttxt,
register unsigned char * txt,
register unsigned char * endtxt,
int accept_partial_match)
{
register value * pc;
intnat instr;
struct backtrack_stack * stack;
union backtrack_point * sp;
value cpool;
value normtable;
unsigned char c;
union backtrack_point back;
{ int i;
struct re_group * p;
unsigned char ** q;
for (p = &re_group[1], i = Numgroups(re); i > 1; i--, p++)
p->start = p->end = NULL;
for (q = &re_register[0], i = Numregisters(re); i > 0; i--, q++)
*q = NULL;
}
pc = &Field(Prog(re), 0);
stack = &initial_stack;
sp = stack->point;
cpool = Cpool(re);
normtable = Normtable(re);
re_group[0].start = txt;
while (1) {
instr = Long_val(*pc++);
switch (Opcode(instr)) {
case CHAR:
if (txt == endtxt) goto prefix_match;
if (*txt != Arg(instr)) goto backtrack;
txt++;
break;
case CHARNORM:
if (txt == endtxt) goto prefix_match;
if (Byte_u(normtable, *txt) != Arg(instr)) goto backtrack;
txt++;
break;
case STRING: {
unsigned char * s =
(unsigned char *) String_val(Field(cpool, Arg(instr)));
while ((c = *s++) != 0) {
if (txt == endtxt) goto prefix_match;
if (c != *txt) goto backtrack;
txt++;
}
break;
}
case STRINGNORM: {
unsigned char * s =
(unsigned char *) String_val(Field(cpool, Arg(instr)));
while ((c = *s++) != 0) {
if (txt == endtxt) goto prefix_match;
if (c != Byte_u(normtable, *txt)) goto backtrack;
txt++;
}
break;
}
case CHARCLASS:
if (txt == endtxt) goto prefix_match;
if (! In_bitset(String_val(Field(cpool, Arg(instr))), *txt, c))
goto backtrack;
txt++;
break;
case BOL:
if (txt > starttxt && txt[-1] != '\n') goto backtrack;
break;
case EOL:
if (txt < endtxt && *txt != '\n') goto backtrack;
break;
case WORDBOUNDARY:
/* At beginning and end of text: no
At beginning of text: OK if current char is a letter
At end of text: OK if previous char is a letter
Otherwise:
OK if previous char is a letter and current char not a letter
or previous char is not a letter and current char is a letter */
if (txt == starttxt) {
if (txt == endtxt) goto prefix_match;
if (Is_word_letter(txt[0])) break;
goto backtrack;
} else if (txt == endtxt) {
if (Is_word_letter(txt[-1])) break;
goto backtrack;
} else {
if (Is_word_letter(txt[-1]) != Is_word_letter(txt[0])) break;
goto backtrack;
}
case BEGGROUP: {
int group_no = Arg(instr);
struct re_group * group = &(re_group[group_no]);
back.undo.loc = &(group->start);
back.undo.val = group->start;
group->start = txt;
goto push;
}
case ENDGROUP: {
int group_no = Arg(instr);
struct re_group * group = &(re_group[group_no]);
back.undo.loc = &(group->end);
back.undo.val = group->end;
group->end = txt;
goto push;
}
case REFGROUP: {
int group_no = Arg(instr);
struct re_group * group = &(re_group[group_no]);
unsigned char * s;
if (group->start == NULL || group->end == NULL) goto backtrack;
for (s = group->start; s < group->end; s++) {
if (txt == endtxt) goto prefix_match;
if (*s != *txt) goto backtrack;
txt++;
}
break;
}
case ACCEPT:
goto accept;
case SIMPLEOPT: {
char * set = String_val(Field(cpool, Arg(instr)));
if (txt < endtxt && In_bitset(set, *txt, c)) txt++;
break;
}
case SIMPLESTAR: {
char * set = String_val(Field(cpool, Arg(instr)));
while (txt < endtxt && In_bitset(set, *txt, c))
txt++;
break;
}
case SIMPLEPLUS: {
char * set = String_val(Field(cpool, Arg(instr)));
if (txt == endtxt) goto prefix_match;
if (! In_bitset(set, *txt, c)) goto backtrack;
txt++;
while (txt < endtxt && In_bitset(set, *txt, c))
txt++;
break;
}
case GOTO:
pc = pc + SignedArg(instr);
break;
case PUSHBACK:
back.pos.pc = Set_tag(pc + SignedArg(instr));
back.pos.txt = txt;
goto push;
case SETMARK: {
int reg_no = Arg(instr);
unsigned char ** reg = &(re_register[reg_no]);
back.undo.loc = reg;
back.undo.val = *reg;
*reg = txt;
goto push;
}
case CHECKPROGRESS: {
int reg_no = Arg(instr);
if (re_register[reg_no] == txt)
goto backtrack;
break;
}
default:
caml_fatal_error ("impossible case in re_match");
}
/* Continue with next instruction */
continue;
push:
/* Push an item on the backtrack stack and continue with next instr */
if (sp == stack->point + BACKTRACK_STACK_BLOCK_SIZE) {
struct backtrack_stack * newstack =
caml_stat_alloc(sizeof(struct backtrack_stack));
newstack->previous = stack;
stack = newstack;
sp = stack->point;
}
*sp = back;
sp++;
continue;
prefix_match:
/* We get here when matching failed because the end of text
was encountered. */
if (accept_partial_match) goto accept;
backtrack:
/* We get here when matching fails. Backtrack to most recent saved
program point, undoing variable assignments on the way. */
while (1) {
if (sp == stack->point) {
struct backtrack_stack * prevstack = stack->previous;
if (prevstack == NULL) return 0;
caml_stat_free(stack);
stack = prevstack;
sp = stack->point + BACKTRACK_STACK_BLOCK_SIZE;
}
sp--;
if (Tag_is_set(sp->pos.pc)) {
pc = Clear_tag(sp->pos.pc);
txt = sp->pos.txt;
break;
} else {
*(sp->undo.loc) = sp->undo.val;
}
}
continue;
}
accept:
/* We get here when the regexp was successfully matched */
free_backtrack_stack(stack);
re_group[0].end = txt;
return 1;
}
CAMLexport void caml_main(char **argv)
{
int fd, pos;
struct exec_trailer trail;
struct channel * chan;
value res;
char * shared_lib_path, * shared_libs, * req_prims;
char * exe_name;
#ifdef __linux__
static char proc_self_exe[256];
#endif
/* Machine-dependent initialization of the floating-point hardware
so that it behaves as much as possible as specified in IEEE */
caml_init_ieee_floats();
#ifdef _MSC_VER
caml_install_invalid_parameter_handler();
#endif
caml_init_custom_operations();
caml_ext_table_init(&caml_shared_libs_path, 8);
caml_external_raise = NULL;
/* Determine options and position of bytecode file */
#ifdef DEBUG
caml_verb_gc = 0xBF;
#endif
parse_camlrunparam();
pos = 0;
exe_name = argv[0];
#ifdef __linux__
if (caml_executable_name(proc_self_exe, sizeof(proc_self_exe)) == 0)
exe_name = proc_self_exe;
#endif
fd = caml_attempt_open(&exe_name, &trail, 0);
if (fd < 0) {
pos = parse_command_line(argv);
if (argv[pos] == 0)
caml_fatal_error("No bytecode file specified.\n");
exe_name = argv[pos];
fd = caml_attempt_open(&exe_name, &trail, 1);
switch(fd) {
case FILE_NOT_FOUND:
caml_fatal_error_arg("Fatal error: cannot find file '%s'\n", argv[pos]);
break;
case BAD_BYTECODE:
caml_fatal_error_arg(
"Fatal error: the file '%s' is not a bytecode executable file\n",
exe_name);
break;
}
}
/* Read the table of contents (section descriptors) */
caml_read_section_descriptors(fd, &trail);
/* Initialize the abstract machine */
caml_init_gc (minor_heap_init, heap_size_init, heap_chunk_init,
percent_free_init, max_percent_free_init);
caml_init_stack (max_stack_init);
init_atoms();
/* Initialize the interpreter */
caml_interprete(NULL, 0);
/* Initialize the debugger, if needed */
caml_debugger_init();
/* Load the code */
caml_code_size = caml_seek_section(fd, &trail, "CODE");
caml_load_code(fd, caml_code_size);
/* Build the table of primitives */
shared_lib_path = read_section(fd, &trail, "DLPT");
shared_libs = read_section(fd, &trail, "DLLS");
req_prims = read_section(fd, &trail, "PRIM");
if (req_prims == NULL) caml_fatal_error("Fatal error: no PRIM section\n");
caml_build_primitive_table(shared_lib_path, shared_libs, req_prims);
caml_stat_free(shared_lib_path);
caml_stat_free(shared_libs);
caml_stat_free(req_prims);
/* Load the globals */
caml_seek_section(fd, &trail, "DATA");
chan = caml_open_descriptor_in(fd);
caml_global_data = caml_input_val(chan);
caml_close_channel(chan); /* this also closes fd */
caml_stat_free(trail.section);
/* Ensure that the globals are in the major heap. */
caml_oldify_one (caml_global_data, &caml_global_data);
caml_oldify_mopup ();
/* Initialize system libraries */
caml_init_exceptions();
caml_sys_init(exe_name, argv + pos);
#ifdef _WIN32
/* Start a thread to handle signals */
if (getenv("CAMLSIGPIPE"))
_beginthread(caml_signal_thread, 4096, NULL);
#endif
/* Execute the program */
caml_debugger(PROGRAM_START);
res = caml_interprete(caml_start_code, caml_code_size);
if (Is_exception_result(res)) {
caml_exn_bucket = Extract_exception(res);
if (caml_debugger_in_use) {
caml_extern_sp = &caml_exn_bucket; /* The debugger needs the
exception value.*/
caml_debugger(UNCAUGHT_EXC);
}
caml_fatal_uncaught_exception(caml_exn_bucket);
}
}
CAMLprim value caml_context_split_r(CAML_R, value thread_no_as_value, value function)
{
#if defined(HAS_MULTICONTEXT) //&& defined(NATIVE_CODE)
//DUMPROOTS("splitting: before GC-protecting locals");
CAMLparam1(function);
//CAMLlocal2(result, open_channels);
CAMLlocal5(result, open_channels, res, tail, chan);
//DUMPROOTS("splitting: after GC-protecting locals");
int can_split = caml_can_split_r(ctx);
if (! can_split)
caml_raise_cannot_split_r(ctx);
int thread_no = Int_val(thread_no_as_value);
caml_global_context **new_contexts = caml_stat_alloc(sizeof(caml_global_context*) * thread_no);
char *blob;
sem_t semaphore;
int i;
caml_initialize_semaphore(&semaphore, 0);
/* CAMLparam0(); CAMLlocal1(open_channels); */
/* Make sure that the currently-existing channels stay alive until
after deserialization; we can't keep reference counts within the
blob, so we pin all alive channels by keeping this list alive: */
/* //if(0){//!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! */
/* struct channel *channel; */
/* struct channel **channels; */
/* int channel_no = 0; */
/* caml_acquire_global_lock(); */
/* for (channel = caml_all_opened_channels; */
/* channel != NULL; */
/* channel = channel->next) */
/* channel_no ++; */
/* channels = caml_stat_alloc(sizeof(struct channel*) * channel_no); */
/* for (i = 0, channel = caml_all_opened_channels; */
/* channel != NULL; */
/* i ++, channel = channel->next){ */
/* channels[i] = channel; */
/* DUMP("split-pinning channel %p, with fd %i, refcount %i->%i", channel, (int)channel->fd, channel->refcount, channel->refcount + 1); */
/* channel->refcount ++; */
/* } */
/* caml_release_global_lock(); */
//open_channels = caml_ml_all_channels_list_r(ctx); // !!!!!!!!!!!!!!!!!!!! This can occasionally cause crashes related to channel picounts. I certainly messed up something in io.c. //!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
//}//!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
/* //EXPERIMENTAL: BEGIN */
/* { */
/* struct channel * channel; */
/* res = Val_emptylist; */
/* caml_acquire_global_lock(); */
/* int ii, channel_index; */
/* for(ii = 0; ii < 100; ii ++){ // !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! */
/* for (channel_index = 0, channel = caml_all_opened_channels; */
/* channel != NULL; */
/* channel = channel->next, channel_index ++) */
/* /\* Testing channel->fd >= 0 looks unnecessary, as */
/* caml_ml_close_channel changes max when setting fd to -1. *\/ */
/* { */
/* DUMP("round %i, channel_index %i", ii, channel_index); */
/* // !!!!!!!!!!!!! BEGIN */
/* /\* chan = *\/ caml_alloc_channel_r (ctx, channel); */
/* // !!!!!!!!!!!!! END */
/* chan = Val_unit;//caml_alloc_channel_r (ctx, channel); // !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! */
/* tail = res; */
/* res = caml_alloc_small_r (ctx, 2, 0); */
/* Field (res, 0) = chan; */
/* Field (res, 1) = tail; */
/* } */
/* DUMP("End of round %i: there are %i channels alive", ii, channel_index); */
/* DUMP("Before GC'ing"); */
/* caml_gc_compaction_r(ctx, Val_unit); //!!!!!@@@@@@@@@@@@@ */
/* DUMP("After GC'ing"); */
/* } */
/* caml_release_global_lock(); */
/* //open_channels = Val_unit/\* res *\/; */
/* open_channels = res; */
/* } */
/* //EXPERIMENTAL: END */
/* Serialize the context in the main thread, then create threads,
and in each one of them deserialize it back in parallel: */
blob = caml_serialize_context(ctx, function);
//if(0){//!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
caml_split_and_wait_r(ctx, blob, new_contexts, thread_no, &semaphore);
//}//!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
/* Now we're done with the blob: */
DUMP("destroying the blob");
caml_stat_free(blob); // !!!!!!!!!!!!!!!!!!!!!!!!!!! This is needed !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
DUMP("GC'ing after destroying the blob");
caml_gc_compaction_r(ctx, Val_unit); //!!!!!@@@@@@@@@@@@@
DUMP("finalizing the semaphore");
caml_finalize_semaphore(&semaphore);
/* Copy the contexts we got, and we're done with new_contexts as well: */
DUMP("copying the new context (descriptors) into the Caml data structure result");
result = caml_alloc_r(ctx, thread_no, 0);
caml_gc_compaction_r(ctx, Val_unit); //!!!!!@@@@@@@@@@@@
for(i = 0; i < thread_no; i ++)
caml_initialize_r(ctx, &Field(result, i), caml_value_of_context_descriptor(new_contexts[i]->descriptor));
caml_stat_free(new_contexts);
DUMP("destroyed the malloced buffer of pointers new_contexts");
//DUMPROOTS("from parent, after splitting");
/* caml_acquire_global_lock(); */
/* for (i = 0; i < channel_no; i ++){ */
/* DUMP("split-unpinning channels[i] %p, with fd %i, refcount %i->%i", channels[i], (int)channels[i]->fd, channels[i]->refcount, channels[i]->refcount - 1); */
/* channels[i]->refcount --; */
/* } */
/* caml_release_global_lock(); */
CAMLreturn(result);
//CAMLreturn(Val_unit);
#else
caml_raise_unimplemented_r(ctx);
return Val_unit; // unreachable
#endif // #if defined(HAS_MULTICONTEXT) //&& defined(NATIVE_CODE)
}
