value setRightLife(val) { fi.rightLife = Int_val(val); return Val_unit; }
CAMLprim value caml_sys_close(value fd) { close(Int_val(fd)); return Val_unit; }
CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout, value vshared, value vdim, value vstart) { HANDLE fd, fmap; int flags, major_dim, mode, perm; intnat num_dims, i; intnat dim[CAML_BA_MAX_NUM_DIMS]; __int64 currpos, startpos, file_size, data_size; uintnat array_size, page, delta; char c; void * addr; LARGE_INTEGER li; SYSTEM_INFO sysinfo; fd = Handle_val(vfd); flags = Int_val(vkind) | Int_val(vlayout); startpos = Int64_val(vstart); num_dims = Wosize_val(vdim); major_dim = flags & CAML_BA_FORTRAN_LAYOUT ? num_dims - 1 : 0; /* Extract dimensions from OCaml array */ num_dims = Wosize_val(vdim); if (num_dims < 1 || num_dims > CAML_BA_MAX_NUM_DIMS) caml_invalid_argument("Bigarray.mmap: bad number of dimensions"); for (i = 0; i < num_dims; i++) { dim[i] = Long_val(Field(vdim, i)); if (dim[i] == -1 && i == major_dim) continue; if (dim[i] < 0) caml_invalid_argument("Bigarray.create: negative dimension"); } /* Determine file size */ currpos = caml_ba_set_file_pointer(fd, 0, FILE_CURRENT); if (currpos == -1) caml_ba_sys_error(); file_size = caml_ba_set_file_pointer(fd, 0, FILE_END); if (file_size == -1) caml_ba_sys_error(); /* Determine array size in bytes (or size of array without the major dimension if that dimension wasn't specified) */ array_size = caml_ba_element_size[flags & CAML_BA_KIND_MASK]; for (i = 0; i < num_dims; i++) if (dim[i] != -1) array_size *= dim[i]; /* Check if the first/last dimension is unknown */ if (dim[major_dim] == -1) { /* Determine first/last dimension from file size */ if (file_size < startpos) caml_failwith("Bigarray.mmap: file position exceeds file size"); data_size = file_size - startpos; dim[major_dim] = (uintnat) (data_size / array_size); array_size = dim[major_dim] * array_size; if (array_size != data_size) caml_failwith("Bigarray.mmap: file size doesn't match array dimensions"); } /* Restore original file position */ caml_ba_set_file_pointer(fd, currpos, FILE_BEGIN); /* Create the file mapping */ if (Bool_val(vshared)) { perm = PAGE_READWRITE; mode = FILE_MAP_WRITE; } else { perm = PAGE_READONLY; /* doesn't work under Win98 */ mode = FILE_MAP_COPY; } li.QuadPart = startpos + array_size; fmap = CreateFileMapping(fd, NULL, perm, li.HighPart, li.LowPart, NULL); if (fmap == NULL) caml_ba_sys_error(); /* Determine offset so that the mapping starts at the given file pos */ GetSystemInfo(&sysinfo); delta = (uintnat) (startpos % sysinfo.dwAllocationGranularity); /* Map the mapping in memory */ li.QuadPart = startpos - delta; addr = MapViewOfFile(fmap, mode, li.HighPart, li.LowPart, array_size + delta); if (addr == NULL) caml_ba_sys_error(); addr = (void *) ((uintnat) addr + delta); /* Close the file mapping */ CloseHandle(fmap); /* Build and return the OCaml bigarray */ return caml_ba_alloc(flags | CAML_BA_MAPPED_FILE, num_dims, addr, dim); }
CAMLprim value uint128_of_int(value v) { CAMLparam1(v); CAMLreturn (copy_uint128((__uint128_t)Int_val(v))); }
/* 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); }
CAMLprim value sys_dlmemcpy( value dst, value src, value len ) { memcpy((char*)dst,(char*)src,Int_val(len)); return Val_unit; }
CAMLprim value caml_nc_xor_into (value b1, value off1, value b2, value off2, value n) { xor_into (_ba_uint8_off (b1, off1), _ba_uint8_off (b2, off2), Int_val (n)); return Val_unit; }
static int t_major_is_valid(value t) { return (Int_val(Field(t, 3)) == caml_stat_compactions); }
static size_t t_major_fill(value t) { return Int_val(Field(t, 4)); }
/* Read an OCaml character out of a raw page, mods offset with PAGE_SIZE */ CAMLprim value caml_page_safe_get(value v_page, value v_off) { int off = Int_val(v_off) % PAGE_SIZE; return Int_val(*((char *)v_page + off)); }
static size_t t_minor_fill(value t) { return Int_val(Field(t, 1)); }
value setRightCreatureLevel(lvl) { fi.rightLevel = Int_val(lvl); return Val_unit; }
value setLeftCreatureLevel(lvl) { fi.leftLevel = Int_val(lvl); return Val_unit; }
value setRightManaMax(val) { fi.rightManaMax = Int_val(val); return Val_unit; }
CAMLprim value sys_dlint( value i ) { return Int_val(i); }
static int t_minor_is_valid(value t) { return (Int_val(Field(t, 0)) == caml_stat_minor_collections); }
CAMLprim value sys_dladdr( value v, value a ) { return (value)((char*)v + Int_val(a)); }
CAMLprim value caml_nice(value val_niceness) { #if defined(WIN32) CAMLparam1(val_niceness); int niceness = Int_val(val_niceness); DWORD priority_class = NORMAL_PRIORITY_CLASS; int thread_priority = THREAD_PRIORITY_NORMAL; /* Simple mapping from Unixy nice values to Windows priority classes */ if(niceness <= -7) { priority_class = HIGH_PRIORITY_CLASS; if(niceness <= -16) thread_priority = THREAD_PRIORITY_HIGHEST; else if(niceness <= -13) thread_priority = THREAD_PRIORITY_ABOVE_NORMAL; else if(niceness <= -10) thread_priority = THREAD_PRIORITY_NORMAL; else thread_priority = THREAD_PRIORITY_BELOW_NORMAL; } else if(niceness <= -1) { priority_class = ABOVE_NORMAL_PRIORITY_CLASS; if(niceness <= -4) thread_priority = THREAD_PRIORITY_ABOVE_NORMAL; else thread_priority = THREAD_PRIORITY_NORMAL; } else if(niceness <= 0) { priority_class = NORMAL_PRIORITY_CLASS; thread_priority = THREAD_PRIORITY_NORMAL; } else if(niceness <= 12) { priority_class = BELOW_NORMAL_PRIORITY_CLASS; if(niceness <= 3) thread_priority = THREAD_PRIORITY_ABOVE_NORMAL; else if(niceness <= 6) thread_priority = THREAD_PRIORITY_NORMAL; else if(niceness <= 9) thread_priority = THREAD_PRIORITY_BELOW_NORMAL; else thread_priority = THREAD_PRIORITY_LOWEST; } else { priority_class = IDLE_PRIORITY_CLASS; if(niceness <= 15) thread_priority = THREAD_PRIORITY_BELOW_NORMAL; else if(niceness <= 18) thread_priority = THREAD_PRIORITY_LOWEST; else thread_priority = THREAD_PRIORITY_IDLE; } if(SetPriorityClass(GetCurrentProcess(), priority_class) == 0) { CAMLreturn(Val_int(0)); } else { if(SetThreadPriority(GetCurrentThread(), thread_priority) == 0) { CAMLreturn(Val_int(0)); } else { CAMLreturn(Val_int(niceness)); } } #else /* Do nothing */ CAMLparam1(val_niceness); CAMLreturn(val_niceness); #endif }
CAMLprim value zlib_deflate_init2(value lvl,value wbits) { value z = zlib_new_stream(); if( deflateInit2(zval(z),Int_val(lvl),Z_DEFLATED,Int_val(wbits),8,Z_DEFAULT_STRATEGY) != Z_OK ) failwith("zlib_deflate_init"); return z; }
/* Llvm.lltype -> int -> DataLayout.t -> Int64.t */ CAMLprim value llvm_datalayout_offset_of_element(LLVMTypeRef Ty, value Index, value DL) { return caml_copy_int64(LLVMOffsetOfElement(DataLayout_val(DL), Ty, Int_val(Index))); }
CAMLprim value uint56_of_int(value v) { CAMLparam1(v); CAMLreturn (copy_uint64(((uint64_t)Int_val(v)) << 8)); }
/* int -> DataLayout.t -> int */ CAMLprim value llvm_datalayout_qualified_pointer_size(value AS, value DL) { return Val_int(LLVMPointerSizeForAS(DataLayout_val(DL), Int_val(AS))); }
CAMLprim value \ FUNCNAME(value caml_socket, value caml_ifname, value caml_val) \ { \ CAMLparam3(caml_socket, caml_ifname, caml_val); \ int socket = Int_val(caml_socket); \ char *ifname = String_val(caml_ifname); \ struct ifreq ifr; \ \ memset(&ifr, 0, sizeof(struct ifreq)); \ copyifname(ifr.ifr_name, ifname); \ SETTER; \ FI(socket, REQUEST, &ifr); \ RESULT(Val_unit, 0); \ } SET_FIELD(SIOCSIFFLAGS, siocsifflags_c, ifr.ifr_flags = Int_val(caml_val)) SET_FIELD(SIOCSIFPFLAGS, siocsifpflags_c, ifr.ifr_flags = Int_val(caml_val)) SET_FIELD(SIOCSIFMTU, siocsifmtu_c, ifr.ifr_mtu = Int_val(caml_val)) SET_FIELD(SIOCSIFTXQLEN, siocsiftxqlen_c, ifr.ifr_qlen = Int_val(caml_val)) SET_FIELD(SIOCSIFNAME, siocsifname_c, copyifname(ifr.ifr_newname, String_val(caml_val))) static void set_hwaddr(struct sockaddr *sa, value hwaddr) { /* quick and dirty checks */ if (caml_string_length(hwaddr) != ETHERNET_MAC_LEN) caml_failwith("Expected 6 byte ethernet MAC"); memcpy(sa->sa_data, String_val(hwaddr), ETHERNET_MAC_LEN); return; }
/* Llvm.llcontext -> int -> DataLayout.t -> Llvm.lltype */ CAMLprim LLVMTypeRef llvm_datalayout_qualified_intptr_type(LLVMContextRef C, value AS, value DL) { return LLVMIntPtrTypeForASInContext(C, DataLayout_val(DL), Int_val(AS)); }
CAMLprim value caml_new_lex_engine(struct lexing_table *tbl, value start_state, struct lexer_buffer *lexbuf) { int state, base, backtrk, c, pstate ; state = Int_val(start_state); if (state >= 0) { /* First entry */ lexbuf->lex_last_pos = lexbuf->lex_start_pos = lexbuf->lex_curr_pos; lexbuf->lex_last_action = Val_int(-1); } else { /* Reentry after refill */ state = -state - 1; } while(1) { /* Lookup base address or action number for current state */ base = Short(tbl->lex_base, state); if (base < 0) { int pc_off = Short(tbl->lex_base_code, state) ; run_tag(Bp_val(tbl->lex_code) + pc_off, lexbuf->lex_mem); /* fprintf(stderr,"Perform: %d\n",-base-1) ; */ return Val_int(-base-1); } /* See if it's a backtrack point */ backtrk = Short(tbl->lex_backtrk, state); if (backtrk >= 0) { int pc_off = Short(tbl->lex_backtrk_code, state); run_tag(Bp_val(tbl->lex_code) + pc_off, lexbuf->lex_mem); lexbuf->lex_last_pos = lexbuf->lex_curr_pos; lexbuf->lex_last_action = Val_int(backtrk); } /* See if we need a refill */ if (lexbuf->lex_curr_pos >= lexbuf->lex_buffer_len){ if (lexbuf->lex_eof_reached == Val_bool (0)){ return Val_int(-state - 1); }else{ c = 256; } }else{ /* Read next input char */ c = Byte_u(lexbuf->lex_buffer, Long_val(lexbuf->lex_curr_pos)); lexbuf->lex_curr_pos += 2; } /* Determine next state */ pstate=state ; if (Short(tbl->lex_check, base + c) == state) state = Short(tbl->lex_trans, base + c); else state = Short(tbl->lex_default, state); /* If no transition on this char, return to last backtrack point */ if (state < 0) { lexbuf->lex_curr_pos = lexbuf->lex_last_pos; if (lexbuf->lex_last_action == Val_int(-1)) { caml_failwith("lexing: empty token"); } else { return lexbuf->lex_last_action; } }else{ /* If some transition, get and perform memory moves */ int base_code = Short(tbl->lex_base_code, pstate) ; int pc_off ; if (Short(tbl->lex_check_code, base_code + c) == pstate) pc_off = Short(tbl->lex_trans_code, base_code + c) ; else pc_off = Short(tbl->lex_default_code, pstate) ; if (pc_off > 0) run_mem(Bp_val(tbl->lex_code) + pc_off, lexbuf->lex_mem, lexbuf->lex_curr_pos) ; /* Erase the EOF condition only if the EOF pseudo-character was consumed by the automaton (i.e. there was no backtrack above) */ if (c == 256) lexbuf->lex_eof_reached = Val_bool (0); } } }
CAMLprim value zlib_inflate_init(value wbits) { value z = zlib_new_stream(); if( inflateInit2(zval(z),Int_val(wbits)) != Z_OK ) failwith("zlib_inflate_init"); return z; }
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); }
CAMLprim value zlib_deflate_bound(value zv,value len) { return Val_int(deflateBound(zval(zv),Int_val(len))); }
CAMLprim value caml_ldexp_float(value f, value i) { return caml_copy_double(ldexp(Double_val(f), Int_val(i))); }
value setLeftManaMax(val) { fi.leftManaMax = Int_val(val); return Val_unit; }