コード例 #1
0
 void
 AddField(const ConstString &name, const CompilerType &type, uint64_t offset)
 {
     m_fields.push_back(Field(name, type, offset));
 }
コード例 #2
0
ファイル: fail.c プロジェクト: puppeh/ocaml-sh4
CAMLexport void caml_raise_not_found(void)
{
  caml_raise_constant(Field(caml_global_data, NOT_FOUND_EXN));
}
コード例 #3
0
ファイル: fail.c プロジェクト: puppeh/ocaml-sh4
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);
}
コード例 #4
0
ファイル: fail.c プロジェクト: puppeh/ocaml-sh4
CAMLexport void caml_raise_stack_overflow(void)
{
  caml_raise_constant(Field(caml_global_data, STACK_OVERFLOW_EXN));
}
コード例 #5
0
ファイル: fail.c プロジェクト: puppeh/ocaml-sh4
CAMLexport void caml_raise_end_of_file(void)
{
  caml_raise_constant(Field(caml_global_data, END_OF_FILE_EXN));
}
コード例 #6
0
ファイル: mpq.c プロジェクト: Athas/mosml
value pgconn_alloc(PGconn* conn)
{ 
  value res = alloc(1, Abstract_tag);
  initialize(&Field(res, 0), (value)conn);
  return res;
}
コード例 #7
0
ファイル: intern.c プロジェクト: alepharchives/exsml
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;
        }
      }
    }
  }
}
コード例 #8
0
ファイル: gc_ctrl.c プロジェクト: dhil/ocaml-multicore
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
}
コード例 #9
0
ファイル: mmap_unix.c プロジェクト: Chris00/ocaml
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);
}
コード例 #10
0
/* 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);
	
}
コード例 #11
0
ファイル: main.cpp プロジェクト: flopp/gol-sat
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;
}
コード例 #12
0
ファイル: xdiff.c プロジェクト: Dunedan/weidu
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);
}
コード例 #13
0
ファイル: gc_ctrl.c プロジェクト: Athas/mosml
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;
}
コード例 #14
0
/**
**  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 &ltpos, 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;
}
コード例 #15
0
ファイル: sendmsg.c プロジェクト: haesbaert/extunix
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);
}
コード例 #16
0
ファイル: mmap_win32.c プロジェクト: MassD/ocaml
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);
}
コード例 #17
0
ファイル: compact.c プロジェクト: MassD/ocaml
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);
}
コード例 #18
0
ファイル: minor_gc.c プロジェクト: blackswanburst/mirage
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;
  }
}
コード例 #19
0
ファイル: mpq.c プロジェクト: Athas/mosml
value pgresult_alloc(PGresult* pgres)
{ 
  value res = alloc_final(2, &pgresult_finalize, 1, 10000);
  initialize(&Field(res, 1), (value)pgres);
  return res;
}
コード例 #20
0
ファイル: stacks.c プロジェクト: pechfunk/caml-shift
                       " 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");
    */
コード例 #21
0
ファイル: intern.c プロジェクト: alepharchives/exsml
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;
}
コード例 #22
0
ファイル: stacks.c プロジェクト: pechfunk/caml-shift
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;
}
コード例 #23
0
ファイル: fail.c プロジェクト: puppeh/ocaml-sh4
CAMLexport void caml_raise_sys_error(value msg)
{
  caml_raise_with_arg(Field(caml_global_data, SYS_ERROR_EXN), msg);
}
コード例 #24
0
ファイル: be-contacts.cpp プロジェクト: G-shadow/trojita
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);
}
コード例 #25
0
ファイル: fail.c プロジェクト: puppeh/ocaml-sh4
CAMLexport void caml_raise_zero_divide(void)
{
  caml_raise_constant(Field(caml_global_data, ZERO_DIVIDE_EXN));
}
コード例 #26
0
ファイル: extern.c プロジェクト: avsm/ocaml-community
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;
    }
    }
  }
コード例 #27
0
ファイル: fail.c プロジェクト: puppeh/ocaml-sh4
CAMLexport void caml_raise_sys_blocked_io(void)
{
  caml_raise_constant(Field(caml_global_data, SYS_BLOCKED_IO));
}
コード例 #28
0
ファイル: errmsg.c プロジェクト: puppeh/ocaml-sh4
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));
}
コード例 #29
0
ファイル: fail.c プロジェクト: puppeh/ocaml-sh4
CAMLexport void caml_failwith (char const *msg)
{
  caml_raise_with_string(Field(caml_global_data, FAILURE_EXN), msg);
}
コード例 #30
0
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);
}