void
 AddField(const ConstString &name, const CompilerType &type, uint64_t offset)
 {
     m_fields.push_back(Field(name, type, offset));
 }

CAMLexport void caml_raise_not_found(void)
{
  caml_raise_constant(Field(caml_global_data, NOT_FOUND_EXN));
}

void caml_init_exceptions(void)
{
  out_of_memory_bucket.hdr = Make_header(1, 0, Caml_white);
  out_of_memory_bucket.exn = Field(caml_global_data, OUT_OF_MEMORY_EXN);
  caml_register_global_root(&out_of_memory_bucket.exn);
}

CAMLexport void caml_raise_stack_overflow(void)
{
  caml_raise_constant(Field(caml_global_data, STACK_OVERFLOW_EXN));
}

CAMLexport void caml_raise_end_of_file(void)
{
  caml_raise_constant(Field(caml_global_data, END_OF_FILE_EXN));
}

value pgconn_alloc(PGconn* conn)
{ 
  value res = alloc(1, Abstract_tag);
  initialize(&Field(res, 0), (value)conn);
  return res;
}

static void expand_block(value32 * source, value * dest, mlsize_t source_len, mlsize_t dest_len, color_t color)
{
  value32 * p, * q;
  value * d, * e;
  header_t hd;
  mlsize_t sz;
  tag_t tag;
  uint32_t * forward_addr;
  uint32_t dest_ofs;
  value v;

  /* First pass: copy the objects and set up forwarding pointers.
     The pointers contained inside blocks are not resolved. */

  for (p = source, q = source + source_len, d = dest; p < q; /*nothing*/) {
    hd = (header_t) *p++;
    sz = Wosize_hd(hd);
    tag = Tag_hd(hd);
    forward_addr = (uint32_t *) p;
    dest_ofs = d + 1 - dest;
    switch(tag) {
    case String_tag:
      { mlsize_t ofs_last_byte, len, new_sz;
        ofs_last_byte = sz * sizeof(value32) - 1;
        len = ofs_last_byte - Byte(p, ofs_last_byte);
        new_sz = (sz * sizeof(value32) + sizeof(value) - 1) / sizeof(value);
        *d++ = Make_header(new_sz, String_tag, color);
        Field(d, new_sz - 1) = 0;
        bcopy((char *)p, (char *)d, len);
        ofs_last_byte = new_sz * sizeof(value) - 1;
        Byte(d, ofs_last_byte) = ofs_last_byte - len;
        p += sz;
        d += new_sz;
        break;
      }
    case Double_tag:
      *d++ = Make_header(Double_wosize, Double_tag, color);
      /* Cannot do *((double *) d) = *((double *) p) directly
         because p might not be 64-aligned. */
      assert(sizeof(double) == sizeof(value));
      ((value32 *) d)[0] = p[0];
      ((value32 *) d)[1] = p[1];
      p += sizeof(double) / sizeof(value32);
      d += 1;
      break;
    default:
      *d++ = Make_header(sz, tag, color);
      for (/*nothing*/; sz > 0; sz--, p++, d++) {
        if ((*p & 1) == 0) {
          *d = *((uint32_t *) p);         /* copy, zero expansion */
        } else {
          *d = *((int32_t *) p);          /* copy, sign expansion */
        }
      }
      break;
    }
    *forward_addr = dest_ofs;   /* store the forwarding pointer */
  }
  assert(d == dest + dest_len);

  /* Second pass: resolve pointers contained inside blocks,
     replacing them by the corresponding forwarding pointer. */

  for (d = dest, e = dest + dest_len; d < e; /*nothing*/) {
    hd = (header_t) *d++;
    sz = Wosize_hd(hd);
    tag = Tag_hd(hd);
    if (tag >= No_scan_tag) {
      d += sz;
    } else {
      for (/*nothing*/; sz > 0; sz--, d++) {
        v = *d;
        switch(v & 3) {
        case 0:                 /* 0: a block represented by its offset */
          assert(v >= 0 && v < source_len * sizeof(value32) && (v & 3) == 0);
          *d = (value) (dest + *((uint32_t *)((char *) source + v)));
          break;
        case 2:                 /* 2: an atom */
          v = v >> 2;
          assert(v >= 0 && v < 256);
          *d = Atom(v);
          break;
        default:                /* 1 or 3: an integer */
          break;
        }
      }
    }
  }
}

