void AddField(const ConstString &name, const CompilerType &type, uint64_t offset) { m_fields.push_back(Field(name, type, offset)); }
CAMLexport void caml_raise_not_found(void) { caml_raise_constant(Field(caml_global_data, NOT_FOUND_EXN)); }
void caml_init_exceptions(void) { out_of_memory_bucket.hdr = Make_header(1, 0, Caml_white); out_of_memory_bucket.exn = Field(caml_global_data, OUT_OF_MEMORY_EXN); caml_register_global_root(&out_of_memory_bucket.exn); }
CAMLexport void caml_raise_stack_overflow(void) { caml_raise_constant(Field(caml_global_data, STACK_OVERFLOW_EXN)); }
CAMLexport void caml_raise_end_of_file(void) { caml_raise_constant(Field(caml_global_data, END_OF_FILE_EXN)); }
value pgconn_alloc(PGconn* conn) { value res = alloc(1, Abstract_tag); initialize(&Field(res, 0), (value)conn); return res; }
static void expand_block(value32 * source, value * dest, mlsize_t source_len, mlsize_t dest_len, color_t color) { value32 * p, * q; value * d, * e; header_t hd; mlsize_t sz; tag_t tag; uint32_t * forward_addr; uint32_t dest_ofs; value v; /* First pass: copy the objects and set up forwarding pointers. The pointers contained inside blocks are not resolved. */ for (p = source, q = source + source_len, d = dest; p < q; /*nothing*/) { hd = (header_t) *p++; sz = Wosize_hd(hd); tag = Tag_hd(hd); forward_addr = (uint32_t *) p; dest_ofs = d + 1 - dest; switch(tag) { case String_tag: { mlsize_t ofs_last_byte, len, new_sz; ofs_last_byte = sz * sizeof(value32) - 1; len = ofs_last_byte - Byte(p, ofs_last_byte); new_sz = (sz * sizeof(value32) + sizeof(value) - 1) / sizeof(value); *d++ = Make_header(new_sz, String_tag, color); Field(d, new_sz - 1) = 0; bcopy((char *)p, (char *)d, len); ofs_last_byte = new_sz * sizeof(value) - 1; Byte(d, ofs_last_byte) = ofs_last_byte - len; p += sz; d += new_sz; break; } case Double_tag: *d++ = Make_header(Double_wosize, Double_tag, color); /* Cannot do *((double *) d) = *((double *) p) directly because p might not be 64-aligned. */ assert(sizeof(double) == sizeof(value)); ((value32 *) d)[0] = p[0]; ((value32 *) d)[1] = p[1]; p += sizeof(double) / sizeof(value32); d += 1; break; default: *d++ = Make_header(sz, tag, color); for (/*nothing*/; sz > 0; sz--, p++, d++) { if ((*p & 1) == 0) { *d = *((uint32_t *) p); /* copy, zero expansion */ } else { *d = *((int32_t *) p); /* copy, sign expansion */ } } break; } *forward_addr = dest_ofs; /* store the forwarding pointer */ } assert(d == dest + dest_len); /* Second pass: resolve pointers contained inside blocks, replacing them by the corresponding forwarding pointer. */ for (d = dest, e = dest + dest_len; d < e; /*nothing*/) { hd = (header_t) *d++; sz = Wosize_hd(hd); tag = Tag_hd(hd); if (tag >= No_scan_tag) { d += sz; } else { for (/*nothing*/; sz > 0; sz--, d++) { v = *d; switch(v & 3) { case 0: /* 0: a block represented by its offset */ assert(v >= 0 && v < source_len * sizeof(value32) && (v & 3) == 0); *d = (value) (dest + *((uint32_t *)((char *) source + v))); break; case 2: /* 2: an atom */ v = v >> 2; assert(v >= 0 && v < 256); *d = Atom(v); break; default: /* 1 or 3: an integer */ break; } } } } }
CAMLprim value caml_gc_set(value v) { return Val_unit; #if 0 uintnat newpf, newpm; asize_t newheapincr; asize_t newminwsz; uintnat oldpolicy; CAML_INSTR_SETUP (tmr, ""); caml_params->verb_gc = Long_field (v, 3); #ifndef NATIVE_CODE caml_change_max_stack_size (Long_field (v, 5)); #endif newpf = norm_pfree (Long_field (v, 2)); if (newpf != caml_percent_free){ caml_percent_free = newpf; caml_gc_message (0x20, "New space overhead: %" ARCH_INTNAT_PRINTF_FORMAT "u%%\n", caml_percent_free); } newpm = norm_pmax (Long_field (v, 4)); if (newpm != caml_percent_max){ caml_percent_max = newpm; caml_gc_message (0x20, "New max overhead: %" ARCH_INTNAT_PRINTF_FORMAT "u%%\n", caml_percent_max); } newheapincr = Long_field (v, 1); if (newheapincr != caml_major_heap_increment){ caml_major_heap_increment = newheapincr; if (newheapincr > 1000){ caml_gc_message (0x20, "New heap increment size: %" ARCH_INTNAT_PRINTF_FORMAT "uk words\n", caml_major_heap_increment/1024); }else{ caml_gc_message (0x20, "New heap increment size: %" ARCH_INTNAT_PRINTF_FORMAT "u%%\n", caml_major_heap_increment); } } oldpolicy = caml_allocation_policy; caml_set_allocation_policy (Long_field (v, 6)); if (oldpolicy != caml_allocation_policy){ caml_gc_message (0x20, "New allocation policy: %" ARCH_INTNAT_PRINTF_FORMAT "u\n", caml_allocation_policy); } /* This field was added in 4.03.0. */ if (Wosize_val (v) >= 8){ int old_window = caml_major_window; caml_set_major_window (norm_window (Long_val (Field (v, 7)))); if (old_window != caml_major_window){ caml_gc_message (0x20, "New smoothing window size: %d\n", caml_major_window); } } /* Minor heap size comes last because it will trigger a minor collection (thus invalidating [v]) and it can raise [Out_of_memory]. */ newminsize = caml_norm_minor_heap_size (Long_field (v, 0)); if (newminsize != Caml_state->minor_heap_size){ caml_gc_message (0x20, "New minor heap size: %luk bytes\n", newminsize/1024); caml_set_minor_heap_size (newminsize); } CAML_INSTR_TIME (tmr, "explicit/gc_set"); return Val_unit; #endif }
CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout, value vshared, value vdim, value vstart) { int fd, flags, major_dim, shared; intnat num_dims, i; intnat dim[CAML_BA_MAX_NUM_DIMS]; file_offset startpos, file_size, data_size; struct stat st; uintnat array_size, page, delta; void * addr; fd = Int_val(vfd); flags = Int_val(vkind) | Int_val(vlayout); startpos = File_offset_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. We avoid lseek here because it is fragile, and because some mappable file types do not support it */ caml_enter_blocking_section(); if (fstat(fd, &st) == -1) { caml_leave_blocking_section(); caml_sys_error(NO_ARG); } file_size = st.st_size; /* 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 major dimension is unknown */ if (dim[major_dim] == -1) { /* Determine major dimension from file size */ if (file_size < startpos) { caml_leave_blocking_section(); 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_leave_blocking_section(); caml_failwith("Bigarray.mmap: file size doesn't match array dimensions"); } } else { /* Check that file is large enough, and grow it otherwise */ if (file_size < startpos + array_size) { if (caml_grow_file(fd, startpos + array_size) == -1) { /* PR#5543 */ caml_leave_blocking_section(); caml_sys_error(NO_ARG); } } } /* Determine offset so that the mapping starts at the given file pos */ page = getpagesize(); delta = (uintnat) startpos % page; /* Do the mmap */ shared = Bool_val(vshared) ? MAP_SHARED : MAP_PRIVATE; if (array_size > 0) addr = mmap(NULL, array_size + delta, PROT_READ | PROT_WRITE, shared, fd, startpos - delta); else addr = NULL; /* PR#5463 - mmap fails on empty region */ caml_leave_blocking_section(); if (addr == (void *) MAP_FAILED) caml_sys_error(NO_ARG); addr = (void *) ((uintnat) addr + delta); /* Build and return the OCaml bigarray */ return caml_ba_alloc(flags | CAML_BA_MAPPED_FILE, num_dims, addr, dim); }
/* given a return value in OCaml land, translate it to the return_val_t C structure */ return_val_t translate_return_value(value ocaml_result) { CAMLparam1(ocaml_result); CAMLlocal5(ocaml_shape, ocaml_strides, ocaml_data, ocaml_cur, ocaml_type); CAMLlocal1(v); return_val_t ret; if (Is_long(ocaml_result)) { // In this case, we know that the return code must have been Pass, // since the other two return codes have data. ret.return_code = RET_PASS; ret.results_len = 0; } else if (Tag_val(ocaml_result) == RET_FAIL) { ret.return_code = RET_FAIL; ret.results_len = caml_string_length(Field(ocaml_result, 0)); ret.error_msg = malloc(ret.results_len + 1); strcpy(ret.error_msg, String_val(Field(ocaml_result, 0))); } else if (Tag_val(ocaml_result) == RET_SUCCESS) { ocaml_cur = Field(ocaml_result, 0); ret.return_code = RET_SUCCESS; ret.results_len = ocaml_list_length(ocaml_cur); ret.results = (ret_t*)malloc(sizeof(ret_t) * ret.results_len); int i, j; host_val h; for (i = 0; i < ret.results_len; ++i) { v = Field(ocaml_cur, 0); h = create_host_val(v); ocaml_cur = Field(ocaml_cur, 1); // returning a scalar if (value_is_scalar(h)) { ret.results[i].is_scalar = 1; ocaml_type = (scalar_type)value_type_of(h); ret.results[i].data.scalar.ret_type = get_scalar_element_type(ocaml_type); // WARNING: // Tiny Memory Leak Ahead // ----------------------- // When scalar data is returned to the host language // on the heap, it should be manually deleted by the // host frontend if (type_is_bool(ocaml_type)) { ret.results[i].data.scalar.ret_scalar_value.boolean = get_bool(h); } else if (type_is_int32(ocaml_type)) { ret.results[i].data.scalar.ret_scalar_value.int32 = get_int32(h); } else if (type_is_int64(ocaml_type)) { ret.results[i].data.scalar.ret_scalar_value.int64 = get_int64(h); } else if (type_is_float32(ocaml_type)) { ret.results[i].data.scalar.ret_scalar_value.float32 = get_float64(h); } else if (type_is_float64(ocaml_type)) { ret.results[i].data.scalar.ret_scalar_value.float64 = get_float64(h); } else { caml_failwith("Unable to return scalar of this type\n"); } } else { // Pass the type ret.results[i].is_scalar = 0; ret.results[i].data.array.ret_type = array_type_of(h); // Pass the data ret.results[i].data.array.data = get_array_data(h); // Build the shape array ocaml_shape = value_get_shape(h); int shape_len = Wosize_val(ocaml_shape); ret.results[i].data.array.shape = (int*)malloc(shape_len * sizeof(int)); ret.results[i].data.array.shape_len = shape_len; for (j = 0; j < shape_len; ++j) { ret.results[i].data.array.shape[j] = Int_val(Field(ocaml_shape, j)); } // Build the strides array ocaml_strides = value_get_strides(h); int strides_len = Wosize_val(ocaml_strides); ret.results[i].data.array.strides_len = strides_len; ret.results[i].data.array.strides = (int*)malloc(strides_len * sizeof(int)); for (j = 0; j < strides_len; ++j) { ret.results[i].data.array.strides[j] = Int_val(Field(ocaml_strides, j)); } } } } CAMLreturnT(return_val_t, ret); }
int main(int argc, char** argv) { Options options; if (!parseCommandLine(argc, argv, options)) { return 1; } std::cout << "-- Reading pattern from file: " << options.pattern << std::endl; Pattern pat; std::ifstream f(options.pattern); if (!f) { std::cout << "-- Error: Cannot open " << options.pattern << std::endl; return 1; } try { pat.load(f); } catch (std::exception& e) { std::cout << "-- Error: " << e.what() << std::endl; return 1; } SatSolver s; std::cout << "-- Building formula for " << options.evolutions << " evolution steps..." << std::endl; std::vector<Field> fields; for (int g = 0; g <= options.evolutions; ++g) { fields.push_back(Field(s, pat.width(), pat.height())); if (g > 0) { transition(s, fields[g-1], fields[g]); } } if (options.backwards) { std::cout << "-- Setting pattern constraint on last generation..." << std::endl; patternConstraint(s, fields.back(), pat); } else { std::cout << "-- Setting pattern constraint on first generation..." << std::endl; patternConstraint(s, fields.front(), pat); } std::cout << "-- Solving formula..." << std::endl; if (!s.solve()) { std::cout << "-- Formula is not solvable. The selected pattern is probably too restrictive!" << std::endl; return 1; } std::cout << std::endl; for (int g = 0; g <= options.evolutions; ++g) { if (options.backwards) { if (g == 0) { std::cout << "-- Initial generation:" << std::endl; } else if (g == options.evolutions) { std::cout << "-- Evolves to final generation (from pattern):" << std::endl; } else { std::cout << "-- Evolves to:" << std::endl; } } else { if (g == 0) { std::cout << "-- Initial generation (from pattern):" << std::endl; } else if (g == options.evolutions) { std::cout << "-- Evolves to final generation:" << std::endl; } else { std::cout << "-- Evolves to:" << std::endl; } } fields[g].print(std::cout, s); std::cout << std::endl; } return 0; }
value xdiff_revpatch( value old_data, value patch) { CAMLparam2 (old_data, patch); CAMLlocal1(res); mmfile_t mf1, mf2, mf3, mf4; xdemitcb_t ecb, rjecb; long new_size, rej_size; res = alloc_tuple(2); if (xdlt_store_mmfile(String_val(old_data), string_length(old_data), &mf1) < 0) { sprintf(ELINE, "%s:%d failed", __FILE__, __LINE__); failwith(ELINE); } if (xdlt_store_mmfile(String_val(patch), string_length(patch), &mf2) < 0) { xdl_free_mmfile(&mf1); sprintf(ELINE, "%s:%d failed", __FILE__, __LINE__); failwith(ELINE); } if (xdl_init_mmfile(&mf3, XDLT_STD_BLKSIZE, XDL_MMF_ATOMIC) < 0) { xdl_free_mmfile(&mf1); xdl_free_mmfile(&mf2); sprintf(ELINE, "%s:%d failed", __FILE__, __LINE__); failwith(ELINE); } if (xdl_init_mmfile(&mf4, XDLT_STD_BLKSIZE, XDL_MMF_ATOMIC) < 0) { xdl_free_mmfile(&mf1); xdl_free_mmfile(&mf2); xdl_free_mmfile(&mf3); sprintf(ELINE, "%s:%d failed", __FILE__, __LINE__); failwith(ELINE); } ecb.priv = &mf3; ecb.outf = xdlt_outf; rjecb.priv = &mf4; rjecb.outf = xdlt_outf; if (xdl_patch(&mf1, &mf2, XDL_PATCH_REVERSE, &ecb, &rjecb) < 0) { xdl_free_mmfile(&mf1); xdl_free_mmfile(&mf2); xdl_free_mmfile(&mf3); xdl_free_mmfile(&mf4); sprintf(ELINE, "%s:%d failed", __FILE__, __LINE__); failwith(ELINE); } new_size = xdlt_mmfile_size(&mf3); rej_size = xdlt_mmfile_size(&mf4); Field(res, 0) = alloc_string(new_size); Field(res, 1) = alloc_string(rej_size); if (xdlt_read_mmfile(String_val(Field(res, 0)), &mf3) < 0) { xdl_free_mmfile(&mf1); xdl_free_mmfile(&mf2); xdl_free_mmfile(&mf3); xdl_free_mmfile(&mf4); sprintf(ELINE, "%s:%d failed", __FILE__, __LINE__); failwith(ELINE); } if (xdlt_read_mmfile(String_val(Field(res, 1)), &mf4) < 0) { xdl_free_mmfile(&mf1); xdl_free_mmfile(&mf2); xdl_free_mmfile(&mf3); xdl_free_mmfile(&mf4); sprintf(ELINE, "%s:%d failed", __FILE__, __LINE__); failwith(ELINE); } xdl_free_mmfile(&mf1); xdl_free_mmfile(&mf2); xdl_free_mmfile(&mf3); xdl_free_mmfile(&mf4); CAMLreturn(res); }
value gc_stat (value v) /* ML */ { value res; long live_words = 0, live_blocks = 0, free_words = 0, free_blocks = 0, largest_free = 0, fragments = 0, heap_chunks = 0; char *chunk = heap_start, *chunk_end; char *cur_hp, *prev_hp; header_t cur_hd; Assert (v == Atom (0)); while (chunk != NULL){ ++ heap_chunks; chunk_end = chunk + Chunk_size (chunk); prev_hp = NULL; cur_hp = chunk; while (cur_hp < chunk_end){ cur_hd = Hd_hp (cur_hp); switch (Color_hd (cur_hd)){ case White: if (Wosize_hd (cur_hd) == 0){ ++fragments; Assert (prev_hp == NULL || (Color_hp (prev_hp) != Blue && Wosize_hp (prev_hp) > 0)); Assert (Next (cur_hp) == chunk_end || (Color_hp (Next (cur_hp)) != Blue && Wosize_hp (Next (cur_hp)) > 0)); break; } /* FALLTHROUGH */ case Gray: case Black: Assert (Wosize_hd (cur_hd) > 0); ++ live_blocks; live_words += Whsize_hd (cur_hd); break; case Blue: Assert (Wosize_hd (cur_hd) > 0); ++ free_blocks; free_words += Whsize_hd (cur_hd); if (Whsize_hd (cur_hd) > largest_free){ largest_free = Whsize_hd (cur_hd); } Assert (prev_hp == NULL || (Color_hp (prev_hp) != Blue && Wosize_hp (prev_hp) > 0)); Assert (Next (cur_hp) == chunk_end || (Color_hp (Next (cur_hp)) != Blue && Wosize_hp (Next (cur_hp)) > 0)); break; } prev_hp = cur_hp; cur_hp = Next (cur_hp); } Assert (cur_hp == chunk_end); chunk = Chunk_next (chunk); } Assert (live_words + free_words + fragments == Wsize_bsize (stat_heap_size)); /* Order of elements changed for Moscow ML */ res = alloc (13, 0); Field (res, 11) = Val_long (stat_minor_words + Wsize_bsize (young_ptr - young_start)); Field (res, 12) = Val_long (stat_promoted_words); Field (res, 9) = Val_long (stat_major_words + allocated_words); Field (res, 10) = Val_long (stat_minor_collections); Field (res, 8) = Val_long (stat_major_collections); Field (res, 4) = Val_long (Wsize_bsize (stat_heap_size)); Field (res, 3) = Val_long (heap_chunks); Field (res, 7) = Val_long (live_words); Field (res, 6) = Val_long (live_blocks); Field (res, 2) = Val_long (free_words); Field (res, 1) = Val_long (free_blocks); Field (res, 5) = Val_long (largest_free); Field (res, 0) = Val_long (fragments); return res; }
/** ** Select units in rectangle range. ** ** @param ltpos Left Top position of selection rectangle ** @param rbpos Right Bottom position of selection rectangle ** @param table All units in the selection rectangle ** @param tablesize Size of table array ** ** @return Returns the number of units found */ int CMap::SelectFixed(const Vec2i <pos, const Vec2i &rbpos, CUnit *table[], const int tablesize) { Assert(Info.IsPointOnMap(ltpos)); Assert(Info.IsPointOnMap(rbpos)); // Optimize small searches. if (ltpos == rbpos) { return Select(ltpos, table, tablesize); } int i; int n = 0; CUnit *unit; unsigned int index = getIndex(ltpos); int j = rbpos.y - ltpos.y + 1; do { const CMapField *mf = Field(index); i = rbpos.x - ltpos.x + 1; do { #if __GNUC__ > 3 //GCC version only, since std::vector::data() is not in STL size_t count = mf->UnitCache.size(); if (count) { CUnit **cache = (CUnit **)mf->UnitCache.Units.data(); do { unit = *cache; // // To avoid getting a unit in multiple times we use a cache lock. // It should only be used in here, unless you somehow want the unit // to be out of cache. // if (!unit->CacheLock && !unit->Type->Revealer) { Assert(!unit->Removed); unit->CacheLock = 1; table[n++] = unit; } ++cache; } while(--count && n < tablesize); } #else const size_t count = mf->UnitCache.size(); if (count) { unsigned int k = 0; const CUnitCache &cache = mf->UnitCache; do { unit = cache[k]; // // To avoid getting a unit in multiple times we use a cache lock. // It should only be used in here, unless you somehow want the unit // to be out of cache. // if (!unit->CacheLock && !unit->Type->Revealer) { Assert(!unit->Removed); unit->CacheLock = 1; table[n++] = unit; } } while(++k < count && n < tablesize); } #endif ++mf; } while(--i && n < tablesize); index += Info.MapWidth; } while(--j && n < tablesize); if (!n) return 0; // // Clean the cache locks, restore to original situation. // #ifndef __GNUG__ for (i = 0; i < n; ++i) { table[i]->CacheLock = 0; } #else i = 0; j = (n+3)/4; switch (n & 3) { case 0: do { table[i++]->CacheLock = 0; case 3: table[i++]->CacheLock = 0; case 2: table[i++]->CacheLock = 0; case 1: table[i++]->CacheLock = 0; } while ( --j > 0 ); } #endif return n; }
CAMLprim value caml_extunix_recvmsg2(value vfd, value vbuf, value ofs, value vlen, value vflags) { CAMLparam4(vfd, vbuf, ofs, vlen); CAMLlocal5(vres, vlist, v, vx, vsaddr); union { struct cmsghdr hdr; char buf[CMSG_SPACE(sizeof(int)) /* File descriptor passing */ #ifdef EXTUNIX_HAVE_IP_RECVIF + CMSG_SPACE(sizeof(struct sockaddr_dl)) /* IP_RECVIF */ #endif #ifdef EXTUNIX_HAVE_IP_RECVDSTADDR + CMSG_SPACE(sizeof(struct in_addr)) /* IP_RECVDSTADDR */ #endif ]; } cmsgbuf; struct iovec iov; struct msghdr msg; struct cmsghdr *cmsg; ssize_t n; size_t len; char iobuf[UNIX_BUFFER_SIZE]; struct sockaddr_storage ss; int sendflags; #ifdef EXTUNIX_HAVE_IP_RECVIF struct sockaddr_dl *dst = NULL; #endif len = Long_val(vlen); memset(&iov, 0, sizeof(iov)); memset(&msg, 0, sizeof(msg)); if (len > UNIX_BUFFER_SIZE) len = UNIX_BUFFER_SIZE; iov.iov_base = iobuf; iov.iov_len = len; msg.msg_name = &ss; msg.msg_namelen = sizeof(ss); msg.msg_iov = &iov; msg.msg_iovlen = 1; msg.msg_control = &cmsgbuf.buf; msg.msg_controllen = sizeof(cmsgbuf.buf); sendflags = caml_convert_flag_list(vflags, msg_flag_table); caml_enter_blocking_section(); n = recvmsg(Int_val(vfd), &msg, sendflags); caml_leave_blocking_section(); vres = caml_alloc_small(4, 0); if (n == -1) { uerror("recvmsg", Nothing); CAMLreturn (vres); } vsaddr = my_alloc_sockaddr(&ss); memmove(&Byte(vbuf, Long_val(ofs)), iobuf, n); vlist = Val_int(0); /* Build the variant list vlist */ for (cmsg = CMSG_FIRSTHDR(&msg); cmsg != NULL; cmsg = CMSG_NXTHDR(&msg, cmsg)) { if (cmsg->cmsg_level == SOL_SOCKET && cmsg->cmsg_type == SCM_RIGHTS) { /* CMSG_DATA is aligned, so the following is cool */ v = caml_alloc_small(2, TAG_FILEDESCRIPTOR); Field(v, 0) = Val_int(*(int *)CMSG_DATA(cmsg)); Field(v, 1) = vlist; vlist = v; continue; } #ifdef EXTUNIX_HAVE_IP_RECVIF if (cmsg->cmsg_level == IPPROTO_IP && cmsg->cmsg_type == IP_RECVIF) { dst = (struct sockaddr_dl *)CMSG_DATA(cmsg); v = caml_alloc_small(2, 0); vx = caml_alloc_small(1, TAG_IP_RECVIF); Field(vx, 0) = Val_int(dst->sdl_index); Field(v, 0) = vx; Field(v, 1) = vlist; vlist = v; continue; } #endif #ifdef EXTUNIX_HAVE_IP_RECVDSTADDR if (cmsg->cmsg_level == IPPROTO_IP && cmsg->cmsg_type == IP_RECVDSTADDR) { struct in_addr ipdst; ipdst = *(struct in_addr *)CMSG_DATA(cmsg); v = caml_alloc_small(2, 0); vx = caml_alloc_small(1, TAG_IP_RECVDSTADDR); Field(vx, 0) = caml_alloc_string(4); memcpy(String_val(Field(vx, 0)), &ipdst, 4); Field(v, 0) = vx; Field(v, 1) = vlist; vlist = v; continue; } #endif } /* Now build the result */ Field(vres, 0) = Val_long(n); Field(vres, 1) = vsaddr; Field(vres, 2) = vlist; Field(vres, 3) = int_to_recvflags(msg.msg_flags); CAMLreturn(vres); }
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); }
static void do_compaction_r (CAML_R) { char *ch, *chend; Assert (caml_gc_phase == Phase_idle); caml_gc_message (0x10, "Compacting heap...\n", 0); #ifdef DEBUG caml_heap_check_r (ctx); #endif /* First pass: encode all noninfix headers. */ { ch = caml_heap_start; while (ch != NULL){ header_t *p = (header_t *) ch; chend = ch + Chunk_size (ch); while ((char *) p < chend){ header_t hd = Hd_hp (p); mlsize_t sz = Wosize_hd (hd); if (Is_blue_hd (hd)){ /* Free object. Give it a string tag. */ Hd_hp (p) = Make_ehd (sz, String_tag, 3); }else{ Assert (Is_white_hd (hd)); /* Live object. Keep its tag. */ Hd_hp (p) = Make_ehd (sz, Tag_hd (hd), 3); } p += Whsize_wosize (sz); } ch = Chunk_next (ch); } } /* Second pass: invert pointers. Link infix headers in each block in an inverted list of inverted lists. Don't forget roots and weak pointers. */ { /* Invert roots first because the threads library needs some heap data structures to find its roots. Fortunately, it doesn't need the headers (see above). */ caml_do_roots_r (ctx, invert_root_r); caml_final_do_weak_roots_r (ctx, invert_root_r); ch = caml_heap_start; while (ch != NULL){ word *p = (word *) ch; chend = ch + Chunk_size (ch); while ((char *) p < chend){ word q = *p; size_t sz, i; tag_t t; word *infixes; while (Ecolor (q) == 0) q = * (word *) q; sz = Whsize_ehd (q); t = Tag_ehd (q); if (t == Infix_tag){ /* Get the original header of this block. */ infixes = p + sz; q = *infixes; while (Ecolor (q) != 3) q = * (word *) (q & ~(uintnat)3); sz = Whsize_ehd (q); t = Tag_ehd (q); } if (t < No_scan_tag){ for (i = 1; i < sz; i++) invert_pointer_at_r (ctx, &(p[i])); } p += sz; } ch = Chunk_next (ch); } /* Invert weak pointers. */ { value *pp = &caml_weak_list_head; value p; word q; size_t sz, i; while (1){ p = *pp; if (p == (value) NULL) break; q = Hd_val (p); while (Ecolor (q) == 0) q = * (word *) q; sz = Wosize_ehd (q); for (i = 1; i < sz; i++){ if (Field (p,i) != caml_weak_none){ invert_pointer_at_r (ctx, (word *) &(Field (p,i))); } } invert_pointer_at_r (ctx, (word *) pp); pp = &Field (p, 0); } } } /* Third pass: reallocate virtually; revert pointers; decode headers. Rebuild infix headers. */ { init_compact_allocate_r (ctx); ch = caml_heap_start; while (ch != NULL){ word *p = (word *) ch; chend = ch + Chunk_size (ch); while ((char *) p < chend){ word q = *p; if (Ecolor (q) == 0 || Tag_ehd (q) == Infix_tag){ /* There were (normal or infix) pointers to this block. */ size_t sz; tag_t t; char *newadr; word *infixes = NULL; while (Ecolor (q) == 0) q = * (word *) q; sz = Whsize_ehd (q); t = Tag_ehd (q); if (t == Infix_tag){ /* Get the original header of this block. */ infixes = p + sz; q = *infixes; Assert (Ecolor (q) == 2); while (Ecolor (q) != 3) q = * (word *) (q & ~(uintnat)3); sz = Whsize_ehd (q); t = Tag_ehd (q); } newadr = compact_allocate_r (ctx, Bsize_wsize (sz)); q = *p; while (Ecolor (q) == 0){ word next = * (word *) q; * (word *) q = (word) Val_hp (newadr); q = next; } *p = Make_header (Wosize_whsize (sz), t, Caml_white); if (infixes != NULL){ /* Rebuild the infix headers and revert the infix pointers. */ while (Ecolor ((word) infixes) != 3){ infixes = (word *) ((word) infixes & ~(uintnat) 3); q = *infixes; while (Ecolor (q) == 2){ word next; q = (word) q & ~(uintnat) 3; next = * (word *) q; * (word *) q = (word) Val_hp ((word *) newadr + (infixes - p)); q = next; } Assert (Ecolor (q) == 1 || Ecolor (q) == 3); *infixes = Make_header (infixes - p, Infix_tag, Caml_white); infixes = (word *) q; } } p += sz; }else{ Assert (Ecolor (q) == 3); /* This is guaranteed only if caml_compact_heap was called after a nonincremental major GC: Assert (Tag_ehd (q) == String_tag); */ /* No pointers to the header and no infix header: the object was free. */ *p = Make_header (Wosize_ehd (q), Tag_ehd (q), Caml_blue); p += Whsize_ehd (q); } } ch = Chunk_next (ch); } } /* Fourth pass: reallocate and move objects. Use the exact same allocation algorithm as pass 3. */ { init_compact_allocate_r (ctx); ch = caml_heap_start; while (ch != NULL){ word *p = (word *) ch; chend = ch + Chunk_size (ch); while ((char *) p < chend){ word q = *p; if (Color_hd (q) == Caml_white){ size_t sz = Bhsize_hd (q); char *newadr = compact_allocate_r (ctx, sz); memmove (newadr, p, sz); p += Wsize_bsize (sz); }else{ Assert (Color_hd (q) == Caml_blue); p += Whsize_hd (q); } } ch = Chunk_next (ch); } } /* Shrink the heap if needed. */ { /* Find the amount of live data and the unshrinkable free space. */ asize_t live = 0; asize_t free = 0; asize_t wanted; ch = caml_heap_start; while (ch != NULL){ if (Chunk_alloc (ch) != 0){ live += Wsize_bsize (Chunk_alloc (ch)); free += Wsize_bsize (Chunk_size (ch) - Chunk_alloc (ch)); } ch = Chunk_next (ch); } /* Add up the empty chunks until there are enough, then remove the other empty chunks. */ wanted = caml_percent_free * (live / 100 + 1); ch = caml_heap_start; while (ch != NULL){ char *next_chunk = Chunk_next (ch); /* Chunk_next (ch) will be erased */ if (Chunk_alloc (ch) == 0){ if (free < wanted){ free += Wsize_bsize (Chunk_size (ch)); }else{ caml_shrink_heap_r (ctx, ch); } } ch = next_chunk; } } /* Rebuild the free list. */ { ch = caml_heap_start; caml_fl_reset_r (ctx); while (ch != NULL){ if (Chunk_size (ch) > Chunk_alloc (ch)){ caml_make_free_blocks_r (ctx, (value *) (ch + Chunk_alloc (ch)), Wsize_bsize (Chunk_size(ch)-Chunk_alloc(ch)), 1, Caml_white); } ch = Chunk_next (ch); } } ++ caml_stat_compactions; caml_gc_message (0x10, "done.\n", 0); }
void caml_oldify_one (value v, value *p) { value result; header_t hd; mlsize_t sz, i; tag_t tag; tail_call: if (Is_block (v) && Is_young (v)){ Assert (Hp_val (v) >= caml_young_ptr); hd = Hd_val (v); if (hd == 0){ /* If already forwarded */ *p = Field (v, 0); /* then forward pointer is first field. */ }else{ tag = Tag_hd (hd); if (tag < Infix_tag){ value field0; sz = Wosize_hd (hd); result = caml_alloc_shr (sz, tag); *p = result; field0 = Field (v, 0); Hd_val (v) = 0; /* Set forward flag */ Field (v, 0) = result; /* and forward pointer. */ if (sz > 1){ Field (result, 0) = field0; Field (result, 1) = oldify_todo_list; /* Add this block */ oldify_todo_list = v; /* to the "to do" list. */ }else{ Assert (sz == 1); p = &Field (result, 0); v = field0; goto tail_call; } }else if (tag >= No_scan_tag){ sz = Wosize_hd (hd); result = caml_alloc_shr (sz, tag); for (i = 0; i < sz; i++) Field (result, i) = Field (v, i); Hd_val (v) = 0; /* Set forward flag */ Field (v, 0) = result; /* and forward pointer. */ *p = result; }else if (tag == Infix_tag){ mlsize_t offset = Infix_offset_hd (hd); caml_oldify_one (v - offset, p); /* Cannot recurse deeper than 1. */ *p += offset; }else{ value f = Forward_val (v); tag_t ft = 0; int vv = 1; Assert (tag == Forward_tag); if (Is_block (f)){ vv = Is_in_value_area(f); if (vv) { ft = Tag_val (Hd_val (f) == 0 ? Field (f, 0) : f); } } if (!vv || ft == Forward_tag || ft == Lazy_tag || ft == Double_tag){ /* Do not short-circuit the pointer. Copy as a normal block. */ Assert (Wosize_hd (hd) == 1); result = caml_alloc_shr (1, Forward_tag); *p = result; Hd_val (v) = 0; /* Set (GC) forward flag */ Field (v, 0) = result; /* and forward pointer. */ p = &Field (result, 0); v = f; goto tail_call; }else{ v = f; /* Follow the forwarding */ goto tail_call; /* then oldify. */ } } } }else{ *p = v; } }
value pgresult_alloc(PGresult* pgres) { value res = alloc_final(2, &pgresult_finalize, 1, 10000); initialize(&Field(res, 1), (value)pgres); return res; }
" to call ensure_stack_space?"); myassert(0); #if 0 /* Old way, pre 3.11: */ print_gl_stack("Reallocating OCaml stack!"); caml_realloc_stack(Stack_threshold / sizeof(value)); */ return push_stack_fragment(ekfragment); /* Redo */ #endif } new_sp = caml_extern_sp - size; new_trapsp = caml_trapsp - size; memmove(new_sp, caml_extern_sp, (caml_trapsp - caml_extern_sp) * sizeof(value)); memcpy(new_trapsp, &Field(ekfragment,0), size * sizeof(value)); /* adjust the links of exc frames (convert to abs addresses) and connect the copied frames to the existing frames */ for (p = new_trapsp; (value)Trap_link(p) != Val_long(0); p = Trap_link(p)) { myassert( p < caml_stack_high ); Trap_link(p) = new_trapsp + Long_val((value) Trap_link(p)); } Trap_link(p) = caml_trapsp; caml_extern_sp = new_sp; caml_trapsp = new_trapsp; /* print_exc_trace("push_stack_fragment: after"); */
static int shrink_block(value64 * source, value * dest, mlsize_t source_len, mlsize_t dest_len, color_t color) { value64 * p, * q; value * d, * e; header_t hd; mlsize_t sz; tag_t tag; byteoffset_t * forward_addr; byteoffset_t dest_ofs; value v; /* First pass: copy the objects and set up forwarding pointers. The pointers contained inside blocks are not resolved. */ for (p = source, q = source + source_len, d = dest; p < q; /*nothing*/) { hd = (header_t)(p->lsw); p++; sz = Wosize_hd(hd); tag = Tag_hd(hd); forward_addr = (byteoffset_t *) p; dest_ofs = d + 1 - dest; switch(tag) { case String_tag: { mlsize_t ofs_last_byte, len, new_sz; ofs_last_byte = sz * sizeof(value64) - 1; len = ofs_last_byte - Byte(p, ofs_last_byte); new_sz = (len + sizeof(value)) / sizeof(value); *d++ = Make_header(new_sz, String_tag, color); Field(d, new_sz - 1) = 0; bcopy(p, d, len); ofs_last_byte = new_sz * sizeof(value) - 1; Byte(d, ofs_last_byte) = ofs_last_byte - len; p += sz; d += new_sz; break; } case Double_tag: *d++ = Make_header(Double_wosize, Double_tag, color); Store_double_val((value)d, Double_val((value)p)); p += sizeof(double) / sizeof(value64); d += sizeof(double) / sizeof(value); break; default: *d++ = Make_header(sz, tag, color); for (/*nothing*/; sz > 0; sz--, p++, d++) { value lsw = p->lsw; value msw = p->msw; if ((lsw & 1) == 0) { /* If relative displacement: */ if (msw != 0) return -1; /* Check unsigned displacement fits in 32 */ } else { /* Otherwise, it's a signed integer */ if ((lsw >= 0 && msw != 0) || (lsw < 0 && msw != -1)) return -1; } *d = lsw; } } *forward_addr = dest_ofs; /* store the forwarding pointer */ } assert(d == dest + dest_len); /* Second pass: resolve pointers contained inside blocks, replacing them by the corresponding forwarding pointer. */ for (d = dest, e = dest + dest_len; d < e; /*nothing*/) { hd = (header_t) *d++; sz = Wosize_hd(hd); tag = Tag_hd(hd); if (tag >= No_scan_tag) { d += sz; } else { for (/*nothing*/; sz > 0; sz--, d++) { v = *d; switch(v & 3) { case 0: /* 0: a block represented by its offset */ assert(v >= 0 && v < source_len * sizeof(value64) && (v & 7) == 0); *d = (value) (dest + *((byteoffset_t *)((char *) source + v))); break; case 2: /* 2: an atom */ v = v >> 2; assert(v >= 0 && v < 256); *d = Atom(v); break; default: /* 1 or 3: an integer */ break; } } } } return 0; }
value pop_stack_fragment(value vek1, value vek2) { const ptrdiff_t ek1 = Long_val(vek1); const ptrdiff_t ek2 = Long_val(vek2); value * const tp1 = caml_stack_high - ek1; value * const tp2 = caml_stack_high - ek2; value *p, *q; mlsize_t size, i; value block; myassert(tp2 < tp1); /* stack grows downwards */ size = tp1 - tp2; /* tp2 is more recent ptr */ /* print_gl_stack("pop_stack_fragment"); fprintf(stderr, "between %p and %p (size %ld)\n",tp2,tp1,size); print_exc_trace("pop_stack_fragment: before"); */ if (size < Max_young_wosize) { block = alloc(size, 0); memcpy(&Field(block, 0), tp2, size * sizeof(value)); } else { block = alloc_shr(size, 0); for (i = 0; i < size; i++) initialize(&Field(block, i), tp2[i]); } /* We check the invariants after the allocation of block, which may cause a GC run. Stack should not be moved though. */ myassert(caml_extern_sp >= caml_stack_low); myassert(caml_extern_sp <= caml_stack_high); myassert(caml_trapsp < caml_stack_high); myassert(tp1 < caml_stack_high); myassert(caml_trapsp == tp2); myassert(caml_extern_sp < tp2); /* Check the invariant that tp1 must occur somewhere in the Trap_link chain */ for(p=caml_trapsp; p == tp1; p = Trap_link(p)) if( !(p < caml_stack_high) ) { print_gl_stack("ERROR: tp1 is not found in the Trap_link chain!!!"); print_exc_trace("ERROR: tp1 is not found..."); myassert(0); } /* Adjust the links in the copied code: make them relative to tp2: the bottom of the copied stack */ p = tp2; while (1) { myassert( p < caml_stack_high ); q = Trap_link(p); if (q == tp1) { /* end of the chain */ Field(block, (value*)(&(Trap_link(p))) - tp2) = Val_long(0); break; } Field(block, (value*)(&(Trap_link(p))) - tp2) = Val_long(q - tp2); p = q; } caml_trapsp = tp1; /* Reset the chain */ return block; }
CAMLexport void caml_raise_sys_error(value msg) { caml_raise_with_arg(Field(caml_global_data, SYS_ERROR_EXN), msg); }
BE::Contacts::Contacts(Gui::AbookAddressbook *abook): m_abook(abook), m_dirty(false) { m_currentContact = 0; QImage img(QDir::homePath() + "/.abook/incognito.png"); if (!img.isNull()) m_incognitoPic = QPixmap::fromImage(img.scaled(160,160,Qt::KeepAspectRatio,Qt::SmoothTransformation)); m_ui = new Ui::Contacts; m_ui->setupUi(this); #if QT_VERSION >= 0x040700 m_ui->filter->setPlaceholderText(tr("Filter")); #endif m_ui2 = new Ui::OneContact; m_ui2->setupUi(m_ui->oneContact); fields << Field(Gui::AbookAddressbook::Name, m_ui2->name, "name") << Field(Gui::AbookAddressbook::Mail, m_ui2->mail, "email") << Field(Gui::AbookAddressbook::Address, m_ui2->address, "address") << Field(Gui::AbookAddressbook::City, m_ui2->city, "city") << Field(Gui::AbookAddressbook::State, m_ui2->state, "state") << Field(Gui::AbookAddressbook::ZIP, m_ui2->zip, "zip") << Field(Gui::AbookAddressbook::Country, m_ui2->country, "country") << Field(Gui::AbookAddressbook::Phone, m_ui2->phone, "phone") << Field(Gui::AbookAddressbook::Workphone, m_ui2->workphone, "workphone") << Field(Gui::AbookAddressbook::Fax, m_ui2->fax, "fax") << Field(Gui::AbookAddressbook::Mobile, m_ui2->mobile, "mobile") << Field(Gui::AbookAddressbook::Nick, m_ui2->nick, "nick") << Field(Gui::AbookAddressbook::URL, m_ui2->url, "url") << Field(Gui::AbookAddressbook::Notes, m_ui2->notes, "notes") << Field(Gui::AbookAddressbook::Anniversary, m_ui2->anniversary, "anniversary") << Field(Gui::AbookAddressbook::Photo, m_ui2->photo, "photo"); m_sortFilterProxy = new QSortFilterProxyModel(this); m_sortFilterProxy->setFilterCaseSensitivity(Qt::CaseInsensitive); m_sortFilterProxy->setFilterKeyColumn(-1); m_sortFilterProxy->setSourceModel(m_abook->model()); connect (m_ui->filter, SIGNAL(textChanged(QString)), m_sortFilterProxy, SLOT(setFilterWildcard(QString))); m_ui->filter->installEventFilter(this); QFont fnt = m_ui2->name->font(); fnt.setPointSize(fnt.pointSize()*2); m_ui2->name->setFont(fnt); for (QList<Field>::const_iterator it = fields.constBegin(), end = fields.constEnd(); it != end; ++it) { it->label->installEventFilter(this); } m_ui->contacts->setModel(m_sortFilterProxy); m_ui->contacts->setSelectionMode(QAbstractItemView::SingleSelection); connect (m_ui->contacts->selectionModel(), SIGNAL(currentChanged(QModelIndex,QModelIndex)), SLOT(setContact(QModelIndex))); QModelIndex idx = m_sortFilterProxy->index(0,0); if (idx.isValid()) m_ui->contacts->setCurrentIndex(idx); m_ui->contacts->installEventFilter(this); connect (m_ui->add, SIGNAL(clicked()), SLOT(addContact())); connect (m_ui->remove, SIGNAL(clicked()), SLOT(removeCurrentContact())); connect (qApp, SIGNAL(focusChanged(QWidget*, QWidget*)), SLOT(updateFocusPolicy(QWidget*, QWidget*))); // cheat to correct the focuspolicies ;-) updateFocusPolicy(m_ui2->name, m_ui->filter); }
CAMLexport void caml_raise_zero_divide(void) { caml_raise_constant(Field(caml_global_data, ZERO_DIVIDE_EXN)); }
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_young(v) || Is_in_heap(v) || Is_atom(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_young (f) || Is_in_heap (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; } } }
CAMLexport void caml_raise_sys_blocked_io(void) { caml_raise_constant(Field(caml_global_data, SYS_BLOCKED_IO)); }
CAMLprim value unix_error_message(value err) { int errnum; errnum = Is_block(err) ? Int_val(Field(err, 0)) : error_table[Int_val(err)]; return copy_string(strerror(errnum)); }
CAMLexport void caml_failwith (char const *msg) { caml_raise_with_string(Field(caml_global_data, FAILURE_EXN), msg); }
CAMLprim value mmdb_ml_lookup_path(value ip, value query_list, value mmdb) { CAMLparam3(ip, query_list, mmdb); CAMLlocal3(iter_count, caml_clean_result, query_r); int total_len = 0, copy_count = 0, gai_error = 0, mmdb_error = 0; char *clean_result; long int int_result; iter_count = query_list; unsigned int len = caml_string_length(ip); char *as_string = caml_strdup(String_val(ip)); if (strlen(as_string) != (size_t)len) { caml_failwith("Could not copy IP address properly"); } MMDB_s *as_mmdb = (MMDB_s*)Data_custom_val(mmdb); MMDB_lookup_result_s *result = caml_stat_alloc(sizeof(*result)); *result = MMDB_lookup_string(as_mmdb, as_string, &gai_error, &mmdb_error); check_error(gai_error, mmdb_error); caml_stat_free(as_string); while (iter_count != Val_emptylist) { total_len++; iter_count = Field(iter_count, 1); } char **query = caml_stat_alloc(sizeof(char *) * (total_len + 1)); while (query_list != Val_emptylist) { query[copy_count] = caml_strdup(String_val(Field(query_list, 0))); copy_count++; query_list = Field(query_list, 1); } query[total_len] = NULL; MMDB_entry_data_s entry_data; int status = MMDB_aget_value(&result->entry, &entry_data, (const char *const *const)query); check_status(status); check_data(entry_data); caml_stat_free(result); for (int i = 0; i < copy_count; caml_stat_free(query[i]), i++); caml_stat_free(query); query_r = caml_alloc(2, 0); as_mmdb = NULL; switch (entry_data.type) { case MMDB_DATA_TYPE_BYTES: clean_result = caml_stat_alloc(entry_data.data_size + 1); memcpy(clean_result, entry_data.bytes, entry_data.data_size); caml_clean_result = caml_copy_string(clean_result); caml_stat_free(clean_result); goto string_finish; case MMDB_DATA_TYPE_UTF8_STRING: clean_result = strndup(entry_data.utf8_string, entry_data.data_size); caml_clean_result = caml_copy_string(clean_result); free(clean_result); goto string_finish; case MMDB_DATA_TYPE_FLOAT: Store_field(query_r, 0, polymorphic_variants.poly_float); Store_field(query_r, 1, caml_copy_double(entry_data.float_value)); goto finish; case MMDB_DATA_TYPE_BOOLEAN: Store_field(query_r, 0, polymorphic_variants.poly_bool); Store_field(query_r, 1, Val_true ? entry_data.boolean : Val_false); goto finish; case MMDB_DATA_TYPE_DOUBLE: Store_field(query_r, 0, polymorphic_variants.poly_float); Store_field(query_r, 1, caml_copy_double(entry_data.double_value)); goto finish; case MMDB_DATA_TYPE_UINT16: Store_field(query_r, 0, polymorphic_variants.poly_int); int_result = Val_long(entry_data.uint16); goto int_finish; case MMDB_DATA_TYPE_UINT32: Store_field(query_r, 0, polymorphic_variants.poly_int); int_result = Val_long(entry_data.uint32); goto int_finish; case MMDB_DATA_TYPE_UINT64: Store_field(query_r, 0, polymorphic_variants.poly_int); int_result = Val_long(entry_data.uint32); goto int_finish; // look at /usr/bin/sed -n 1380,1430p src/maxminddb.c case MMDB_DATA_TYPE_ARRAY: case MMDB_DATA_TYPE_MAP: caml_failwith("Can't return a Map or Array yet"); } string_finish: Store_field(query_r, 0, polymorphic_variants.poly_string); Store_field(query_r, 1, caml_clean_result); CAMLreturn(query_r); int_finish: Store_field(query_r, 1, int_result); CAMLreturn(query_r); finish: CAMLreturn(query_r); }