/* ML type : pgresult_ -> int -> int */
value pq_fsize(value pgresval, value fieldno)
{
checkfbound(PGresult_val(pgresval), Long_val(fieldno), "pq_ftype");
return Val_long(PQfsize(PGresult_val(pgresval), Long_val(fieldno)));
}
static void extern_rec(value v)
{
struct code_fragment * cf;
struct extern_item * sp;
sp = extern_stack;
while(1) {
if (Is_long(v)) {
intnat n = Long_val(v);
if (n >= 0 && n < 0x40) {
Write(PREFIX_SMALL_INT + n);
} else if (n >= -(1 << 7) && n < (1 << 7)) {
writecode8(CODE_INT8, n);
} else if (n >= -(1 << 15) && n < (1 << 15)) {
writecode16(CODE_INT16, n);
#ifdef ARCH_SIXTYFOUR
} else if (n < -((intnat)1 << 31) || n >= ((intnat)1 << 31)) {
writecode64(CODE_INT64, n);
#endif
} else
writecode32(CODE_INT32, n);
goto next_item;
}
if (Is_in_value_area(v)) {
header_t hd = Hd_val(v);
tag_t tag = Tag_hd(hd);
mlsize_t sz = Wosize_hd(hd);
if (tag == Forward_tag) {
value f = Forward_val (v);
if (Is_block (f)
&& (!Is_in_value_area(f) || Tag_val (f) == Forward_tag
|| Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag)){
/* Do not short-circuit the pointer. */
}else{
v = f;
continue;
}
}
/* Atoms are treated specially for two reasons: they are not allocated
in the externed block, and they are automatically shared. */
if (sz == 0) {
if (tag < 16) {
Write(PREFIX_SMALL_BLOCK + tag);
} else {
writecode32(CODE_BLOCK32, hd);
}
goto next_item;
}
/* Check if already seen */
if (Color_hd(hd) == Caml_blue) {
uintnat d = obj_counter - (uintnat) Field(v, 0);
if (d < 0x100) {
writecode8(CODE_SHARED8, d);
} else if (d < 0x10000) {
writecode16(CODE_SHARED16, d);
} else {
writecode32(CODE_SHARED32, d);
}
goto next_item;
}
/* Output the contents of the object */
switch(tag) {
case String_tag: {
mlsize_t len = caml_string_length(v);
if (len < 0x20) {
Write(PREFIX_SMALL_STRING + len);
} else if (len < 0x100) {
writecode8(CODE_STRING8, len);
} else {
writecode32(CODE_STRING32, len);
}
writeblock(String_val(v), len);
size_32 += 1 + (len + 4) / 4;
size_64 += 1 + (len + 8) / 8;
extern_record_location(v);
break;
}
case Double_tag: {
if (sizeof(double) != 8)
extern_invalid_argument("output_value: non-standard floats");
Write(CODE_DOUBLE_NATIVE);
writeblock_float8((double *) v, 1);
size_32 += 1 + 2;
size_64 += 1 + 1;
extern_record_location(v);
break;
}
case Double_array_tag: {
mlsize_t nfloats;
if (sizeof(double) != 8)
extern_invalid_argument("output_value: non-standard floats");
nfloats = Wosize_val(v) / Double_wosize;
if (nfloats < 0x100) {
writecode8(CODE_DOUBLE_ARRAY8_NATIVE, nfloats);
} else {
writecode32(CODE_DOUBLE_ARRAY32_NATIVE, nfloats);
}
writeblock_float8((double *) v, nfloats);
size_32 += 1 + nfloats * 2;
size_64 += 1 + nfloats;
extern_record_location(v);
break;
}
case Abstract_tag:
extern_invalid_argument("output_value: abstract value (Abstract)");
break;
case Infix_tag:
writecode32(CODE_INFIXPOINTER, Infix_offset_hd(hd));
extern_rec(v - Infix_offset_hd(hd));
break;
case Custom_tag: {
uintnat sz_32, sz_64;
char * ident = Custom_ops_val(v)->identifier;
void (*serialize)(value v, uintnat * wsize_32,
uintnat * wsize_64)
= Custom_ops_val(v)->serialize;
if (serialize == NULL)
extern_invalid_argument("output_value: abstract value (Custom)");
Write(CODE_CUSTOM);
writeblock(ident, strlen(ident) + 1);
Custom_ops_val(v)->serialize(v, &sz_32, &sz_64);
size_32 += 2 + ((sz_32 + 3) >> 2); /* header + ops + data */
size_64 += 2 + ((sz_64 + 7) >> 3);
extern_record_location(v);
break;
}
default: {
value field0;
if (tag < 16 && sz < 8) {
Write(PREFIX_SMALL_BLOCK + tag + (sz << 4));
#ifdef ARCH_SIXTYFOUR
} else if (hd >= ((uintnat)1 << 32)) {
writecode64(CODE_BLOCK64, Whitehd_hd (hd));
#endif
} else {
writecode32(CODE_BLOCK32, Whitehd_hd (hd));
}
size_32 += 1 + sz;
size_64 += 1 + sz;
field0 = Field(v, 0);
extern_record_location(v);
/* Remember that we still have to serialize fields 1 ... sz - 1 */
if (sz > 1) {
sp++;
if (sp >= extern_stack_limit) sp = extern_resize_stack(sp);
sp->v = &Field(v,1);
sp->count = sz-1;
}
/* Continue serialization with the first field */
v = field0;
continue;
}
}
}
else if ((cf = extern_find_code((char *) v)) != NULL) {
if (!extern_closures)
extern_invalid_argument("output_value: functional value");
writecode32(CODE_CODEPOINTER, (char *) v - cf->code_start);
writeblock((char *) cf->digest, 16);
} else {
extern_invalid_argument("output_value: abstract value (outside heap)");
}
next_item:
/* Pop one more item to marshal, if any */
if (sp == extern_stack) {
/* We are done. Cleanup the stack and leave the function */
extern_free_stack();
return;
}
v = *((sp->v)++);
if (--(sp->count) == 0) sp--;
}
CAMLprim value ml_gpointer_set_char (value region, value pos, value ch)
{
*(ml_gpointer_base (region) + Long_val(pos)) = Int_val(ch);
return Val_unit;
}
CAMLprim value unix_alarm(value t)
{
return Val_int(alarm((unsigned int) Long_val(t)));
}
value lwt_unix_send_notification_stub(value id) {
lwt_unix_send_notification(Long_val(id));
return Val_unit;
}
value fdset_isset(value fd, fd_set *fds) {
/* fprintf(stderr,"fdset_isset: fd = %d.\n",Long_val(fd)); */
return (FD_ISSET(Long_val(fd),fds) == 0 ? Val_false : Val_true);
}
CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout,
value vshared, value vdim, value vstart)
{
HANDLE fd, fmap;
int flags, major_dim, mode, perm;
intnat num_dims, i;
intnat dim[CAML_BA_MAX_NUM_DIMS];
__int64 currpos, startpos, file_size, data_size;
uintnat array_size, page, delta;
char c;
void * addr;
LARGE_INTEGER li;
SYSTEM_INFO sysinfo;
fd = Handle_val(vfd);
flags = Int_val(vkind) | Int_val(vlayout);
startpos = Int64_val(vstart);
num_dims = Wosize_val(vdim);
major_dim = flags & CAML_BA_FORTRAN_LAYOUT ? num_dims - 1 : 0;
/* Extract dimensions from OCaml array */
num_dims = Wosize_val(vdim);
if (num_dims < 1 || num_dims > CAML_BA_MAX_NUM_DIMS)
caml_invalid_argument("Bigarray.mmap: bad number of dimensions");
for (i = 0; i < num_dims; i++) {
dim[i] = Long_val(Field(vdim, i));
if (dim[i] == -1 && i == major_dim) continue;
if (dim[i] < 0)
caml_invalid_argument("Bigarray.create: negative dimension");
}
/* Determine file size */
currpos = caml_ba_set_file_pointer(fd, 0, FILE_CURRENT);
if (currpos == -1) caml_ba_sys_error();
file_size = caml_ba_set_file_pointer(fd, 0, FILE_END);
if (file_size == -1) caml_ba_sys_error();
/* Determine array size in bytes (or size of array without the major
dimension if that dimension wasn't specified) */
array_size = caml_ba_element_size[flags & CAML_BA_KIND_MASK];
for (i = 0; i < num_dims; i++)
if (dim[i] != -1) array_size *= dim[i];
/* Check if the first/last dimension is unknown */
if (dim[major_dim] == -1) {
/* Determine first/last dimension from file size */
if (file_size < startpos)
caml_failwith("Bigarray.mmap: file position exceeds file size");
data_size = file_size - startpos;
dim[major_dim] = (uintnat) (data_size / array_size);
array_size = dim[major_dim] * array_size;
if (array_size != data_size)
caml_failwith("Bigarray.mmap: file size doesn't match array dimensions");
}
/* Restore original file position */
caml_ba_set_file_pointer(fd, currpos, FILE_BEGIN);
/* Create the file mapping */
if (Bool_val(vshared)) {
perm = PAGE_READWRITE;
mode = FILE_MAP_WRITE;
} else {
perm = PAGE_READONLY; /* doesn't work under Win98 */
mode = FILE_MAP_COPY;
}
li.QuadPart = startpos + array_size;
fmap = CreateFileMapping(fd, NULL, perm, li.HighPart, li.LowPart, NULL);
if (fmap == NULL) caml_ba_sys_error();
/* Determine offset so that the mapping starts at the given file pos */
GetSystemInfo(&sysinfo);
delta = (uintnat) (startpos % sysinfo.dwAllocationGranularity);
/* Map the mapping in memory */
li.QuadPart = startpos - delta;
addr =
MapViewOfFile(fmap, mode, li.HighPart, li.LowPart, array_size + delta);
if (addr == NULL) caml_ba_sys_error();
addr = (void *) ((uintnat) addr + delta);
/* Close the file mapping */
CloseHandle(fmap);
/* Build and return the OCaml bigarray */
return caml_ba_alloc(flags | CAML_BA_MAPPED_FILE, num_dims, addr, dim);
}
CAMLprim inline __pure value get_buf_ptr_stub(value v_buf, value v_pos)
{
char *sptr = Caml_ba_data_val(v_buf);
char *eptr = sptr + Long_val(v_pos);
return (value) eptr;
}
CAMLprim value shift_sptr_stub(char *sptr, value v_n)
{
return (value) (sptr + Long_val(v_n));
}
CAMLprim value caml_ba_fill(value vb, value vinit)
{
struct caml_ba_array * b = Caml_ba_array_val(vb);
intnat num_elts = caml_ba_num_elts(b);
switch (b->flags & CAML_BA_KIND_MASK) {
default:
Assert(0);
#ifdef _KERNEL
#else
case CAML_BA_FLOAT32: {
float init = Double_val(vinit);
float * p;
for (p = b->data; num_elts > 0; p++, num_elts--) *p = init;
break;
}
case CAML_BA_FLOAT64: {
double init = Double_val(vinit);
double * p;
for (p = b->data; num_elts > 0; p++, num_elts--) *p = init;
break;
}
#endif
case CAML_BA_SINT8:
case CAML_BA_UINT8: {
int init = Int_val(vinit);
char * p;
for (p = b->data; num_elts > 0; p++, num_elts--) *p = init;
break;
}
case CAML_BA_SINT16:
case CAML_BA_UINT16: {
int init = Int_val(vinit);
int16 * p;
for (p = b->data; num_elts > 0; p++, num_elts--) *p = init;
break;
}
case CAML_BA_INT32: {
int32 init = Int32_val(vinit);
int32 * p;
for (p = b->data; num_elts > 0; p++, num_elts--) *p = init;
break;
}
case CAML_BA_INT64: {
int64 init = Int64_val(vinit);
int64 * p;
for (p = b->data; num_elts > 0; p++, num_elts--) *p = init;
break;
}
case CAML_BA_NATIVE_INT: {
intnat init = Nativeint_val(vinit);
intnat * p;
for (p = b->data; num_elts > 0; p++, num_elts--) *p = init;
break;
}
case CAML_BA_CAML_INT: {
intnat init = Long_val(vinit);
intnat * p;
for (p = b->data; num_elts > 0; p++, num_elts--) *p = init;
break;
}
#ifdef _KERNEL
#else
case CAML_BA_COMPLEX32: {
float init0 = Double_field(vinit, 0);
float init1 = Double_field(vinit, 1);
float * p;
for (p = b->data; num_elts > 0; num_elts--) { *p++ = init0; *p++ = init1; }
break;
}
case CAML_BA_COMPLEX64: {
double init0 = Double_field(vinit, 0);
double init1 = Double_field(vinit, 1);
double * p;
for (p = b->data; num_elts > 0; num_elts--) { *p++ = init0; *p++ = init1; }
break;
}
#endif
}
return Val_unit;
}
CAMLprim value caml_float_of_int(value n)
{
return caml_copy_double((double) Long_val(n));
}
CAMLprim value caml_parse_engine(struct parser_tables *tables,
struct parser_env *env, value cmd, value arg)
{
int state;
mlsize_t sp, asp;
int errflag;
int n, n1, n2, m, state1;
switch(Int_val(cmd)) {
case START:
state = 0;
sp = Int_val(env->sp);
errflag = 0;
loop:
n = Short(tables->defred, state);
if (n != 0) goto reduce;
if (Int_val(env->curr_char) >= 0) goto testshift;
SAVE;
return READ_TOKEN;
/* The ML code calls the lexer and updates */
/* symb_start and symb_end */
case TOKEN_READ:
RESTORE;
if (Is_block(arg)) {
env->curr_char = Field(tables->transl_block, Tag_val(arg));
caml_modify_field((value)env,
offsetof(struct parser_env, lval) / sizeof(value),
Field(arg, 0));
} else {
env->curr_char = Field(tables->transl_const, Int_val(arg));
caml_modify_field((value)env,
offsetof(struct parser_env, lval) / sizeof(value),
Val_long(0));
}
if (caml_startup_params.parser_trace) print_token(tables, state, arg);
testshift:
n1 = Short(tables->sindex, state);
n2 = n1 + Int_val(env->curr_char);
if (n1 != 0 && n2 >= 0 && n2 <= Int_val(tables->tablesize) &&
Short(tables->check, n2) == Int_val(env->curr_char)) goto shift;
n1 = Short(tables->rindex, state);
n2 = n1 + Int_val(env->curr_char);
if (n1 != 0 && n2 >= 0 && n2 <= Int_val(tables->tablesize) &&
Short(tables->check, n2) == Int_val(env->curr_char)) {
n = Short(tables->table, n2);
goto reduce;
}
if (errflag > 0) goto recover;
SAVE;
return CALL_ERROR_FUNCTION;
/* The ML code calls the error function */
case ERROR_DETECTED:
RESTORE;
recover:
if (errflag < 3) {
errflag = 3;
while (1) {
state1 = Int_val(Field(env->s_stack, sp));
n1 = Short(tables->sindex, state1);
n2 = n1 + ERRCODE;
if (n1 != 0 && n2 >= 0 && n2 <= Int_val(tables->tablesize) &&
Short(tables->check, n2) == ERRCODE) {
if (caml_startup_params.parser_trace)
fprintf(stderr, "Recovering in state %d\n", state1);
goto shift_recover;
} else {
if (caml_startup_params.parser_trace){
fprintf(stderr, "Discarding state %d\n", state1);
}
if (sp <= Int_val(env->stackbase)) {
if (caml_startup_params.parser_trace){
fprintf(stderr, "No more states to discard\n");
}
return RAISE_PARSE_ERROR; /* The ML code raises Parse_error */
}
sp--;
}
}
} else {
if (Int_val(env->curr_char) == 0)
return RAISE_PARSE_ERROR; /* The ML code raises Parse_error */
if (caml_startup_params.parser_trace) fprintf(stderr, "Discarding last token read\n");
env->curr_char = Val_int(-1);
goto loop;
}
shift:
env->curr_char = Val_int(-1);
if (errflag > 0) errflag--;
shift_recover:
if (caml_startup_params.parser_trace)
fprintf(stderr, "State %d: shift to state %d\n",
state, Short(tables->table, n2));
state = Short(tables->table, n2);
sp++;
if (sp < Long_val(env->stacksize)) goto push;
SAVE;
return GROW_STACKS_1;
/* The ML code resizes the stacks */
case STACKS_GROWN_1:
RESTORE;
push:
Store_field (env->s_stack, sp, Val_int(state));
Store_field (env->v_stack, sp, env->lval);
Store_field (env->symb_start_stack, sp, env->symb_start);
Store_field (env->symb_end_stack, sp, env->symb_end);
goto loop;
reduce:
if (caml_startup_params.parser_trace)
fprintf(stderr, "State %d: reduce by rule %d\n", state, n);
m = Short(tables->len, n);
env->asp = Val_int(sp);
env->rule_number = Val_int(n);
env->rule_len = Val_int(m);
sp = sp - m + 1;
m = Short(tables->lhs, n);
state1 = Int_val(Field(env->s_stack, sp - 1));
n1 = Short(tables->gindex, m);
n2 = n1 + state1;
if (n1 != 0 && n2 >= 0 && n2 <= Int_val(tables->tablesize) &&
Short(tables->check, n2) == state1) {
state = Short(tables->table, n2);
} else {
state = Short(tables->dgoto, m);
}
if (sp < Long_val(env->stacksize)) goto semantic_action;
SAVE;
return GROW_STACKS_2;
/* The ML code resizes the stacks */
case STACKS_GROWN_2:
RESTORE;
semantic_action:
SAVE;
return COMPUTE_SEMANTIC_ACTION;
/* The ML code calls the semantic action */
case SEMANTIC_ACTION_COMPUTED:
RESTORE;
Store_field(env->s_stack, sp, Val_int(state));
caml_modify_field(env->v_stack, sp, arg);
asp = Int_val(env->asp);
Store_field (env->symb_end_stack, sp, Field(env->symb_end_stack, asp));
if (sp > asp) {
/* This is an epsilon production. Take symb_start equal to symb_end. */
Store_field (env->symb_start_stack, sp, Field(env->symb_end_stack, asp));
}
goto loop;
default: /* Should not happen */
Assert(0);
return RAISE_PARSE_ERROR; /* Keeps gcc -Wall happy */
}
static intnat compare_val(value v1, value v2, int total)
{
struct compare_item * sp;
tag_t t1, t2;
if (!compare_stack) compare_init_stack();
sp = compare_stack;
while (1) {
if (v1 == v2 && total) goto next_item;
if (Is_long(v1)) {
if (v1 == v2) goto next_item;
if (Is_long(v2))
return Long_val(v1) - Long_val(v2);
/* Subtraction above cannot overflow and cannot result in UNORDERED */
switch (Tag_val(v2)) {
case Forward_tag:
v2 = Forward_val(v2);
continue;
case Custom_tag: {
int res;
int (*compare)(value v1, value v2) = Custom_ops_val(v2)->compare_ext;
if (compare == NULL) break; /* for backward compatibility */
caml_compare_unordered = 0;
res = compare(v1, v2);
if (caml_compare_unordered && !total) return UNORDERED;
if (res != 0) return res;
goto next_item;
}
default: /*fallthrough*/;
}
return LESS; /* v1 long < v2 block */
}
if (Is_long(v2)) {
switch (Tag_val(v1)) {
case Forward_tag:
v1 = Forward_val(v1);
continue;
case Custom_tag: {
int res;
int (*compare)(value v1, value v2) = Custom_ops_val(v1)->compare_ext;
if (compare == NULL) break; /* for backward compatibility */
caml_compare_unordered = 0;
res = compare(v1, v2);
if (caml_compare_unordered && !total) return UNORDERED;
if (res != 0) return res;
goto next_item;
}
default: /*fallthrough*/;
}
return GREATER; /* v1 block > v2 long */
}
t1 = Tag_val(v1);
t2 = Tag_val(v2);
if (t1 == Forward_tag) { v1 = Forward_val (v1); continue; }
if (t2 == Forward_tag) { v2 = Forward_val (v2); continue; }
if (t1 != t2) return (intnat)t1 - (intnat)t2;
switch(t1) {
case String_tag: {
mlsize_t len1, len2;
int res;
if (v1 == v2) break;
len1 = caml_string_length(v1);
len2 = caml_string_length(v2);
res = memcmp(String_val(v1), String_val(v2), len1 <= len2 ? len1 : len2);
if (res < 0) return LESS;
if (res > 0) return GREATER;
if (len1 != len2) return len1 - len2;
break;
}
case Double_tag: {
double d1 = Double_val(v1);
double d2 = Double_val(v2);
if (d1 < d2) return LESS;
if (d1 > d2) return GREATER;
if (d1 != d2) {
if (! total) return UNORDERED;
/* One or both of d1 and d2 is NaN. Order according to the
convention NaN = NaN and NaN < f for all other floats f. */
if (d1 == d1) return GREATER; /* d1 is not NaN, d2 is NaN */
if (d2 == d2) return LESS; /* d2 is not NaN, d1 is NaN */
/* d1 and d2 are both NaN, thus equal: continue comparison */
}
break;
}
case Double_array_tag: {
mlsize_t sz1 = Wosize_val(v1) / Double_wosize;
mlsize_t sz2 = Wosize_val(v2) / Double_wosize;
mlsize_t i;
if (sz1 != sz2) return sz1 - sz2;
for (i = 0; i < sz1; i++) {
double d1 = Double_field(v1, i);
double d2 = Double_field(v2, i);
if (d1 < d2) return LESS;
if (d1 > d2) return GREATER;
if (d1 != d2) {
if (! total) return UNORDERED;
/* See comment for Double_tag case */
if (d1 == d1) return GREATER;
if (d2 == d2) return LESS;
}
}
break;
}
case Abstract_tag:
compare_free_stack();
caml_invalid_argument("equal: abstract value");
case Closure_tag:
case Infix_tag:
compare_free_stack();
caml_invalid_argument("equal: functional value");
case Object_tag: {
intnat oid1 = Oid_val(v1);
intnat oid2 = Oid_val(v2);
if (oid1 != oid2) return oid1 - oid2;
break;
}
case Custom_tag: {
int res;
int (*compare)(value v1, value v2) = Custom_ops_val(v1)->compare;
/* Hardening against comparisons between different types */
if (compare != Custom_ops_val(v2)->compare) {
return strcmp(Custom_ops_val(v1)->identifier,
Custom_ops_val(v2)->identifier) < 0
? LESS : GREATER;
}
if (compare == NULL) {
compare_free_stack();
caml_invalid_argument("equal: abstract value");
}
caml_compare_unordered = 0;
res = compare(v1, v2);
if (caml_compare_unordered && !total) return UNORDERED;
if (res != 0) return res;
break;
}
default: {
mlsize_t sz1 = Wosize_val(v1);
mlsize_t sz2 = Wosize_val(v2);
/* Compare sizes first for speed */
if (sz1 != sz2) return sz1 - sz2;
if (sz1 == 0) break;
/* Remember that we still have to compare fields 1 ... sz - 1 */
if (sz1 > 1) {
sp++;
if (sp >= compare_stack_limit) sp = compare_resize_stack(sp);
sp->v1 = Op_val(v1) + 1;
sp->v2 = Op_val(v2) + 1;
sp->count = sz1 - 1;
}
/* Continue comparison with first field */
v1 = Field(v1, 0);
v2 = Field(v2, 0);
continue;
}
}
next_item:
/* Pop one more item to compare, if any */
if (sp == compare_stack) return EQUAL; /* we're done */
v1 = *((sp->v1)++);
v2 = *((sp->v2)++);
if (--(sp->count) == 0) sp--;
}
}
/* ML type : pgresult_ -> int -> int -> bool */
value pq_getisnull(value pgresval, value tupno, value fieldno)
{
checkbounds(pgresval, tupno, fieldno, "pq_getisnull");
return Val_bool(PQgetisnull(PGresult_val(pgresval), Long_val(tupno),
Long_val(fieldno)));
}
static void hash_aux(value obj)
{
unsigned char * p;
mlsize_t i, j;
tag_t tag;
hash_univ_limit--;
if (hash_univ_count < 0 || hash_univ_limit < 0) return;
again:
if (Is_long(obj)) {
hash_univ_count--;
Combine(Long_val(obj));
return;
}
/* Pointers into the heap are well-structured blocks. So are atoms.
We can inspect the block contents. */
Assert (Is_block (obj));
if (Is_atom(obj) || Is_young(obj) || Is_in_heap(obj)) {
tag = Tag_val(obj);
switch (tag) {
case String_tag:
hash_univ_count--;
i = caml_string_length(obj);
for (p = &Byte_u(obj, 0); i > 0; i--, p++)
Combine_small(*p);
break;
case Double_tag:
/* For doubles, we inspect their binary representation, LSB first.
The results are consistent among all platforms with IEEE floats. */
hash_univ_count--;
#ifdef ARCH_BIG_ENDIAN
for (p = &Byte_u(obj, sizeof(double) - 1), i = sizeof(double);
i > 0;
p--, i--)
#else
for (p = &Byte_u(obj, 0), i = sizeof(double);
i > 0;
p++, i--)
#endif
Combine_small(*p);
break;
case Double_array_tag:
hash_univ_count--;
for (j = 0; j < Bosize_val(obj); j += sizeof(double)) {
#ifdef ARCH_BIG_ENDIAN
for (p = &Byte_u(obj, j + sizeof(double) - 1), i = sizeof(double);
i > 0;
p--, i--)
#else
for (p = &Byte_u(obj, j), i = sizeof(double);
i > 0;
p++, i--)
#endif
Combine_small(*p);
}
break;
case Abstract_tag:
/* We don't know anything about the contents of the block.
Better do nothing. */
break;
case Infix_tag:
hash_aux(obj - Infix_offset_val(obj));
break;
case Forward_tag:
obj = Forward_val (obj);
goto again;
case Object_tag:
hash_univ_count--;
Combine(Oid_val(obj));
break;
case Custom_tag:
/* If no hashing function provided, do nothing */
if (Custom_ops_val(obj)->hash != NULL) {
hash_univ_count--;
Combine(Custom_ops_val(obj)->hash(obj));
}
break;
default:
hash_univ_count--;
Combine_small(tag);
i = Wosize_val(obj);
while (i != 0) {
i--;
hash_aux(Field(obj, i));
}
break;
}
return;
}
/* Otherwise, obj is a pointer outside the heap, to an object with
a priori unknown structure. Use its physical address as hash key. */
Combine((intnat) obj);
}
CAMLprim value get_eptr_from_sptr_ptr(char **sptr_ptr, value v_pos)
{
return (value) (*sptr_ptr + Long_val(v_pos));
}
value fdset_clr(value fd,fd_set *fds) {
FD_CLR(Long_val(fd),fds);
/* fprintf(stderr,"fdset_clr: fd = %d.\n",Long_val(fd)); */
return Val_unit;
}
CAMLprim value set_sptr_ptr_stub(char **sptr_ptr, value v_buf, value v_pos)
{
*sptr_ptr = (char *) Caml_ba_data_val(v_buf) + Long_val(v_pos);
return Val_unit;
}
value coq_set_bytecode_field(value v, value i, value code) {
// No write barrier because the bytecode does not live on the OCaml heap
Field(v, Long_val(i)) = (value) Code_val(code);
return Val_unit;
}
static inline __pure char * get_buf(value v_buf, value v_pos)
{
return (char *) Caml_ba_data_val(v_buf) + Long_val(v_pos);
}
CAMLprim value unix_ftruncate(value fd, value len)
{
if (ftruncate(Int_val(fd), Long_val(len)) == -1)
uerror("ftruncate", Nothing);
return Val_unit;
}
/* ML type : dbresult_ -> int -> int */
EXTERNML value db_ftype(value dbresval, value fieldno)
{
/* Fetch field information */
// NB. fetch_field direct doesn't work. (mysql is broken)
// NB!: The numbers below need to correspond to the
// numbers in Mysql.sml
MYSQL_FIELD *fields;
checkfbound(DBresult_val(dbresval), Long_val(fieldno), "db_ftype");
fields=mysql_fetch_fields(DBresult_val(dbresval));
switch(fields[Long_val(fieldno)].type) {
case FIELD_TYPE_DECIMAL:
return Val_long(0);
case FIELD_TYPE_TINY:
return Val_long(1);
case FIELD_TYPE_SHORT:
return Val_long(2);
case FIELD_TYPE_LONG:
return Val_long(3);
case FIELD_TYPE_FLOAT:
return Val_long(4);
case FIELD_TYPE_DOUBLE:
return Val_long(5);
case FIELD_TYPE_NULL:
return Val_long(6);
case FIELD_TYPE_TIMESTAMP:
return Val_long(7);
case FIELD_TYPE_LONGLONG:
return Val_long(8);
case FIELD_TYPE_INT24:
return Val_long(9);
case FIELD_TYPE_DATE:
return Val_long(10);
case FIELD_TYPE_TIME:
return Val_long(11);
case FIELD_TYPE_DATETIME:
return Val_long(12);
case FIELD_TYPE_YEAR:
return Val_long(13);
case FIELD_TYPE_NEWDATE:
return Val_long(14);
case FIELD_TYPE_ENUM:
return Val_long(15);
case FIELD_TYPE_SET:
return Val_long(16);
case FIELD_TYPE_TINY_BLOB:
return Val_long(17);
case FIELD_TYPE_MEDIUM_BLOB:
return Val_long(18);
case FIELD_TYPE_LONG_BLOB:
return Val_long(19);
case FIELD_TYPE_BLOB:
return Val_long(20);
case FIELD_TYPE_VAR_STRING:
return Val_long(21);
case FIELD_TYPE_STRING:
return Val_long(22);
// broken by design: FIELD_TYPE_CHAR=FIELD_TYPE_TINY,
// really shouldn't be, as it's to different concepts
// case FIELD_TYPE_CHAR:
// return copy_string(17);
}
//default type
return Val_long(-1);
}
CAMLprim value lwt_unix_fill_bytes(value val_buf, value val_ofs, value val_len,
value val_char) {
memset((char *)Caml_ba_data_val(val_buf) + Long_val(val_ofs),
Int_val(val_char), Long_val(val_len));
return Val_unit;
}
value immediate_exit (value v) {
_exit (Long_val(v));
return Val_unit;
}
void hh_shared_init(
value global_size_val,
value heap_size_val
) {
CAMLparam2(global_size_val, heap_size_val);
global_size_b = Long_val(global_size_val);
heap_size = Long_val(heap_size_val);
/* MAP_NORESERVE is because we want a lot more virtual memory than what
* we are actually going to use.
*/
int flags = MAP_SHARED | MAP_ANON | MAP_NORESERVE | MAP_FIXED;
int prot = PROT_READ | PROT_WRITE;
int page_size = getpagesize();
/* The total size of the shared memory. Most of it is going to remain
* virtual. */
size_t shared_mem_size = global_size_b + 2 * DEP_SIZE_B + HASHTBL_SIZE_B +
heap_size;
char* shared_mem =
(char*)mmap((void*)SHARED_MEM_INIT, page_size + shared_mem_size, prot,
flags, 0, 0);
if(shared_mem == MAP_FAILED) {
printf("Error initializing: %s\n", strerror(errno));
exit(2);
}
#ifdef MADV_DONTDUMP
// We are unlikely to get much useful information out of the shared heap in
// a core file. Moreover, it can be HUGE, and the extensive work done dumping
// it once for each CPU can mean that the user will reboot their machine
// before the much more useful stack gets dumped!
madvise(shared_mem, page_size + shared_mem_size, MADV_DONTDUMP);
#endif
// Keeping the pids around to make asserts.
master_pid = getpid();
my_pid = master_pid;
char* bottom = shared_mem;
init_shared_globals(shared_mem);
// Checking that we did the maths correctly.
assert(*heap + heap_size == bottom + shared_mem_size + page_size);
// Uninstall ocaml's segfault handler. It's supposed to throw an exception on
// stack overflow, but we don't actually handle that exception, so what
// happens in practice is we terminate at toplevel with an unhandled exception
// and a useless ocaml backtrace. A core dump is actually more useful. Sigh.
struct sigaction sigact;
sigact.sa_handler = SIG_DFL;
sigemptyset(&sigact.sa_mask);
sigact.sa_flags = 0;
sigaction(SIGSEGV, &sigact, NULL);
set_priorities();
CAMLreturn0;
}
value hh_shared_init(
value global_size_val,
value heap_size_val
) {
CAMLparam2(global_size_val, heap_size_val);
global_size_b = Long_val(global_size_val);
heap_size = Long_val(heap_size_val);
char* shared_mem;
size_t page_size = getpagesize();
/* The total size of the shared memory. Most of it is going to remain
* virtual. */
size_t shared_mem_size =
global_size_b + 2 * DEP_SIZE_B + HASHTBL_SIZE_B +
heap_size + page_size;
#ifdef _WIN32
/*
We create an anonymous memory file, whose `handle` might be
inherited by slave processes.
This memory file is tagged "reserved" but not "committed". This
means that the memory space will be reserved in the virtual
memory table but the pages will not be bound to any physical
memory yet. Further calls to 'VirtualAlloc' will "commit" pages,
meaning they will be bound to physical memory.
This is behavior that should reflect the 'MAP_NORESERVE' flag of
'mmap' on Unix. But, on Unix, the "commit" is implicit.
Committing the whole shared heap at once would require the same
amount of free space in memory (or in swap file).
*/
HANDLE handle = CreateFileMapping(
INVALID_HANDLE_VALUE,
NULL,
PAGE_READWRITE | SEC_RESERVE,
shared_mem_size >> 32, shared_mem_size & ((1ll << 32) - 1),
NULL);
if (handle == NULL) {
win32_maperr(GetLastError());
uerror("CreateFileMapping", Nothing);
}
if (!SetHandleInformation(handle, HANDLE_FLAG_INHERIT, HANDLE_FLAG_INHERIT)) {
win32_maperr(GetLastError());
uerror("SetHandleInformation", Nothing);
}
shared_mem = MapViewOfFileEx(
handle,
FILE_MAP_ALL_ACCESS,
0, 0,
0,
(char *)SHARED_MEM_INIT);
if (shared_mem != (char *)SHARED_MEM_INIT) {
shared_mem = NULL;
win32_maperr(GetLastError());
uerror("MapViewOfFileEx", Nothing);
}
#else /* _WIN32 */
/* MAP_NORESERVE is because we want a lot more virtual memory than what
* we are actually going to use.
*/
int flags = MAP_SHARED | MAP_ANON | MAP_NORESERVE | MAP_FIXED;
int prot = PROT_READ | PROT_WRITE;
shared_mem =
(char*)mmap((void*)SHARED_MEM_INIT, shared_mem_size, prot,
flags, 0, 0);
if(shared_mem == MAP_FAILED) {
printf("Error initializing: %s\n", strerror(errno));
exit(2);
}
#ifdef MADV_DONTDUMP
// We are unlikely to get much useful information out of the shared heap in
// a core file. Moreover, it can be HUGE, and the extensive work done dumping
// it once for each CPU can mean that the user will reboot their machine
// before the much more useful stack gets dumped!
madvise(shared_mem, shared_mem_size, MADV_DONTDUMP);
#endif
// Keeping the pids around to make asserts.
master_pid = getpid();
my_pid = master_pid;
#endif /* _WIN32 */
char* bottom = shared_mem;
init_shared_globals(shared_mem);
// Checking that we did the maths correctly.
assert(*heap + heap_size == bottom + shared_mem_size);
#ifndef _WIN32
// Uninstall ocaml's segfault handler. It's supposed to throw an exception on
// stack overflow, but we don't actually handle that exception, so what
// happens in practice is we terminate at toplevel with an unhandled exception
// and a useless ocaml backtrace. A core dump is actually more useful. Sigh.
struct sigaction sigact;
sigact.sa_handler = SIG_DFL;
sigemptyset(&sigact.sa_mask);
sigact.sa_flags = 0;
sigaction(SIGSEGV, &sigact, NULL);
#endif
CAMLreturn(Val_unit);
}
CAMLprim value ml_gpointer_get_char (value region, value pos)
{
return Val_int(*(ml_gpointer_base (region) + Long_val(pos)));
}
CAMLprim value caml_ensure_stack_capacity(value required_space)
{
asize_t req = Long_val(required_space);
if (caml_extern_sp - req < caml_stack_low) caml_realloc_stack(req);
return Val_unit;
}
CAMLextern_C value
caml_sfRenderWindow_setFramerateLimit(value win, value limit)
{
SfRenderWindow_val(win)->setFramerateLimit(Long_val(limit));
return Val_unit;
}
/* ML type : pgresult_ -> int -> string */
value pq_fname(value pgresval, value fieldno)
{
checkfbound(PGresult_val(pgresval), Long_val(fieldno), "pq_ftype");
return copy_string(PQfname(PGresult_val(pgresval), Long_val(fieldno)));
}