CAMLprim value caml_gc_set(value v)
{
  return Val_unit;
#if 0
  uintnat newpf, newpm;
  asize_t newheapincr;
  asize_t newminwsz;
  uintnat oldpolicy;
  CAML_INSTR_SETUP (tmr, "");

  caml_params->verb_gc = Long_field (v, 3);

#ifndef NATIVE_CODE
  caml_change_max_stack_size (Long_field (v, 5));
#endif

  newpf = norm_pfree (Long_field (v, 2));
  if (newpf != caml_percent_free){
    caml_percent_free = newpf;
    caml_gc_message (0x20, "New space overhead: %"
                     ARCH_INTNAT_PRINTF_FORMAT "u%%\n", caml_percent_free);
  }

  newpm = norm_pmax (Long_field (v, 4));
  if (newpm != caml_percent_max){
    caml_percent_max = newpm;
    caml_gc_message (0x20, "New max overhead: %"
                     ARCH_INTNAT_PRINTF_FORMAT "u%%\n", caml_percent_max);
  }

  newheapincr = Long_field (v, 1);
  if (newheapincr != caml_major_heap_increment){
    caml_major_heap_increment = newheapincr;
    if (newheapincr > 1000){
      caml_gc_message (0x20, "New heap increment size: %"
                       ARCH_INTNAT_PRINTF_FORMAT "uk words\n",
                       caml_major_heap_increment/1024);
    }else{
      caml_gc_message (0x20, "New heap increment size: %"
                       ARCH_INTNAT_PRINTF_FORMAT "u%%\n",
                       caml_major_heap_increment);
    }
  }
  oldpolicy = caml_allocation_policy;
  caml_set_allocation_policy (Long_field (v, 6));
  if (oldpolicy != caml_allocation_policy){
    caml_gc_message (0x20, "New allocation policy: %"
                     ARCH_INTNAT_PRINTF_FORMAT "u\n", caml_allocation_policy);
  }

  /* This field was added in 4.03.0. */
  if (Wosize_val (v) >= 8){
    int old_window = caml_major_window;
    caml_set_major_window (norm_window (Long_val (Field (v, 7))));
    if (old_window != caml_major_window){
      caml_gc_message (0x20, "New smoothing window size: %d\n",
                       caml_major_window);
    }
  }

    /* Minor heap size comes last because it will trigger a minor collection
       (thus invalidating [v]) and it can raise [Out_of_memory]. */
  newminsize = caml_norm_minor_heap_size (Long_field (v, 0));
  if (newminsize != Caml_state->minor_heap_size){
    caml_gc_message (0x20, "New minor heap size: %luk bytes\n",
                     newminsize/1024);
    caml_set_minor_heap_size (newminsize);
  }
  CAML_INSTR_TIME (tmr, "explicit/gc_set");
  return Val_unit;
#endif
}

CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout,
                                value vshared, value vdim, value vstart)
{
  int fd, flags, major_dim, shared;
  intnat num_dims, i;
  intnat dim[CAML_BA_MAX_NUM_DIMS];
  file_offset startpos, file_size, data_size;
  struct stat st;
  uintnat array_size, page, delta;
  void * addr;

  fd = Int_val(vfd);
  flags = Int_val(vkind) | Int_val(vlayout);
  startpos = File_offset_val(vstart);
  num_dims = Wosize_val(vdim);
  major_dim = flags & CAML_BA_FORTRAN_LAYOUT ? num_dims - 1 : 0;
  /* Extract dimensions from OCaml array */
  num_dims = Wosize_val(vdim);
  if (num_dims < 1 || num_dims > CAML_BA_MAX_NUM_DIMS)
    caml_invalid_argument("Bigarray.mmap: bad number of dimensions");
  for (i = 0; i < num_dims; i++) {
    dim[i] = Long_val(Field(vdim, i));
    if (dim[i] == -1 && i == major_dim) continue;
    if (dim[i] < 0)
      caml_invalid_argument("Bigarray.create: negative dimension");
  }
  /* Determine file size. We avoid lseek here because it is fragile,
     and because some mappable file types do not support it
   */
  caml_enter_blocking_section();
  if (fstat(fd, &st) == -1) {
    caml_leave_blocking_section();
    caml_sys_error(NO_ARG);
  }
  file_size = st.st_size;
  /* Determine array size in bytes (or size of array without the major
     dimension if that dimension wasn't specified) */
  array_size = caml_ba_element_size[flags & CAML_BA_KIND_MASK];
  for (i = 0; i < num_dims; i++)
    if (dim[i] != -1) array_size *= dim[i];
  /* Check if the major dimension is unknown */
  if (dim[major_dim] == -1) {
    /* Determine major dimension from file size */
    if (file_size < startpos) {
      caml_leave_blocking_section();
      caml_failwith("Bigarray.mmap: file position exceeds file size");
    }
    data_size = file_size - startpos;
    dim[major_dim] = (uintnat) (data_size / array_size);
    array_size = dim[major_dim] * array_size;
    if (array_size != data_size) {
      caml_leave_blocking_section();
      caml_failwith("Bigarray.mmap: file size doesn't match array dimensions");
    }
  } else {
    /* Check that file is large enough, and grow it otherwise */
    if (file_size < startpos + array_size) {
      if (caml_grow_file(fd, startpos + array_size) == -1) { /* PR#5543 */
        caml_leave_blocking_section();
        caml_sys_error(NO_ARG);
      }
    }
  }
  /* Determine offset so that the mapping starts at the given file pos */
  page = getpagesize();
  delta = (uintnat) startpos % page;
  /* Do the mmap */
  shared = Bool_val(vshared) ? MAP_SHARED : MAP_PRIVATE;
  if (array_size > 0)
    addr = mmap(NULL, array_size + delta, PROT_READ | PROT_WRITE,
                shared, fd, startpos - delta);
  else
    addr = NULL;                /* PR#5463 - mmap fails on empty region */
  caml_leave_blocking_section();
  if (addr == (void *) MAP_FAILED) caml_sys_error(NO_ARG);
  addr = (void *) ((uintnat) addr + delta);
  /* Build and return the OCaml bigarray */
  return caml_ba_alloc(flags | CAML_BA_MAPPED_FILE, num_dims, addr, dim);
}

