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); }