static void check_block (char *hp)
{
mlsize_t i;
value v = Val_hp (hp);
value f;
check_head (v);
switch (Tag_hp (hp)) {
case Abstract_tag:
break;
case String_tag:
break;
case Double_tag:
Assert (Wosize_val (v) == Double_wosize);
break;
case Double_array_tag:
Assert (Wosize_val (v) % Double_wosize == 0);
break;
case Custom_tag:
Assert (!Is_in_heap (Custom_ops_val (v)));
break;
case Infix_tag:
Assert (0);
break;
default:
Assert (Tag_hp (hp) < No_scan_tag);
for (i = 0; i < Wosize_hp (hp); i++) {
f = Field (v, i);
if (Is_block (f) && Is_in_heap (f)) check_head (f);
}
}
}
CAMLprim value caml_weak_blit (value ars, value ofs,
value ard, value ofd, value len)
{
mlsize_t offset_s = Long_val (ofs) + 1;
mlsize_t offset_d = Long_val (ofd) + 1;
mlsize_t length = Long_val (len);
long i;
Assert (Is_in_heap (ars));
Assert (Is_in_heap (ard));
if (offset_s < 1 || offset_s + length > Wosize_val (ars)){
caml_invalid_argument ("Weak.blit");
}
if (offset_d < 1 || offset_d + length > Wosize_val (ard)){
caml_invalid_argument ("Weak.blit");
}
if (caml_gc_phase == Phase_mark && caml_gc_subphase == Subphase_weak1){
for (i = 0; i < length; i++){
value v = Field (ars, offset_s + i);
if (v != caml_weak_none && Is_block (v) && Is_in_heap (v)
&& Is_white_val (v)){
Field (ars, offset_s + i) = caml_weak_none;
}
}
}
if (offset_d < offset_s){
for (i = 0; i < length; i++){
do_set (ard, offset_d + i, Field (ars, offset_s + i));
}
}else{
for (i = length - 1; i >= 0; i--){
do_set (ard, offset_d + i, Field (ars, offset_s + i));
}
}
return Val_unit;
}
static void scan_native_globals(scanning_action f)
{
int i, j;
static link* dyn_globals;
value glob;
link* lnk;
caml_plat_lock(&roots_mutex);
dyn_globals = caml_dyn_globals;
caml_plat_unlock(&roots_mutex);
/* The global roots */
for (i = 0; caml_globals[i] != 0; i++) {
glob = caml_globals[i];
for (j = 0; j < Wosize_val(glob); j++)
f (Op_val(glob)[j], &Op_val(glob)[j]);
}
/* Dynamic (natdynlink) global roots */
iter_list(dyn_globals, lnk) {
glob = (value) lnk->data;
for (j = 0; j < Wosize_val(glob); j++){
f (Op_val(glob)[j], &Op_val(glob)[j]);
}
}
CAMLexport mlsize_t caml_array_length(value array)
{
if (Tag_val(array) == Double_array_tag)
return Wosize_val(array) / Double_wosize;
else
return Wosize_val(array);
}
static void search_pointer(char **pointers, char *name, unsigned bound, char *p, char *v, unsigned index)
{
unsigned i, j, k;
char *p2;
i = 0;
j = bound;
while(j - i > 1) {
k = (i + j) >> 1;
p2 = pointers[k];
if(p2 <= p)
i = k;
else
j = k;
}
p2 = pointers[i];
if((p2 != p) && (Tag_val(p) != Infix_tag)) {
fprintf(stderr, "%s: illegal pointer: 0x%08lx < 0x%08lx < 0x%08lx, size = %lud, tag = %d\n",
name,
(unsigned long) p2, (unsigned long) p, (unsigned long) pointers[i + 1],
Wosize_val(p), Tag_val(p));
fprintf(stderr, "points into: 0x%08lx: index = %d, size = %lud, tag = %d\n",
(unsigned long) p2, i, Wosize_val(p2), Tag_val(p2));
fprintf(stderr, "from block: 0x%08lx: size = %lud, tag = %d, field = %d\n",
(unsigned long) v, Wosize_val(v), Tag_val(v), index);
fflush(stderr);
abort();
}
}
CAMLprim value caml_clone_cont (value cont)
{
CAMLparam1(cont);
CAMLlocal3(new_cont, prev_target, source);
value target;
if (Field (cont, 0) == Val_unit)
caml_invalid_argument ("continuation already taken");
prev_target = Val_unit;
source = Field (cont, 0);
new_cont = caml_alloc (1, 0);
do {
Assert (Is_block (source) && Tag_val(source) == Stack_tag);
target = caml_alloc (Wosize_val(source), Stack_tag);
memcpy ((void*)target, (void*)source, Wosize_val(source) * sizeof(value));
if (prev_target == Val_unit) {
caml_modify (&Field(new_cont, 0), target);
} else {
caml_modify (&Stack_parent(prev_target), target);
}
prev_target = target;
source = Stack_parent(source);
} while (source != Val_unit);
CAMLreturn(new_cont);
}
CAMLprim value caml_string_length_based_compare(value s1, value s2)
{
mlsize_t len1, len2;
mlsize_t temp;
int res;
if (s1 == s2) return Val_int(0);
len1 = Wosize_val(s1);
temp = Bsize_wsize(len1) - 1 ;
len1 = temp - Byte(s1,temp);
len2 = Wosize_val(s2);
temp = Bsize_wsize(len2) - 1 ;
len2 = temp - Byte(s2,temp);
if (len1 != len2)
{
if (len1 < len2 ) {
return Val_long_clang(-1);
} else {
return Val_long_clang(1);
}
}
else {
res = memcmp(String_val(s1), String_val(s2), len1);
if(res < 0) return Val_long_clang(-1);
if(res > 0) return Val_long_clang(1);
return Val_long_clang(0);
}
}
CAMLexport char * caml_format_exception(value exn)
{
#ifndef NATIVE_CODE
if( bytecode_compatibility == Caml1999X008){
return Caml1999X008_caml_format_exception(exn);
} else
#endif
{
mlsize_t start, i;
value bucket, v;
struct stringbuf buf;
char intbuf[64];
char * res;
buf.ptr = buf.data;
buf.end = buf.data + sizeof(buf.data) - 1;
if (Tag_val(exn) == 0) {
add_string(&buf, String_val(Field(Field(exn, 0), 0)));
/* Check for exceptions in the style of Match_failure and Assert_failure */
if (Wosize_val(exn) == 2 &&
Is_block(Field(exn, 1)) &&
Tag_val(Field(exn, 1)) == 0 &&
caml_is_special_exception(Field(exn, 0))) {
bucket = Field(exn, 1);
start = 0;
} else {
bucket = exn;
start = 1;
}
add_char(&buf, '(');
for (i = start; i < Wosize_val(bucket); i++) {
if (i > start) add_string(&buf, ", ");
v = Field(bucket, i);
if (Is_long(v)) {
snprintf(intbuf, sizeof(intbuf),
"%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val(v));
add_string(&buf, intbuf);
} else if (Tag_val(v) == String_tag) {
add_char(&buf, '"');
add_string(&buf, String_val(v));
add_char(&buf, '"');
} else {
add_char(&buf, '_');
}
}
add_char(&buf, ')');
} else
add_string(&buf, String_val(Field(exn, 0)));
*buf.ptr = 0; /* Terminate string */
i = buf.ptr - buf.data + 1;
res = malloc(i);
if (res == NULL) return NULL;
memmove(res, buf.data, i);
return res;
}
}
static long compare_val(value v1, value v2)
{
tag_t t1, t2;
tailcall:
if (v1 == v2) return 0;
if (Is_long(v1) || Is_long(v2)) return Long_val(v1) - Long_val(v2);
/* If one of the objects is outside the heap (but is not an atom),
use address comparison. */
if ((!Is_atom(v1) && !Is_young(v1) && !Is_in_heap((addr)v1)) ||
(!Is_atom(v2) && !Is_young(v2) && !Is_in_heap((addr)v2)))
return v1 - v2;
t1 = Tag_val(v1);
t2 = Tag_val(v2);
if (t1 != t2) return (long)t1 - (long)t2;
switch(t1) {
case String_tag: {
mlsize_t len1, len2, len;
unsigned char * p1, * p2;
len1 = string_length(v1);
len2 = string_length(v2);
for (len = (len1 <= len2 ? len1 : len2),
p1 = (unsigned char *) String_val(v1),
p2 = (unsigned char *) String_val(v2);
len > 0;
len--, p1++, p2++)
if (*p1 != *p2) return (long)*p1 - (long)*p2;
return len1 - len2;
}
case Double_tag: {
double d1 = Double_val(v1);
double d2 = Double_val(v2);
if (d1 == d2) return 0; else if (d1 < d2) return -1; else return 1;
}
case Abstract_tag:
case Final_tag:
invalid_argument("equal: abstract value");
case Closure_tag:
invalid_argument("equal: functional value");
default: {
mlsize_t sz1 = Wosize_val(v1);
mlsize_t sz2 = Wosize_val(v2);
value * p1, * p2;
long res;
if (sz1 != sz2) return sz1 - sz2;
for(p1 = Op_val(v1), p2 = Op_val(v2);
sz1 > 1;
sz1--, p1++, p2++) {
res = compare_val(*p1, *p2);
if (res != 0) return res;
}
v1 = *p1;
v2 = *p2;
goto tailcall;
}
}
}
CAMLprim value caml_mcl(value inflation, value arr)
{
CAMLparam2(inflation, arr);
int i, cols = Wosize_val(arr);
mclv *domc = mclvCanonical(NULL, cols, 1.0);
mclv *domr = mclvCanonical(NULL, cols, 1.0);
mclx *res_mat, *mx = mclxAllocZero(domc, domr);
mclAlgParam *mlp;
value res;
for (i = 0; i < cols; ++i) {
value col = Field(arr, i);
int j, rows = Wosize_val(col);
mclv *col_vec = &mx->cols[i];
if (!cols)
continue;
mclvResize(col_vec, rows);
for (j = 0; j < rows; ++j) {
value t = Field(col, j);
col_vec->ivps[j].idx = Int_val(Field(t, 0));
col_vec->ivps[j].val = Double_val(Field(t, 1));
}
}
mclAlgInterface(&mlp, NULL, 0, NULL, mx, 0);
/* Optionally set inflation */
if (inflation != Val_none) {
mlp->mpp->mainInflation = Double_val(Some_val(inflation));
}
mclAlgorithm(mlp);
res_mat = mlp->cl_result;
cols = res_mat->dom_cols->n_ivps;
res = caml_alloc(cols, 0);
for (i = 0; i < cols; ++i) {
mclv *col_vec = &res_mat->cols[i];
int j, rows = col_vec->n_ivps;
value row = caml_alloc(rows, 0);
for (j = 0; j < rows; ++j) {
Store_field(row, j, Val_int(col_vec->ivps[j].idx));
}
Store_field(res, i, row);
}
mclAlgParamFree(&mlp, TRUE);
CAMLreturn(res);
}
value caml_mpi_allgather_float(value data, value result, value comm)
{
mlsize_t len = Wosize_val(data) / Double_wosize;
mlsize_t reslen = Wosize_val(result) / Double_wosize;
double * d = caml_mpi_input_floatarray(data, len);
double * res = caml_mpi_output_floatarray(result, reslen);
MPI_Allgather(d, len, MPI_DOUBLE, res, len, MPI_DOUBLE,
Comm_val(comm));
caml_mpi_free_floatarray(d);
caml_mpi_commit_floatarray(res, result, reslen);
return Val_unit;
}
value coq_closure_arity(value clos) {
opcode_t * c = Code_val(clos);
if (Is_instruction(c,RESTART)) {
c++;
if (Is_instruction(c,GRAB)) return Val_int(3 + c[1] - Wosize_val(clos));
else {
if (Wosize_val(clos) != 2) failwith("Coq Values : coq_closure_arity");
return Val_int(1);
}
}
if (Is_instruction(c,GRAB)) return Val_int(1 + c[1]);
return Val_int(1);
}
CAMLprim value caml_string_equal(value s1, value s2)
{
mlsize_t sz1, sz2;
value * p1, * p2;
if (s1 == s2) return Val_true;
sz1 = Wosize_val(s1);
sz2 = Wosize_val(s2);
if (sz1 != sz2) return Val_false;
for(p1 = Op_val(s1), p2 = Op_val(s2); sz1 > 0; sz1--, p1++, p2++)
if (*p1 != *p2) return Val_false;
return Val_true;
}
value coq_tcode_array(value tcodes) {
CAMLparam1(tcodes);
CAMLlocal2(res, tmp);
int i;
/* Assumes that the vector of types is small. This was implicit in the
previous code which was building the type array using Alloc_small. */
res = caml_alloc_small(Wosize_val(tcodes), Default_tag);
for (i = 0; i < Wosize_val(tcodes); i++) {
tmp = caml_alloc_small(1, Abstract_tag);
Code_val(tmp) = (code_t) Field(tcodes, i);
Store_field(res, i, tmp);
}
CAMLreturn(res);
}
value ml_cv_convert_array( value converter, value src, value dest ) {
CAMLparam3( converter, src, dest );
size_t n;
n = Wosize_val( dest ) / Double_wosize;
if ( n > ( Wosize_val( src ) / Double_wosize ) ) {
caml_raise_with_arg( *caml_named_value( "ut status exception" ), Val_int( UT_BAD_ARG ) );
}
cv_convert_doubles( UD_cv_converter_val( converter ), (double *)src, n, (double *)dest );
CAMLreturn( Val_unit );
}
value caml_mpi_scatter_floatarray(value source, value dest,
value root, value comm)
{
mlsize_t srclen = Wosize_val(source) / Double_wosize;
mlsize_t len = Wosize_val(dest) / Double_wosize;
double * src = caml_mpi_input_floatarray_at_node(source, srclen, root, comm);
double * dst = caml_mpi_output_floatarray(dest, len);
MPI_Scatter(src, len, MPI_DOUBLE, dst, len, MPI_DOUBLE,
Int_val(root), Comm_val(comm));
caml_mpi_free_floatarray(src);
caml_mpi_commit_floatarray(dst, dest, len);
return Val_unit;
}
/* llvalue -> string array -> (string * string) array -> ExecutionEngine.t ->
int */
CAMLprim value llvm_ee_run_function_as_main(LLVMValueRef F,
value Args, value Env,
LLVMExecutionEngineRef EE) {
CAMLparam2(Args, Env);
int I, NumArgs, NumEnv, EnvSize, Result;
const char **CArgs, **CEnv;
char *CEnvBuf, *Pos;
NumArgs = Wosize_val(Args);
NumEnv = Wosize_val(Env);
/* Build the environment. */
CArgs = (const char **) malloc(NumArgs * sizeof(char*));
for (I = 0; I != NumArgs; ++I)
CArgs[I] = String_val(Field(Args, I));
/* Compute the size of the environment string buffer. */
for (I = 0, EnvSize = 0; I != NumEnv; ++I) {
EnvSize += strlen(String_val(Field(Field(Env, I), 0))) + 1;
EnvSize += strlen(String_val(Field(Field(Env, I), 1))) + 1;
}
/* Build the environment. */
CEnv = (const char **) malloc((NumEnv + 1) * sizeof(char*));
CEnvBuf = (char*) malloc(EnvSize);
Pos = CEnvBuf;
for (I = 0; I != NumEnv; ++I) {
char *Name = String_val(Field(Field(Env, I), 0)),
*Value = String_val(Field(Field(Env, I), 1));
int NameLen = strlen(Name),
ValueLen = strlen(Value);
CEnv[I] = Pos;
memcpy(Pos, Name, NameLen);
Pos += NameLen;
*Pos++ = '=';
memcpy(Pos, Value, ValueLen);
Pos += ValueLen;
*Pos++ = '\0';
}
CEnv[NumEnv] = NULL;
Result = LLVMRunFunctionAsMain(EE, F, NumArgs, CArgs, CEnv);
free(CArgs);
free(CEnv);
free(CEnvBuf);
CAMLreturn(Val_int(Result));
}
CAMLprim value caml_weak_set (value ar, value n, value el)
{
mlsize_t offset = Long_val (n) + 1;
Assert (Is_in_heap (ar));
if (offset < 1 || offset >= Wosize_val (ar)){
caml_invalid_argument ("Weak.set");
}
if (el != None_val && Is_block (el)){
Assert (Wosize_val (el) == 1);
do_set (ar, offset, Field (el, 0));
}else{
Field (ar, offset) = caml_weak_none;
}
return Val_unit;
}
CAMLprim value
ml_XtOpenApplication( value application_class, value ml_widget_class, value ml_app_resources )
{
CAMLparam3(application_class, ml_widget_class, ml_app_resources);
CAMLlocal2(ret, app_context);
alloc_XtAppContext(app_context);
WidgetClass widget_class = get_shellWidgetClass(ml_widget_class);
char *p_argv[] = { };
int p_argc = 0;
/*
String app_resources[] = {
"*command.Label: Write text to stdout",
"*clear_command.Label: Clear",
"*quit_command.Label: Quit",
"*window.Title: Hello, world in Xt/Athena",
"*window.Geometry: 300x200+10+10",
"*ascii.Width: 280",
"*ascii.Height: 150",
NULL };
*/
String * app_resources;
app_resources = calloc(Wosize_val(ml_app_resources) + 1, sizeof(String *));
int i;
for (i=0; i<Wosize_val(ml_app_resources); ++i)
app_resources[i] = String_val(Field(ml_app_resources, i));
app_resources[i] = NULL;
Widget window = XtOpenApplication(
XtAppContext_val(app_context),
String_val(application_class),
NULL, // XrmOptionDescList options,
0, // Cardinal num_options,
&p_argc, // int* argc_in_out,
p_argv, // String* argv_in_out,
//NULL, // String* app_resources,
app_resources,
widget_class,
NULL, // ArgList args,
0 // Cardinal num_args
);
ret = caml_alloc(2, 0);
Store_field(ret, 0, app_context );
Store_field(ret, 1, Val_Widget(window) );
CAMLreturn(ret);
}
CAMLexport char * caml_format_exception(value exn)
{
mlsize_t start, i;
value bucket, v;
struct stringbuf buf;
char intbuf[64];
char * res;
buf.ptr = buf.data;
buf.end = buf.data + sizeof(buf.data) - 1;
add_string(&buf, String_val(Field(Field(exn, 0), 0)));
if (Wosize_val(exn) >= 2) {
/* Check for exceptions in the style of Match_failure and Assert_failure */
if (Wosize_val(exn) == 2 &&
Is_block(Field(exn, 1)) &&
Tag_val(Field(exn, 1)) == 0 &&
caml_is_special_exception(Field(exn, 0))) {
bucket = Field(exn, 1);
start = 0;
} else {
bucket = exn;
start = 1;
}
add_char(&buf, '(');
for (i = start; i < Wosize_val(bucket); i++) {
if (i > start) add_string(&buf, ", ");
v = Field(bucket, i);
if (Is_long(v)) {
sprintf(intbuf, "%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val(v));
add_string(&buf, intbuf);
} else if (Tag_val(v) == String_tag) {
add_char(&buf, '"');
add_string(&buf, String_val(v));
add_char(&buf, '"');
} else {
add_char(&buf, '_');
}
}
add_char(&buf, ')');
}
*buf.ptr = 0; /* Terminate string */
i = buf.ptr - buf.data + 1;
/* OCamlCC: fix g++ warning */
res = (char *) malloc(i);
if (res == NULL) return NULL;
memmove(res, buf.data, i);
return res;
}
CAMLprim value caml_array_set_addr(value array, value index, value newval)
{
intnat idx = Long_val(index);
if (idx < 0 || idx >= Wosize_val(array)) caml_array_bound_error();
Modify(&Field(array, idx), newval);
return Val_unit;
}
CAMLprim value caml_make_array(value init)
{
CAMLparam1 (init);
mlsize_t wsize, size, i;
CAMLlocal2 (v, res);
size = Wosize_val(init);
if (size == 0) {
CAMLreturn (init);
} else {
v = Field(init, 0);
if (Is_long(v)
|| ! Is_in_value_area(v)
|| Tag_val(v) != Double_tag) {
CAMLreturn (init);
} else {
Assert(size < Max_young_wosize);
wsize = size * Double_wosize;
res = caml_alloc_small(wsize, Double_array_tag);
for (i = 0; i < size; i++) {
Store_double_field(res, i, Double_val(Field(init, i)));
}
CAMLreturn (res);
}
}
}
CAMLprim value stub_gnttab_mapv_batched(
value xgh,
value array,
value writable)
{
CAMLparam3(xgh, array, writable);
CAMLlocal4(domid, reference, contents, pair);
int count = Wosize_val(array) / 2;
uint32_t domids[count];
uint32_t refs[count];
int i;
for (i = 0; i < count; i++) {
domids[i] = Int_val(Field(array, i * 2 + 0));
refs[i] = Int_val(Field(array, i * 2 + 1));
}
void *map =
xc_gnttab_map_grant_refs(_G(xgh),
count, domids, refs,
Bool_val(writable)?PROT_READ | PROT_WRITE : PROT_READ);
if(map==NULL) {
caml_failwith("Failed to map grant ref");
}
contents = caml_ba_alloc_dims(XC_GNTTAB_BIGARRAY, 1,
map, count << XC_PAGE_SHIFT);
pair = caml_alloc_tuple(2);
Store_field(pair, 0, contents); /* grant_handle */
Store_field(pair, 1, contents); /* Io_page.t */
CAMLreturn(pair);
}
/* Finish the work that was put off by [caml_oldify_one].
Note that [caml_oldify_one] itself is called by oldify_mopup, so we
have to be careful to remove the first entry from the list before
oldifying its fields. */
void caml_oldify_mopup (void)
{
value v, new_v, f;
mlsize_t i;
while (oldify_todo_list != 0){
v = oldify_todo_list; /* Get the head. */
Assert (Hd_val (v) == 0); /* It must be forwarded. */
new_v = Field (v, 0); /* Follow forward pointer. */
oldify_todo_list = Field (new_v, 1); /* Remove from list. */
f = Field (new_v, 0);
if (Is_block (f) && Is_young (f)){
caml_oldify_one (f, &Field (new_v, 0));
}
for (i = 1; i < Wosize_val (new_v); i++){
f = Field (v, i);
if (Is_block (f) && Is_young (f)){
caml_oldify_one (f, &Field (new_v, i));
}else{
Field (new_v, i) = f;
}
}
}
}
CAMLprim value c_push_and_multMatrix(value mat) {
if ((Wosize_val(mat) / Double_wosize) != 16)
caml_invalid_argument("draw_with_matrix: array length should be 16");
glPushMatrix();
glMultMatrixd( (double *)mat );
return Val_unit;
}
static void serialize_nat(value nat,
uintnat * wsize_32,
uintnat * wsize_64)
{
mlsize_t len = Wosize_val(nat) - 1;
#ifdef ARCH_SIXTYFOUR
len = len * 2; /* two 32-bit words per 64-bit digit */
if (len >= ((mlsize_t)1 << 32))
failwith("output_value: nat too big");
#endif
serialize_int_4((int32) len);
#if defined(ARCH_SIXTYFOUR) && defined(ARCH_BIG_ENDIAN)
{ int32 * p;
mlsize_t i;
for (i = len, p = Data_custom_val(nat); i > 0; i -= 2, p += 2) {
serialize_int_4(p[1]); /* low 32 bits of 64-bit digit */
serialize_int_4(p[0]); /* high 32 bits of 64-bit digit */
}
}
#else
serialize_block_4(Data_custom_val(nat), len);
#endif
*wsize_32 = len * 4;
*wsize_64 = len * 4;
}
/* Finish the work that was put off by [caml_oldify_one].
Note that [caml_oldify_one] itself is called by oldify_mopup, so we
have to be careful to remove the first entry from the list before
oldifying its fields. */
static void caml_oldify_mopup (void)
{
value v, new_v, f;
mlsize_t i;
while (oldify_todo_list != 0){
v = oldify_todo_list; /* Get the head. */
Assert (Hd_val (v) == 0); /* It must be forwarded. */
new_v = Op_val (v)[0]; /* Follow forward pointer. */
if (Tag_val(new_v) == Stack_tag) {
oldify_todo_list = Op_val (v)[1]; /* Remove from list (stack) */
caml_scan_stack(caml_oldify_one, new_v);
} else {
oldify_todo_list = Op_val (new_v)[1]; /* Remove from list (non-stack) */
f = Op_val (new_v)[0];
if (Is_block (f) && Is_young (f)){
caml_oldify_one (f, Op_val (new_v));
}
for (i = 1; i < Wosize_val (new_v); i++){
f = Op_val (v)[i];
if (Is_block (f) && Is_young (f)){
caml_oldify_one (f, Op_val (new_v) + i);
}else{
Op_val (new_v)[i] = f;
}
}
}
}
}
void print_closure (value v, int pass, hash_table_t* ht)
{
int i,size;
size=Wosize_val(v);
if (pass == PASS2)
{
printf("< %p", Code_val(v));
if (size > 1)
{
printf(", ");
for (i=1; i<size; i++)
{
print_value(Field(v,i), pass, ht);
if (i < size-1)
printf(", ");
}
}
printf(" > ");
}
return;
}
/* Return a Caml tuple/array containing all the globals of the given
context. The result should not be modified as it may share
structure with the context globals. The result may be invalidated
by loading more caml compilation units. */
CAMLprim value caml_global_array_r(CAML_R, value unit)
{
CAMLparam0();
#ifdef NATIVE_CODE
CAMLlocal1(globals);
const int global_no = ctx->caml_globals.local_used_size / sizeof(value);
globals = caml_alloc_tuple_r(ctx, global_no);
int i;
for(i = 0; i < global_no; i ++){
if(((value*)ctx->caml_globals.array)[i] == 0)
fprintf(stderr, "%%%%%%%%%% Context %p: the %i-th global is zero!\n", ctx, i);
caml_initialize_r(ctx, &Field(globals, i), ((value*)ctx->caml_globals.array)[i]);
}
int element_no = Wosize_val(globals);
assert(element_no == global_no);
//fprintf(stderr, "[native] The tuple has %i elements; it should be %i\n", (int)element_no, (int)global_no);
CAMLreturn(globals);
#else /* bytecode */
/* No need for GC-protection: there is no allocation here. */
// FIXME: for debugging only. Remove: BEGIN
//globals = ctx->caml_global_data;
//int element_no = Wosize_val(globals);
//fprintf(stderr, "[bytecode] The tuple has %i elements\n", (int)element_no);
// FIXME: for debugging only. Remove: END
CAMLreturn(ctx->caml_global_data);
#endif /* #else, #ifdef NATIVE_CODE */
}
//+ external ajoin : ?nosort:bool -> db -> cursor array -> get_flag list ->
//+ cursor = "caml_join_cursors"
//+ let join ?nosort db cursor_list get_flag_list =
//+ ajoin ?nosort db (Array.of_list cursor_list) get_flag_list
value caml_join_cursors(value vnosort, value db,
value vcursors, value vflags) {
CAMLparam4(vnosort,db,vcursors,vflags);
CAMLlocal1(rval);
DBC *jcurs; // pointer to joined cursor
int carray_len = Wosize_val(vcursors);
int flags = convert_flag_list(vflags,cursor_get_flags);
DBC *cursors[carray_len + 1];
int i;
if (Is_Some(vnosort) && Bool_val(vnosort)) {
flags = flags | DB_JOIN_NOSORT;
}
for (i=0; i < carray_len; i++) {
if (UW_cursor_closed(Field(vcursors,i))) {
invalid_argument("caml_join_cursors: Attempt to use closed cursor");
}
cursors[i] = UW_cursor(Field(vcursors,i));
}
cursors[i] = NULL;
test_db_closed(db);
UW_db(db)->join(UW_db(db),cursors,&jcurs,flags);
rval = alloc_custom(&cursor_custom,Camlcursor_wosize,0,1);
UW_cursor(rval) = jcurs;
UW_cursor_closed(rval) = False;
CAMLreturn (rval);
}