/* given a return value in OCaml land, translate it to 
   the return_val_t C structure
*/ 
return_val_t translate_return_value(value ocaml_result) {
  CAMLparam1(ocaml_result);
  CAMLlocal5(ocaml_shape, ocaml_strides, ocaml_data, ocaml_cur, ocaml_type);
  CAMLlocal1(v);
  
  return_val_t ret;
  
  if (Is_long(ocaml_result)) {
    // In this case, we know that the return code must have been Pass,
    // since the other two return codes have data.
    ret.return_code = RET_PASS;
    ret.results_len = 0;
  } else if (Tag_val(ocaml_result) == RET_FAIL) {
    ret.return_code = RET_FAIL;
    ret.results_len = caml_string_length(Field(ocaml_result, 0));
    ret.error_msg = malloc(ret.results_len + 1);
    strcpy(ret.error_msg, String_val(Field(ocaml_result, 0)));
  } else if (Tag_val(ocaml_result) == RET_SUCCESS) {
    
    ocaml_cur = Field(ocaml_result, 0);
    ret.return_code = RET_SUCCESS;
    ret.results_len = ocaml_list_length(ocaml_cur);
    ret.results = (ret_t*)malloc(sizeof(ret_t) * ret.results_len);
    
    int i, j;
    host_val h; 
    for (i = 0; i < ret.results_len; ++i) {
      v = Field(ocaml_cur, 0);
      h = create_host_val(v);  
      ocaml_cur = Field(ocaml_cur, 1);
      // returning a scalar
      if (value_is_scalar(h)) {

        ret.results[i].is_scalar = 1;
        ocaml_type = (scalar_type)value_type_of(h);
        ret.results[i].data.scalar.ret_type =
            get_scalar_element_type(ocaml_type);

        // WARNING:
        // Tiny Memory Leak Ahead
        // -----------------------
        // When scalar data is returned to the host language
        // on the heap, it should be manually deleted by the
        // host frontend

        if (type_is_bool(ocaml_type)) {
          ret.results[i].data.scalar.ret_scalar_value.boolean = get_bool(h);
        } else if (type_is_int32(ocaml_type)) {
          ret.results[i].data.scalar.ret_scalar_value.int32 = get_int32(h);
        } else if (type_is_int64(ocaml_type)) {
          ret.results[i].data.scalar.ret_scalar_value.int64 = get_int64(h);
        } else if (type_is_float32(ocaml_type)) { 
          ret.results[i].data.scalar.ret_scalar_value.float32 = get_float64(h);
        } else if (type_is_float64(ocaml_type)) {
          ret.results[i].data.scalar.ret_scalar_value.float64 = get_float64(h);
        } else {
          caml_failwith("Unable to return scalar of this type\n");
        }
      } else {
        // Pass the type
        ret.results[i].is_scalar = 0;
        ret.results[i].data.array.ret_type = array_type_of(h);

        // Pass the data
        ret.results[i].data.array.data = get_array_data(h);

        // Build the shape array
        ocaml_shape = value_get_shape(h);
        int shape_len = Wosize_val(ocaml_shape);

        ret.results[i].data.array.shape =
            (int*)malloc(shape_len * sizeof(int));
        ret.results[i].data.array.shape_len = shape_len;
        for (j = 0; j < shape_len; ++j) {
          ret.results[i].data.array.shape[j] = Int_val(Field(ocaml_shape, j));
        }

        // Build the strides array
        ocaml_strides = value_get_strides(h);
        int strides_len = Wosize_val(ocaml_strides);

        ret.results[i].data.array.strides_len = strides_len;
        ret.results[i].data.array.strides =
            (int*)malloc(strides_len * sizeof(int));
        for (j = 0; j < strides_len; ++j) {
          ret.results[i].data.array.strides[j] =
              Int_val(Field(ocaml_strides, j));
        }
      }
    }
  }
  CAMLreturnT(return_val_t, ret);
	
}

