static void print_token(struct parser_tables *tables, int state, value tok)
{
value v;
#if defined(__FreeBSD__) && defined(_KERNEL)
char buf[16];
#endif
if (Is_long(tok)) {
__fprintf(stderr, "State %d: read token %s\n",
state, token_name(tables->names_const, Int_val(tok)));
} else {
__fprintf(stderr, "State %d: read token %s(",
state, token_name(tables->names_block, Tag_val(tok)));
v = Field(tok, 0);
if (Is_long(v))
__fprintf(stderr, "%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val(v));
else if (Tag_val(v) == String_tag)
__fprintf(stderr, "%s", String_val(v));
else if (Tag_val(v) == Double_tag)
#if defined(__FreeBSD__) && defined(_KERNEL)
{
fixpt_to_str(Double_val(v), buf, 7);
__fprintf(stderr, "%s", buf);
}
#else
__fprintf(stderr, "%g", Double_val(v));
#endif
else
__fprintf(stderr, "_");
__fprintf(stderr, ")\n");
}
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;
}
}
}
void caml_stash_backtrace(value exn, code_t pc, value * sp, int reraise)
{
code_t end_code = (code_t) ((char *) caml_start_code + caml_code_size);
if (pc != NULL) pc = pc - 1;
if (exn != caml_backtrace_last_exn || !reraise) {
caml_backtrace_pos = 0;
caml_backtrace_last_exn = exn;
}
if (caml_backtrace_buffer == NULL) {
Assert(caml_backtrace_pos == 0);
caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t));
if (caml_backtrace_buffer == NULL) return;
}
if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) return;
/* testing the code region is needed: PR#1554 */
if (find_debug_info(pc) != NULL)
caml_backtrace_buffer[caml_backtrace_pos++] = pc;
/* Traverse the stack and put all values pointing into bytecode
into the backtrace buffer. */
for (/*nothing*/; sp < caml_stack_high + caml_trap_sp_off; sp++) {
code_t p = Pc_val(*sp);
if (Is_long(*sp) && Pc_val(*sp) >= caml_start_code && Pc_val(*sp) < end_code) {
if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) break;
if (find_debug_info(p) != NULL)
caml_backtrace_buffer[caml_backtrace_pos++] = p;
}
}
}
void ml_payment_init(value pubkey, value scb, value ecb) {
if (successCb == 0) {
successCb = scb;
caml_register_generational_global_root(&successCb);
errorCb = ecb;
caml_register_generational_global_root(&errorCb);
} else {
caml_modify_generational_global_root(&successCb,scb);
caml_modify_generational_global_root(&errorCb,ecb);
}
if (!Is_long(pubkey)) {
JNIEnv *env;
(*gJavaVM)->GetEnv(gJavaVM, (void**) &env, JNI_VERSION_1_4);
jclass securityCls = (*env)->FindClass(env, "ru/redspell/lightning/payments/Security");
jmethodID setPubkey = (*env)->GetStaticMethodID(env, securityCls, "setPubkey", "(Ljava/lang/String;)V");
char* cpubkey = String_val(Field(pubkey, 0));
jstring jpubkey = (*env)->NewStringUTF(env, cpubkey);
(*env)->CallStaticVoidMethod(env, securityCls, setPubkey, jpubkey);
(*env)->DeleteLocalRef(env, securityCls);
(*env)->DeleteLocalRef(env, jpubkey);
}
}
void caml_stash_backtrace(value exn, code_t pc, value * sp, int reraise)
{
if (pc != NULL) pc = pc - 1;
if (exn != caml_read_root(Caml_state->backtrace_last_exn) || !reraise) {
Caml_state->backtrace_pos = 0;
caml_modify_root(Caml_state->backtrace_last_exn, exn);
}
if (Caml_state->backtrace_buffer == NULL &&
caml_alloc_backtrace_buffer() == -1)
return;
if (Caml_state->backtrace_pos >= BACKTRACE_BUFFER_SIZE) return;
/* testing the code region is needed: PR#1554 */
if (find_debug_info(pc) != NULL)
Caml_state->backtrace_buffer[Caml_state->backtrace_pos++] = pc;
/* Traverse the stack and put all values pointing into bytecode
into the backtrace buffer. */
value *trap_sp = Stack_high(Caml_state->current_stack) + Caml_state->trap_sp_off;
for (/*nothing*/; sp < trap_sp; sp++) {
if (Is_long(*sp)) {
code_t p = Pc_val(*sp);
if (Caml_state->backtrace_pos >= BACKTRACE_BUFFER_SIZE) break;
if (find_debug_info(p) != NULL)
Caml_state->backtrace_buffer[Caml_state->backtrace_pos++] = p;
}
}
}
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
ml_osmesacreatecontext( value _format,
value ml_sharelist )
{
OSMesaContext ctx;
OSMesaContext sharelist;
GLenum format;
if (Is_long(ml_sharelist))
sharelist = NULL;
else
sharelist = (OSMesaContext) Field(ml_sharelist,0);
switch (Int_val(_format)) {
case 0: format = OSMESA_COLOR_INDEX; break;
case 1: format = OSMESA_RGBA; break;
case 2: format = OSMESA_BGRA; break;
case 3: format = OSMESA_ARGB; break;
case 4: format = OSMESA_RGB; break;
case 5: format = OSMESA_BGR; break;
}
ctx = OSMesaCreateContext( format, sharelist );
if (!ctx)
caml_failwith("osMesaCreateContext");
return (value) ctx;
}
DataType
Marshaller::dataType (value value)
{
if (Is_long (value))
{
switch (Int_val (value))
{
case 0: return Type_Unit;
}
}
else
{
switch (Tag_val (value))
{
case 0: return Type_Bool;
case 1: return Type_Char;
case 2: return Type_Int;
case 3: return Type_IntRef;
case 4: return Type_Float;
case 5: return Type_Int64;
case 6: return Type_String;
case 7: return Type_VoidP;
case 8: return Type_ClassP;
case 9: return Type_ObjectP;
}
}
throw caml_exception ("Invalid tag");
}
void print_block(value v, int m)
{
int size, i;
margin(m);
if (Is_long(v))
{
printf("immediate value (%ld)\n", Long_val(v));
return;
}
printf("memory block: size=%d - ", size=Wosize_val(v));
switch(Tag_val(v))
{
case Closure_tag:
printf("closure with %d free variables\n", size-1);
margin(m+4);
printf("code pointer: %p\n", Code_val(v));
for (i=1; i<size; i++)
print_block(Field(v,i),m+4);
break;
case String_tag:
printf("string: %s (%s)\n", String_val(v), (char *) v);
break;
case Double_tag:
printf("float: %g\n", Double_val(v));
break;
case Double_array_tag:
printf("float array: ");
for (i=0; i<size/Double_wosize; i++)
printf(" %g", Double_field(v,i));
printf("\n");
break;
case Abstract_tag:
printf("abstract type\n");
break;
case Custom_tag:
printf("abstract finalized type\n");
break;
default:
if (Tag_val(v) >= No_scan_tag)
{
printf("unknown tag");
break;
};
printf("structured block (tag=%d):\n", Tag_val(v));
for (i=0; i<size; i++)
print_block(Field(v,i), m+4);
}
return;
}
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;
}
}
CAMLprim value caml_gc_major_slice (value v)
{
CAML_INSTR_SETUP (tmr, "");
Assert (Is_long (v));
caml_empty_minor_heap ();
caml_major_collection_slice (Long_val (v));
CAML_INSTR_TIME (tmr, "explicit/gc_major_slice");
return Val_long (0);
}
static Uint8 state_of_value(value l)
{
Uint8 state = 0;
while(is_not_nil(l)){
if (Is_long(hd(l)))
state |= 1 << Int_val(hd(l));
l = tl(l);
}
return state;
}
CAMLprim value caml_gc_major_slice (value v)
{
intnat res;
CAMLassert (Is_long (v));
caml_ev_pause(EV_PAUSE_GC);
caml_empty_minor_heap ();
res = caml_major_collection_slice(Long_val(v), 0);
caml_ev_resume();
caml_handle_gc_interrupt();
return Val_long (res);
}
static value caml_promote_one(struct promotion_stack* stk, struct domain* domain, value curr)
{
header_t curr_block_hd;
int infix_offset = 0;
if (Is_long(curr) || !Is_minor(curr))
return curr; /* needs no promotion */
Assert(caml_owner_of_young_block(curr) == domain);
curr_block_hd = Hd_val(curr);
if (Tag_hd(curr_block_hd) == Infix_tag) {
infix_offset = Infix_offset_val(curr);
curr -= infix_offset;
curr_block_hd = Hd_val(curr);
}
if (Is_promoted_hd(curr_block_hd)) {
/* already promoted */
return caml_addrmap_lookup(&domain->state->remembered_set->promotion, curr) + infix_offset;
} else if (curr_block_hd == 0) {
/* promoted by minor GC */
return Op_val(curr)[0] + infix_offset;
}
/* otherwise, must promote */
void* mem = caml_shared_try_alloc(domain->shared_heap, Wosize_hd(curr_block_hd),
Tag_hd(curr_block_hd), 1);
if (!mem) caml_fatal_error("allocation failure during promotion");
value promoted = Val_hp(mem);
Hd_val(curr) = Promotedhd_hd(curr_block_hd);
caml_addrmap_insert(&domain->state->remembered_set->promotion, curr, promoted);
caml_addrmap_insert(&domain->state->remembered_set->promotion_rev, promoted, curr);
if (Tag_hd(curr_block_hd) >= No_scan_tag) {
int i;
for (i = 0; i < Wosize_hd(curr_block_hd); i++)
Op_val(promoted)[i] = Op_val(curr)[i];
} else {
/* push to stack */
if (stk->sp == stk->stack_len) {
stk->stack_len = 2 * (stk->stack_len + 10);
stk->stack = caml_stat_resize(stk->stack,
sizeof(struct promotion_stack_entry) * stk->stack_len);
}
stk->stack[stk->sp].local = curr;
stk->stack[stk->sp].global = promoted;
stk->stack[stk->sp].field = 0;
stk->sp++;
}
return promoted + infix_offset;
}
static void print_token(struct parser_tables *tables, int state, value tok)
{
value v;
if (Is_long(tok)) {
fprintf(stderr, "State %d: read token %s\n",
state, token_name(tables->names_const, Int_val(tok)));
} else {
fprintf(stderr, "State %d: read token %s(",
state, token_name(tables->names_block, Tag_val(tok)));
v = Field(tok, 0);
if (Is_long(v))
fprintf(stderr, "%ld", Long_val(v));
else if (Tag_val(v) == String_tag)
fprintf(stderr, "%s", String_val(v));
else if (Tag_val(v) == Double_tag)
fprintf(stderr, "%g", Double_val(v));
else
fprintf(stderr, "_");
fprintf(stderr, ")\n");
}
}
CAMLprim
value caml_extunix_signalfd(value vfd, value vsigs, value vflags, value v_unit)
{
CAMLparam4(vfd, vsigs, vflags, v_unit);
int fd = ((Val_none == vfd) ? -1 : Int_val(Some_val(vfd)));
int flags = 0;
int ret = 0;
sigset_t ss;
sigemptyset (&ss);
while (!Is_long (vsigs)) {
int sig = caml_convert_signal_number (Int_val (Field (vsigs, 0)));
if (sigaddset (&ss, sig) < 0) uerror ("sigaddset", Nothing);
vsigs = Field (vsigs, 1);
}
while (!Is_long (vflags)) {
int f = Int_val (Field (vflags, 0));
if (SFD_NONBLOCK == f) flags |= SFD_NONBLOCK;
if (SFD_CLOEXEC == f) flags |= SFD_CLOEXEC;
vflags = Field (vflags, 1);
}
ret = signalfd (fd, &ss, flags);
if (ret < 0) uerror ("signalfd", Nothing);
CAMLreturn (Val_int (ret));
}
code_t caml_next_frame_pointer(value* stack_high, value ** sp,
intnat * trap_spoff)
{
while (*sp < stack_high) {
value* p = (*sp)++;
if(&Trap_pc(stack_high + *trap_spoff) == p) {
*trap_spoff = Trap_link(stack_high + *trap_spoff);
continue;
}
if (Is_long(*p) && find_debug_info(Pc_val(*p)) != NULL)
return Pc_val(*p);
}
return NULL;
}
static void print_token(struct parser_tables *tables, int state, value tok)
{
CAMLparam1 (tok);
CAMLlocal1 (v);
if (Is_long(tok)) {
fprintf(stderr, "State %d: read token %s\n",
state, token_name(tables->names_const, Int_val(tok)));
} else {
fprintf(stderr, "State %d: read token %s(",
state, token_name(tables->names_block, Tag_val(tok)));
caml_read_field(tok, 0, &v);
if (Is_long(v))
fprintf(stderr, "%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val(v));
else if (Tag_val(v) == String_tag)
fprintf(stderr, "%s", String_val(v));
else if (Tag_val(v) == Double_tag)
fprintf(stderr, "%g", Double_val(v));
else
fprintf(stderr, "_");
fprintf(stderr, ")\n");
}
CAMLreturn0;
}
CAMLprim value xmlsecml_xmlSecKeyGenerate(value camlId, value camlSize, value camlType)
{
CAMLparam3(camlId, camlSize, camlType);
xmlSecKeyDataId id;
xmlSecSize size;
xmlSecKeyDataType type;
xmlSecKeyPtr key = NULL;
assert ( Is_long(camlId) );
id = xmlSecKeyDataAesId;
size = Int_val(camlSize);
type = Int_val(camlType);
key = xmlSecKeyGenerate(id, size, type);
assert(key != NULL);
CAMLreturn(alloc_key(key));
}
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 ocaml_ssl_ctx_set_verify(value context, value vmode, value vcallback)
{
CAMLparam3(context, vmode, vcallback);
SSL_CTX *ctx = Ctx_val(context);
int mode = 0;
value mode_tl = vmode;
int (*callback) (int, X509_STORE_CTX*) = NULL;
if (Is_long(vmode))
mode = SSL_VERIFY_NONE;
while (Is_block(mode_tl))
{
switch(Int_val(Field(mode_tl, 0)))
{
case 0:
mode |= SSL_VERIFY_PEER;
break;
case 1:
mode |= SSL_VERIFY_FAIL_IF_NO_PEER_CERT | SSL_VERIFY_PEER;
break;
case 2:
mode |= SSL_VERIFY_CLIENT_ONCE | SSL_VERIFY_PEER;
break;
default:
caml_invalid_argument("mode");
}
mode_tl = Field(mode_tl, 1);
}
if (Is_block(vcallback))
callback = (int(*) (int, X509_STORE_CTX*))Field(vcallback, 0);
caml_enter_blocking_section();
SSL_CTX_set_verify(ctx, mode, callback);
caml_leave_blocking_section();
CAMLreturn(Val_unit);
}
code_t caml_next_frame_pointer(value ** sp, intnat * trap_spoff)
{
code_t end_code = (code_t) ((char *) caml_start_code + caml_code_size);
while (*sp < caml_stack_high) {
value *p = (*sp)++;
if(&Trap_pc(caml_stack_high + *trap_spoff) == p) {
*trap_spoff = Trap_link(caml_stack_high + *trap_spoff);
continue;
}
if (Is_long(*p) &&
Pc_val(*p) >= caml_start_code &&
Pc_val(*p) < end_code &&
find_debug_info((code_t)*p)) {
return Pc_val(*p);
}
}
return NULL;
}
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
ml_osmesacreatecontextext( value _format,
value depthBits,
value stencilBits,
value accumBits,
value ml_sharelist )
{
OSMesaContext ctx;
OSMesaContext sharelist;
GLenum format;
if (Is_long(ml_sharelist))
sharelist = NULL;
else
sharelist = (OSMesaContext) Field(ml_sharelist,0);
switch (Int_val(_format)) {
case 0: format = OSMESA_COLOR_INDEX; break;
case 1: format = OSMESA_RGBA; break;
case 2: format = OSMESA_BGRA; break;
case 3: format = OSMESA_ARGB; break;
case 4: format = OSMESA_RGB; break;
case 5: format = OSMESA_BGR; break;
}
#if OSMESA_MAJOR_VERSION * 100 + OSMESA_MINOR_VERSION >= 305
ctx = OSMesaCreateContextExt( format,
Int_val(depthBits),
Int_val(stencilBits),
Int_val(accumBits),
sharelist );
#else
caml_failwith("function OSMesaCreateContextExt not available");
#endif
if (!ctx) {
caml_failwith("osMesaCreateContextExt");
}
return (value) ctx;
}
CAMLprim value
caml_backpack_mq_open(value val_name, value val_flags, value val_mode, value val_attr)
{
CAMLparam4(val_name, val_flags, val_mode, val_attr);
CAMLlocal1(val_res);
int flags = caml_convert_flag_list(val_flags, mqueue_flags);
struct mq_attr attr, *pattr;
mqd_t mq;
if (Is_long(val_attr))
pattr = NULL;
else {
attr.mq_maxmsg = Long_val(Field(Field(val_attr, 0), 0));
attr.mq_msgsize = Long_val(Field(Field(val_attr, 0), 1));
pattr = &attr;
}
if ((mq = mq_open(String_val(val_name), flags, Int_val(val_mode), pattr)) == -1)
uerror("mq_open", val_name);
val_res = Val_int(mq);
CAMLreturn(val_res);
}
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_in_value_area(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);
}
value netsys_copy_value(value flags, value orig)
{
int code;
int cflags;
intnat start_offset, bytelen;
mlsize_t wosize;
char *dest, *dest_end, *extra_block, *extra_block_end;
int color;
struct named_custom_ops bigarray_ops;
struct named_custom_ops int32_ops;
struct named_custom_ops int64_ops;
struct named_custom_ops nativeint_ops;
CAMLparam2(orig,flags);
CAMLlocal1(block);
/* First test on trivial cases: */
if (Is_long(orig) || Wosize_val(orig) == 0) {
CAMLreturn(orig);
};
code = prep_stat_tab();
if (code != 0) goto exit;
code = prep_stat_queue();
if (code != 0) goto exit;
cflags = caml_convert_flag_list(flags, init_value_flags);
/* fprintf (stderr, "counting\n"); */
/* Count only! */
code = netsys_init_value_1(stat_tab, stat_queue, NULL, NULL, orig,
(cflags & 1) ? 1 : 0, /* enable_bigarrays */
(cflags & 2) ? 1 : 0, /* enable_customs */
1, /* enable_atoms */
1, /* simulate */
NULL, NULL, 0, &start_offset, &bytelen);
if (code != 0) goto exit;
/* fprintf (stderr, "done counting bytelen=%ld\n", bytelen); */
/* set up the custom ops. We always set this, because we assume that
the values in [orig] are not trustworthy
*/
bigarray_ops.name = "_bigarray";
bigarray_ops.ops =
Custom_ops_val(alloc_bigarray_dims(CAML_BA_UINT8 | BIGARRAY_C_LAYOUT,
1, NULL, 1));
bigarray_ops.next = &int32_ops;
int32_ops.name = "_i";
int32_ops.ops = Custom_ops_val(caml_copy_int32(0));
int32_ops.next = &int64_ops;
int64_ops.name = "_j";
int64_ops.ops = Custom_ops_val(caml_copy_int64(0));
int64_ops.next = &nativeint_ops;
nativeint_ops.name = "_n";
nativeint_ops.ops = Custom_ops_val(caml_copy_nativeint(0));
nativeint_ops.next = NULL;
/* alloc */
extra_block = NULL;
extra_block_end = NULL;
/* shamelessly copied from intern.c */
wosize = Wosize_bhsize(bytelen);
/* fprintf (stderr, "wosize=%ld\n", wosize); */
if (wosize > Max_wosize) {
/* Round desired size up to next page */
asize_t request = ((bytelen + Page_size - 1) >> Page_log) << Page_log;
extra_block = caml_alloc_for_heap(request);
if (extra_block == NULL) caml_raise_out_of_memory();
extra_block_end = extra_block + request;
color = caml_allocation_color(extra_block);
dest = extra_block;
dest_end = dest + bytelen;
block = Val_hp(extra_block);
} else {
static void extern_rec(value v)
{
tailcall:
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);
return;
}
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;
goto tailcall;
}
}
/* 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);
}
return;
}
/* 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);
}
return;
}
/* 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;
mlsize_t i;
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);
if (sz == 1) {
v = field0;
} else {
extern_rec(field0);
for (i = 1; i < sz - 1; i++) extern_rec(Field(v, i));
v = Field(v, i);
}
goto tailcall;
}
}
}
else if ((char *) v >= caml_code_area_start &&
void print_value (value v, int pass, hash_table_t *ht)
{
int size, i, n, ret;
unsigned long key;
char buf[256];
addr_list_t* entry;
if (Is_long(v))
{
if (pass == PASS2)
printf("%ld ", Long_val(v));
return;
}
size=Wosize_val(v);
switch (Tag_val(v))
{
case Closure_tag:
print_closure (v, pass, ht);
break;
case String_tag:
print_string(v);
break;
case Double_tag:
if (pass == PASS2)
printf("%g ", Double_val(v));
break;
case Double_array_tag:
if (pass == PASS2)
{
printf("[| ");
n = size/Double_wosize;
for (i=0; i<n; i++)
{
printf("%g", Double_field(v,i));
if (i < (n-1))
printf("; ");
else
printf(" ");
}
printf("|]");
}
break;
case Abstract_tag:
if (pass == PASS2)
printf("(abstract) ");
break;
case Custom_tag:
if (pass == PASS2)
printf("(custom) ");
break;
default:
if (pass == PASS2 && Tag_val(v) >= No_scan_tag)
{
printf("(unknown) ");
break;
};
/*
For structured values, PASS1 gathers information about addresses and
PASS2 prints it. We use MINCYCCNT as a threshold for printing cyclic/shared
values. The name of the value is just its stringified address.
*/
if (pass == PASS1)
{
key = (unsigned long)v;
entry = get(ht, key);
if ((entry == NULL) || (entry->count < MINCYCCNT))
{
buf[0] = '\0';
sprintf(buf,"var_%lx",key);
put(ht, key, strdup(buf));
}
for (i=0; i<size; i++)
{
key = (unsigned long)Field(v,i);
entry = get(ht, key);
if ((entry == NULL) || (entry->count < MINCYCCNT))
print_value(Field(v,i), pass, ht);
}
}
else if (pass == PASS2)
{
key = (unsigned long)v;
entry = get(ht, key);
if ((entry != NULL) && (entry->count >= MINCYCCNT))
{
printf("(v=%s) ", entry->val);
if (entry->printed == FALSE)
{
entry->printed = TRUE;
printf("( ");
for (i=0; i<size; i++)
{
print_value(Field(v,i), pass, ht);
if (i < (size-1))
printf(", ");
}
printf(") ");
}
} else
{
printf("( ");
for (i=0; i<size; i++)
{
print_value(Field(v,i), pass, ht);
if (i < (size-1))
printf(", ");
}
printf(") ");
}
}
}
return;
}
CAMLexport char * caml_format_exception(value exn)
{
mlsize_t start, i;
struct stringbuf buf;
char intbuf[64];
char * res;
CAMLparam1(exn);
CAMLlocal4(bucket, v, exnclass, field1);
buf.ptr = buf.data;
buf.end = buf.data + sizeof(buf.data) - 1;
/* An exception class is a value with tag Object_tag, whose first
field is a string naming the exception.
Exceptions that take parameters (e.g. Invalid_argument) are blocks
with tag 0, where the first field is the exception class.
Exceptions without parameters (e.g. Not_found) are just the exception
class. */
if (Tag_val(exn) == 0) {
/* Field 0 of exn is the exception class, which is immutable */
exnclass = Field_imm(exn, 0);
add_string(&buf, String_val(Field_imm(exnclass, 0)));
/* Check for exceptions in the style of Match_failure and Assert_failure */
if (Wosize_val(exn) == 2) {
caml_read_field(exn, 1, &field1);
} else {
field1 = Val_unit;
}
if (Is_block(field1) &&
Tag_val(field1) == 0 &&
caml_is_special_exception(exnclass)) {
bucket = field1;
start = 0;
} else {
bucket = exn;
start = 1;
}
add_char(&buf, '(');
for (i = start; i < Wosize_val(bucket); i++) {
if (i > start) add_string(&buf, ", ");
caml_read_field(bucket, i, &v);
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 {
/* Exception without parameters */
exnclass = exn;
add_string(&buf, String_val(Field_imm(exnclass, 0)));
}
*buf.ptr = 0; /* Terminate string */
i = buf.ptr - buf.data + 1;
res = malloc(i);
if (res == NULL) CAMLreturnT (char*, NULL);
memmove(res, buf.data, i);
CAMLreturnT (char*, res);
}
