Example #1
0
value setRightLife(val)
{
	fi.rightLife = Int_val(val);
	return Val_unit;
}
Example #2
0
CAMLprim value caml_sys_close(value fd)
{
  close(Int_val(fd));
  return Val_unit;
}
Example #3
0
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);
}
Example #4
0
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);
	
}
Example #6
0
CAMLprim value sys_dlmemcpy( value dst, value src, value len ) {
	memcpy((char*)dst,(char*)src,Int_val(len));
	return Val_unit;
}
Example #7
0
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;
}
Example #8
0
static int t_major_is_valid(value t)
{
  return (Int_val(Field(t, 3)) == caml_stat_compactions);
}
Example #9
0
static size_t t_major_fill(value t)
{
  return Int_val(Field(t, 4));
}
Example #10
0
/* 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));
}
Example #11
0
static size_t t_minor_fill(value t)
{
  return Int_val(Field(t, 1));
}
Example #12
0
value setRightCreatureLevel(lvl)
{
	fi.rightLevel = Int_val(lvl);
	return Val_unit;
}
Example #13
0
value setLeftCreatureLevel(lvl)
{
	fi.leftLevel = Int_val(lvl);
	return Val_unit;
}
Example #14
0
value setRightManaMax(val)
{
	fi.rightManaMax = Int_val(val);
	return Val_unit;
}
Example #15
0
CAMLprim value sys_dlint( value i ) {
	return Int_val(i);
}
Example #16
0
static int t_minor_is_valid(value t)
{
  return (Int_val(Field(t, 0)) == caml_stat_minor_collections);
}
Example #17
0
CAMLprim value sys_dladdr( value v, value a ) {
	return (value)((char*)v + Int_val(a));
}
Example #18
0
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

}
Example #19
0
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;
}
Example #20
0
/* 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)));
}
Example #21
0
CAMLprim value
uint56_of_int(value v)
{
  CAMLparam1(v);
  CAMLreturn (copy_uint64(((uint64_t)Int_val(v)) << 8));
}
Example #22
0
/* 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)));
}
Example #23
0
  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;
}
Example #24
0
/* 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));
}
Example #25
0
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);
    }
  }
}
Example #26
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;
}
Example #27
0
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);
}
Example #28
0
CAMLprim value zlib_deflate_bound(value zv,value len) {
	return Val_int(deflateBound(zval(zv),Int_val(len)));
}
Example #29
0
CAMLprim value caml_ldexp_float(value f, value i)
{
  return caml_copy_double(ldexp(Double_val(f), Int_val(i)));
}
Example #30
0
value setLeftManaMax(val)
{
	fi.leftManaMax = Int_val(val);
	return Val_unit;
}