int main(int argc, char** argv)
{
    Options options;
    if (!parseCommandLine(argc, argv, options))
    {
        return 1;
    }
    
    std::cout << "-- Reading pattern from file: " << options.pattern << std::endl;
    Pattern pat;
    std::ifstream f(options.pattern);
    if (!f)
    {
        std::cout << "-- Error: Cannot open " << options.pattern << std::endl;
        return 1;
    }
    try
    {
        pat.load(f);
    }
    catch (std::exception& e)
    {
        std::cout << "-- Error: " << e.what() << std::endl;
        return 1;
    }

    SatSolver s;

    std::cout << "-- Building formula for " << options.evolutions << " evolution steps..." << std::endl;
    std::vector<Field> fields;
    for (int g = 0; g <= options.evolutions; ++g)
    {
        fields.push_back(Field(s, pat.width(), pat.height()));
        if (g > 0)
        {
            transition(s, fields[g-1], fields[g]);
        }
    }
    
    if (options.backwards)
    {
        std::cout << "-- Setting pattern constraint on last generation..." << std::endl;
        patternConstraint(s, fields.back(), pat);
    }
    else
    {
        std::cout << "-- Setting pattern constraint on first generation..." << std::endl;
        patternConstraint(s, fields.front(), pat);
    }

    std::cout << "-- Solving formula..." << std::endl;
    if (!s.solve())
    {
        std::cout << "-- Formula is not solvable. The selected pattern is probably too restrictive!" << std::endl;
        return 1;
    }

    std::cout << std::endl;
    for (int g = 0; g <= options.evolutions; ++g)
    {
        if (options.backwards)
        {
            if (g == 0)
            {
                std::cout << "-- Initial generation:" << std::endl;
            }
            else if (g == options.evolutions)
            {
                std::cout << "-- Evolves to final generation (from pattern):" << std::endl;
            }
            else
            {
                std::cout << "-- Evolves to:" << std::endl;
            }
        }
        else
        {
            if (g == 0)
            {
                std::cout << "-- Initial generation (from pattern):" << std::endl;
            }
            else if (g == options.evolutions)
            {
                std::cout << "-- Evolves to final generation:" << std::endl;
            }
            else
            {
                std::cout << "-- Evolves to:" << std::endl;
            }
        }
        fields[g].print(std::cout, s);
        std::cout << std::endl;
    }

    return 0;
}

value xdiff_revpatch( value old_data, value patch) 
{
    CAMLparam2 (old_data, patch);
    CAMLlocal1(res);
    mmfile_t mf1, mf2, mf3, mf4;
    xdemitcb_t ecb, rjecb;
    long new_size, rej_size;


    res = alloc_tuple(2);

    if (xdlt_store_mmfile(String_val(old_data), string_length(old_data), &mf1) < 0) {
        sprintf(ELINE, "%s:%d failed", __FILE__, __LINE__);
        failwith(ELINE);
    }
    if (xdlt_store_mmfile(String_val(patch), string_length(patch), &mf2) < 0) {
        xdl_free_mmfile(&mf1);
        sprintf(ELINE, "%s:%d failed", __FILE__, __LINE__);
        failwith(ELINE);
    }
    if (xdl_init_mmfile(&mf3, XDLT_STD_BLKSIZE, XDL_MMF_ATOMIC) < 0) {
        xdl_free_mmfile(&mf1);
        xdl_free_mmfile(&mf2);
        sprintf(ELINE, "%s:%d failed", __FILE__, __LINE__);
        failwith(ELINE);
    }
    if (xdl_init_mmfile(&mf4, XDLT_STD_BLKSIZE, XDL_MMF_ATOMIC) < 0) {
        xdl_free_mmfile(&mf1);
        xdl_free_mmfile(&mf2);
        xdl_free_mmfile(&mf3);
        sprintf(ELINE, "%s:%d failed", __FILE__, __LINE__);
        failwith(ELINE);
    }
    ecb.priv = &mf3;
    ecb.outf = xdlt_outf;
    rjecb.priv = &mf4;
    rjecb.outf = xdlt_outf;

    if (xdl_patch(&mf1, &mf2, XDL_PATCH_REVERSE, &ecb, &rjecb) < 0) {
        xdl_free_mmfile(&mf1);
        xdl_free_mmfile(&mf2);
        xdl_free_mmfile(&mf3);
        xdl_free_mmfile(&mf4);
        sprintf(ELINE, "%s:%d failed", __FILE__, __LINE__);
        failwith(ELINE);
    }
    new_size = xdlt_mmfile_size(&mf3);
    rej_size = xdlt_mmfile_size(&mf4);
    Field(res, 0) = alloc_string(new_size);
    Field(res, 1) = alloc_string(rej_size);
    if (xdlt_read_mmfile(String_val(Field(res, 0)), &mf3) < 0) {
        xdl_free_mmfile(&mf1);
        xdl_free_mmfile(&mf2);
        xdl_free_mmfile(&mf3);
        xdl_free_mmfile(&mf4);
        sprintf(ELINE, "%s:%d failed", __FILE__, __LINE__);
        failwith(ELINE);
    }
    if (xdlt_read_mmfile(String_val(Field(res, 1)), &mf4) < 0) {
        xdl_free_mmfile(&mf1);
        xdl_free_mmfile(&mf2);
        xdl_free_mmfile(&mf3);
        xdl_free_mmfile(&mf4);
        sprintf(ELINE, "%s:%d failed", __FILE__, __LINE__);
        failwith(ELINE);
    }

    xdl_free_mmfile(&mf1);
    xdl_free_mmfile(&mf2);
    xdl_free_mmfile(&mf3);
    xdl_free_mmfile(&mf4);

    CAMLreturn(res);
}

value gc_stat (value v) /* ML */
{
  value res;
  long live_words = 0, live_blocks = 0,
       free_words = 0, free_blocks = 0, largest_free = 0,
       fragments = 0, heap_chunks = 0;
  char *chunk = heap_start, *chunk_end;
  char *cur_hp, *prev_hp;
  header_t cur_hd;

  Assert (v == Atom (0));

  while (chunk != NULL){
    ++ heap_chunks;
    chunk_end = chunk + Chunk_size (chunk);
    prev_hp = NULL;
    cur_hp = chunk;
    while (cur_hp < chunk_end){
      cur_hd = Hd_hp (cur_hp);
      switch (Color_hd (cur_hd)){
      case White:
	if (Wosize_hd (cur_hd) == 0){
	  ++fragments;
	  Assert (prev_hp == NULL
		  || (Color_hp (prev_hp) != Blue
		      && Wosize_hp (prev_hp) > 0));
	  Assert (Next (cur_hp) == chunk_end
		  || (Color_hp (Next (cur_hp)) != Blue
		      && Wosize_hp (Next (cur_hp)) > 0));
	  break;
	}
	/* FALLTHROUGH */
      case Gray: case Black:
	Assert (Wosize_hd (cur_hd) > 0);
	++ live_blocks;
	live_words += Whsize_hd (cur_hd);
	break;
      case Blue:
	Assert (Wosize_hd (cur_hd) > 0);
	++ free_blocks;
	free_words += Whsize_hd (cur_hd);
	if (Whsize_hd (cur_hd) > largest_free){
	  largest_free = Whsize_hd (cur_hd);
	}
	Assert (prev_hp == NULL
		|| (Color_hp (prev_hp) != Blue
		    && Wosize_hp (prev_hp) > 0));
	Assert (Next (cur_hp) == chunk_end
		|| (Color_hp (Next (cur_hp)) != Blue
		    && Wosize_hp (Next (cur_hp)) > 0));
	break;
      }
      prev_hp = cur_hp;
      cur_hp = Next (cur_hp);
    }                                          Assert (cur_hp == chunk_end);
    chunk = Chunk_next (chunk);
  }
  
  Assert (live_words + free_words + fragments == Wsize_bsize (stat_heap_size));
  /* Order of elements changed for Moscow ML */
  res = alloc (13, 0);
  Field (res, 11) = Val_long (stat_minor_words
                             + Wsize_bsize (young_ptr - young_start));
  Field (res, 12) = Val_long (stat_promoted_words);
  Field (res,  9) = Val_long (stat_major_words + allocated_words);
  Field (res, 10) = Val_long (stat_minor_collections);
  Field (res,  8) = Val_long (stat_major_collections);
  Field (res,  4) = Val_long (Wsize_bsize (stat_heap_size));
  Field (res,  3) = Val_long (heap_chunks);
  Field (res,  7) = Val_long (live_words);
  Field (res,  6) = Val_long (live_blocks);
  Field (res,  2) = Val_long (free_words);
  Field (res,  1) = Val_long (free_blocks);
  Field (res,  5) = Val_long (largest_free);
  Field (res,  0) = Val_long (fragments);
  return res;
}

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;
//.........这里部分代码省略.........

CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout,
                                value vshared, value vdim, value vstart)
{
  HANDLE fd, fmap;
  int flags, major_dim, mode, perm;
  intnat num_dims, i;
  intnat dim[CAML_BA_MAX_NUM_DIMS];
  __int64 currpos, startpos, file_size, data_size;
  uintnat array_size, page, delta;
  char c;
  void * addr;
  LARGE_INTEGER li;
  SYSTEM_INFO sysinfo;

  fd = Handle_val(vfd);
  flags = Int_val(vkind) | Int_val(vlayout);
  startpos = Int64_val(vstart);
  num_dims = Wosize_val(vdim);
  major_dim = flags & CAML_BA_FORTRAN_LAYOUT ? num_dims - 1 : 0;
  /* Extract dimensions from OCaml array */
  num_dims = Wosize_val(vdim);
  if (num_dims < 1 || num_dims > CAML_BA_MAX_NUM_DIMS)
    caml_invalid_argument("Bigarray.mmap: bad number of dimensions");
  for (i = 0; i < num_dims; i++) {
    dim[i] = Long_val(Field(vdim, i));
    if (dim[i] == -1 && i == major_dim) continue;
    if (dim[i] < 0)
      caml_invalid_argument("Bigarray.create: negative dimension");
  }
  /* Determine file size */
  currpos = caml_ba_set_file_pointer(fd, 0, FILE_CURRENT);
  if (currpos == -1) caml_ba_sys_error();
  file_size = caml_ba_set_file_pointer(fd, 0, FILE_END);
  if (file_size == -1) caml_ba_sys_error();
  /* Determine array size in bytes (or size of array without the major
     dimension if that dimension wasn't specified) */
  array_size = caml_ba_element_size[flags & CAML_BA_KIND_MASK];
  for (i = 0; i < num_dims; i++)
    if (dim[i] != -1) array_size *= dim[i];
  /* Check if the first/last dimension is unknown */
  if (dim[major_dim] == -1) {
    /* Determine first/last dimension from file size */
    if (file_size < startpos)
      caml_failwith("Bigarray.mmap: file position exceeds file size");
    data_size = file_size - startpos;
    dim[major_dim] = (uintnat) (data_size / array_size);
    array_size = dim[major_dim] * array_size;
    if (array_size != data_size)
      caml_failwith("Bigarray.mmap: file size doesn't match array dimensions");
  }
  /* Restore original file position */
  caml_ba_set_file_pointer(fd, currpos, FILE_BEGIN);
  /* Create the file mapping */
  if (Bool_val(vshared)) {
    perm = PAGE_READWRITE;
    mode = FILE_MAP_WRITE;
  } else {
    perm = PAGE_READONLY;       /* doesn't work under Win98 */
    mode = FILE_MAP_COPY;
  }
  li.QuadPart = startpos + array_size;
  fmap = CreateFileMapping(fd, NULL, perm, li.HighPart, li.LowPart, NULL);
  if (fmap == NULL) caml_ba_sys_error();
  /* Determine offset so that the mapping starts at the given file pos */
  GetSystemInfo(&sysinfo);
  delta = (uintnat) (startpos % sysinfo.dwAllocationGranularity);
  /* Map the mapping in memory */
  li.QuadPart = startpos - delta;
  addr =
    MapViewOfFile(fmap, mode, li.HighPart, li.LowPart, array_size + delta);
  if (addr == NULL) caml_ba_sys_error();
  addr = (void *) ((uintnat) addr + delta);
  /* Close the file mapping */
  CloseHandle(fmap);
  /* Build and return the OCaml bigarray */
  return caml_ba_alloc(flags | CAML_BA_MAPPED_FILE, num_dims, addr, dim);
}

static void do_compaction_r (CAML_R)
{
  char *ch, *chend;
                                          Assert (caml_gc_phase == Phase_idle);
  caml_gc_message (0x10, "Compacting heap...\n", 0);

#ifdef DEBUG
  caml_heap_check_r (ctx);
#endif

  /* First pass: encode all noninfix headers. */
  {
    ch = caml_heap_start;
    while (ch != NULL){
      header_t *p = (header_t *) ch;

      chend = ch + Chunk_size (ch);
      while ((char *) p < chend){
        header_t hd = Hd_hp (p);
        mlsize_t sz = Wosize_hd (hd);

        if (Is_blue_hd (hd)){
          /* Free object.  Give it a string tag. */
          Hd_hp (p) = Make_ehd (sz, String_tag, 3);
        }else{                                      Assert (Is_white_hd (hd));
          /* Live object.  Keep its tag. */
          Hd_hp (p) = Make_ehd (sz, Tag_hd (hd), 3);
        }
        p += Whsize_wosize (sz);
      }
      ch = Chunk_next (ch);
    }
  }


  /* Second pass: invert pointers.
     Link infix headers in each block in an inverted list of inverted lists.
     Don't forget roots and weak pointers. */
  {
    /* Invert roots first because the threads library needs some heap
       data structures to find its roots.  Fortunately, it doesn't need
       the headers (see above). */
    caml_do_roots_r (ctx, invert_root_r);
    caml_final_do_weak_roots_r (ctx, invert_root_r);

    ch = caml_heap_start;
    while (ch != NULL){
      word *p = (word *) ch;
      chend = ch + Chunk_size (ch);

      while ((char *) p < chend){
        word q = *p;
        size_t sz, i;
        tag_t t;
        word *infixes;

        while (Ecolor (q) == 0) q = * (word *) q;
        sz = Whsize_ehd (q);
        t = Tag_ehd (q);

        if (t == Infix_tag){
          /* Get the original header of this block. */
          infixes = p + sz;
          q = *infixes;
          while (Ecolor (q) != 3) q = * (word *) (q & ~(uintnat)3);
          sz = Whsize_ehd (q);
          t = Tag_ehd (q);
        }

        if (t < No_scan_tag){
          for (i = 1; i < sz; i++) invert_pointer_at_r (ctx, &(p[i]));
        }
        p += sz;
      }
      ch = Chunk_next (ch);
    }
    /* Invert weak pointers. */
    {
      value *pp = &caml_weak_list_head;
      value p;
      word q;
      size_t sz, i;

      while (1){
        p = *pp;
        if (p == (value) NULL) break;
        q = Hd_val (p);
        while (Ecolor (q) == 0) q = * (word *) q;
        sz = Wosize_ehd (q);
        for (i = 1; i < sz; i++){
          if (Field (p,i) != caml_weak_none){
            invert_pointer_at_r (ctx, (word *) &(Field (p,i)));
          }
        }
        invert_pointer_at_r (ctx, (word *) pp);
        pp = &Field (p, 0);
      }
    }
  }

//.........这里部分代码省略.........

void caml_oldify_one (value v, value *p)
{
  value result;
  header_t hd;
  mlsize_t sz, i;
  tag_t tag;

 tail_call:
  if (Is_block (v) && Is_young (v)){
    Assert (Hp_val (v) >= caml_young_ptr);
    hd = Hd_val (v);
    if (hd == 0){         /* If already forwarded */
      *p = Field (v, 0);  /*  then forward pointer is first field. */
    }else{
      tag = Tag_hd (hd);
      if (tag < Infix_tag){
        value field0;

        sz = Wosize_hd (hd);
        result = caml_alloc_shr (sz, tag);
        *p = result;
        field0 = Field (v, 0);
        Hd_val (v) = 0;            /* Set forward flag */
        Field (v, 0) = result;     /*  and forward pointer. */
        if (sz > 1){
          Field (result, 0) = field0;
          Field (result, 1) = oldify_todo_list;    /* Add this block */
          oldify_todo_list = v;                    /*  to the "to do" list. */
        }else{
          Assert (sz == 1);
          p = &Field (result, 0);
          v = field0;
          goto tail_call;
        }
      }else if (tag >= No_scan_tag){
        sz = Wosize_hd (hd);
        result = caml_alloc_shr (sz, tag);
        for (i = 0; i < sz; i++) Field (result, i) = Field (v, i);
        Hd_val (v) = 0;            /* Set forward flag */
        Field (v, 0) = result;     /*  and forward pointer. */
        *p = result;
      }else if (tag == Infix_tag){
        mlsize_t offset = Infix_offset_hd (hd);
        caml_oldify_one (v - offset, p);   /* Cannot recurse deeper than 1. */
        *p += offset;
      }else{
        value f = Forward_val (v);
        tag_t ft = 0;
        int vv = 1;

        Assert (tag == Forward_tag);
        if (Is_block (f)){
          vv = Is_in_value_area(f);
          if (vv) {
            ft = Tag_val (Hd_val (f) == 0 ? Field (f, 0) : f);
          }
        }
        if (!vv || ft == Forward_tag || ft == Lazy_tag || ft == Double_tag){
          /* Do not short-circuit the pointer.  Copy as a normal block. */
          Assert (Wosize_hd (hd) == 1);
          result = caml_alloc_shr (1, Forward_tag);
          *p = result;
          Hd_val (v) = 0;             /* Set (GC) forward flag */
          Field (v, 0) = result;      /*  and forward pointer. */
          p = &Field (result, 0);
          v = f;
          goto tail_call;
        }else{
          v = f;                        /* Follow the forwarding */
          goto tail_call;               /*  then oldify. */
        }
      }
    }
  }else{
    *p = v;
  }
}

value pgresult_alloc(PGresult* pgres)
{ 
  value res = alloc_final(2, &pgresult_finalize, 1, 10000);
  initialize(&Field(res, 1), (value)pgres);
  return res;
}

                       " to call ensure_stack_space?");
        myassert(0);
#if 0
        /* Old way, pre 3.11: */
        print_gl_stack("Reallocating OCaml stack!");
        caml_realloc_stack(Stack_threshold / sizeof(value));
        */
        return push_stack_fragment(ekfragment); /* Redo */
#endif
    }

    new_sp = caml_extern_sp - size;
    new_trapsp = caml_trapsp - size;
    memmove(new_sp, caml_extern_sp,
            (caml_trapsp - caml_extern_sp) * sizeof(value));
    memcpy(new_trapsp, &Field(ekfragment,0), size * sizeof(value));

    /* adjust the links of exc frames (convert to abs addresses)
       and connect the copied frames to the existing frames
    */
    for (p = new_trapsp; (value)Trap_link(p) != Val_long(0); p = Trap_link(p)) {
        myassert( p < caml_stack_high );
        Trap_link(p) = new_trapsp + Long_val((value) Trap_link(p));
    }
    Trap_link(p) = caml_trapsp;
    caml_extern_sp = new_sp;
    caml_trapsp    = new_trapsp;

    /*
    print_exc_trace("push_stack_fragment: after");
    */

static int shrink_block(value64 * source, value * dest, mlsize_t source_len, mlsize_t dest_len, color_t color)
{
  value64 * p, * q;
  value * d, * e;
  header_t hd;
  mlsize_t sz;
  tag_t tag;
  byteoffset_t * forward_addr;
  byteoffset_t dest_ofs;
  value v;

  /* First pass: copy the objects and set up forwarding pointers.
     The pointers contained inside blocks are not resolved. */

  for (p = source, q = source + source_len, d = dest; p < q; /*nothing*/) {
    hd = (header_t)(p->lsw);
    p++;
    sz = Wosize_hd(hd);
    tag = Tag_hd(hd);
    forward_addr = (byteoffset_t *) p;
    dest_ofs = d + 1 - dest;
    switch(tag) {
    case String_tag:
      { mlsize_t ofs_last_byte, len, new_sz;
        ofs_last_byte = sz * sizeof(value64) - 1;
        len = ofs_last_byte - Byte(p, ofs_last_byte);
        new_sz = (len + sizeof(value)) / sizeof(value);
        *d++ = Make_header(new_sz, String_tag, color);
        Field(d, new_sz - 1) = 0;
        bcopy(p, d, len);
        ofs_last_byte = new_sz * sizeof(value) - 1;
        Byte(d, ofs_last_byte) = ofs_last_byte - len;
        p += sz;
        d += new_sz;
        break;
      }
    case Double_tag:
      *d++ = Make_header(Double_wosize, Double_tag, color);
      Store_double_val((value)d, Double_val((value)p));
      p += sizeof(double) / sizeof(value64);
      d += sizeof(double) / sizeof(value);
      break;
    default:
      *d++ = Make_header(sz, tag, color);
      for (/*nothing*/; sz > 0; sz--, p++, d++) {
        value lsw = p->lsw;
        value msw = p->msw;
        if ((lsw & 1) == 0) {      /* If relative displacement: */
          if (msw != 0) return -1; /* Check unsigned displacement fits in 32 */
        } else {                   /* Otherwise, it's a signed integer */
          if ((lsw >= 0 && msw != 0) || (lsw < 0 && msw != -1)) return -1;
        }
        *d = lsw;
      }
    }
    *forward_addr = dest_ofs;   /* store the forwarding pointer */
  }
  assert(d == dest + dest_len);

  /* Second pass: resolve pointers contained inside blocks,
     replacing them by the corresponding forwarding pointer. */

  for (d = dest, e = dest + dest_len; d < e; /*nothing*/) {
    hd = (header_t) *d++;
    sz = Wosize_hd(hd);
    tag = Tag_hd(hd);
    if (tag >= No_scan_tag) {
      d += sz;
    } else {
      for (/*nothing*/; sz > 0; sz--, d++) {
        v = *d;
        switch(v & 3) {
        case 0:                 /* 0: a block represented by its offset */
          assert(v >= 0 && v < source_len * sizeof(value64) && (v & 7) == 0);
          *d = (value) (dest + *((byteoffset_t *)((char *) source + v)));
          break;
        case 2:                 /* 2: an atom */
          v = v >> 2;
          assert(v >= 0 && v < 256);
          *d = Atom(v);
          break;
        default:                /* 1 or 3: an integer */
          break;
        }
      }
    }
  }
  return 0;
}