Ejemplo n.º 1
0
CAMLprim value caml_make_array(value init)
{
  CAMLparam1 (init);
  mlsize_t wsize, size, i;
  CAMLlocal2 (v, res);

  size = Wosize_val(init);
  if (size == 0) {
    CAMLreturn (init);
  } else {
    v = Field(init, 0);
    if (Is_long(v)
        || ! Is_in_value_area(v)
        || Tag_val(v) != Double_tag) {
      CAMLreturn (init);
    } else {
      Assert(size < Max_young_wosize);
      wsize = size * Double_wosize;
      res = caml_alloc_small(wsize, Double_array_tag);
      for (i = 0; i < size; i++) {
        Store_double_field(res, i, Double_val(Field(init, i)));
      }
      CAMLreturn (res);
    }
  }
}
Ejemplo n.º 2
0
CAMLprim value caml_make_vect(value len, value init)
{
  CAMLparam2 (len, init);
  CAMLlocal1 (res);
  mlsize_t size, wsize, i;
  double d;

  size = Long_val(len);
  if (size == 0) {
    res = Atom(0);
  }
  else if (Is_block(init)
           && Is_in_value_area(init)
           && Tag_val(init) == Double_tag) {
    d = Double_val(init);
    wsize = size * Double_wosize;
    if (wsize > Max_wosize) caml_invalid_argument("Array.make");
    res = caml_alloc(wsize, Double_array_tag);
    for (i = 0; i < size; i++) {
      Store_double_field(res, i, d);
    }
  } else {
    if (size > Max_wosize) caml_invalid_argument("Array.make");
    if (size < Max_young_wosize) {
      res = caml_alloc_small(size, 0);
      for (i = 0; i < size; i++) Field(res, i) = init;
    }
    else if (Is_block(init) && Is_young(init)) {
      caml_minor_collection();
      res = caml_alloc_shr(size, 0);
      for (i = 0; i < size; i++) Field(res, i) = init;
      res = caml_check_urgent_gc (res);
    }
    else {
      res = caml_alloc_shr(size, 0);
      for (i = 0; i < size; i++) caml_initialize(&Field(res, i), init);
      res = caml_check_urgent_gc (res);
    }
  }
  CAMLreturn (res);
}
Ejemplo n.º 3
0
Archivo: hash.c Proyecto: OpenXT/ocaml
static void hash_aux(value obj)
{
  unsigned char * p;
  mlsize_t i, j;
  tag_t tag;

  hash_univ_limit--;
  if (hash_univ_count < 0 || hash_univ_limit < 0) return;

 again:
  if (Is_long(obj)) {
    hash_univ_count--;
    Combine(Long_val(obj));
    return;
  }

  /* Pointers into the heap are well-structured blocks. So are atoms.
     We can inspect the block contents. */

  Assert (Is_block (obj));  
  if (Is_in_value_area(obj)) {
    tag = Tag_val(obj);
    switch (tag) {
    case String_tag:
      hash_univ_count--;
      i = caml_string_length(obj);
      for (p = &Byte_u(obj, 0); i > 0; i--, p++)
        Combine_small(*p);
      break;
    case Double_tag:
      /* For doubles, we inspect their binary representation, LSB first.
         The results are consistent among all platforms with IEEE floats. */
      hash_univ_count--;
#ifdef ARCH_BIG_ENDIAN
      for (p = &Byte_u(obj, sizeof(double) - 1), i = sizeof(double);
           i > 0;
           p--, i--)
#else
      for (p = &Byte_u(obj, 0), i = sizeof(double);
           i > 0;
           p++, i--)
#endif
        Combine_small(*p);
      break;
    case Double_array_tag:
      hash_univ_count--;
      for (j = 0; j < Bosize_val(obj); j += sizeof(double)) {
#ifdef ARCH_BIG_ENDIAN
      for (p = &Byte_u(obj, j + sizeof(double) - 1), i = sizeof(double);
           i > 0;
           p--, i--)
#else
      for (p = &Byte_u(obj, j), i = sizeof(double);
           i > 0;
           p++, i--)
#endif
        Combine_small(*p);
      }
      break;
    case Abstract_tag:
      /* We don't know anything about the contents of the block.
         Better do nothing. */
      break;
    case Infix_tag:
      hash_aux(obj - Infix_offset_val(obj));
      break;
    case Forward_tag:
      obj = Forward_val (obj);
      goto again;
    case Object_tag:
      hash_univ_count--;
      Combine(Oid_val(obj));
      break;
    case Custom_tag:
      /* If no hashing function provided, do nothing */
      if (Custom_ops_val(obj)->hash != NULL) {
        hash_univ_count--;
        Combine(Custom_ops_val(obj)->hash(obj));
      }
      break;
    default:
      hash_univ_count--;
      Combine_small(tag);
      i = Wosize_val(obj);
      while (i != 0) {
        i--;
        hash_aux(Field(obj, i));
      }
      break;
    }
    return;
  }

  /* Otherwise, obj is a pointer outside the heap, to an object with
     a priori unknown structure. Use its physical address as hash key. */
  Combine((intnat) obj);
}
Ejemplo n.º 4
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)){
    if (Hp_val(v) < caml_young_ptr)
      printf("%lx, %lx\n", Hp_val(v), caml_young_ptr);
    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;
  }
}
Ejemplo n.º 5
0
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_in_value_area(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_in_value_area(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;
    }
    }
  }
  else if ((char *) v >= caml_code_area_start &&
Ejemplo n.º 6
0
static void extern_rec(value v)
{
  struct code_fragment * cf;
  struct extern_item * sp;
  sp = extern_stack;

  while(1) {
  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);
    goto next_item;
  }
  if (Is_in_value_area(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_in_value_area(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;
        continue;
      }
    }
    /* 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);
      }
      goto next_item;
    }
    /* 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);
      }
      goto next_item;
    }

    /* 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;
      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);
      /* Remember that we still have to serialize fields 1 ... sz - 1 */
      if (sz > 1) {
        sp++;
        if (sp >= extern_stack_limit) sp = extern_resize_stack(sp);
        sp->v = &Field(v,1);
        sp->count = sz-1;
      }
      /* Continue serialization with the first field */
      v = field0;
      continue;
    }
    }
  }
  else if ((cf = extern_find_code((char *) v)) != NULL) {
    if (!extern_closures)
      extern_invalid_argument("output_value: functional value");
    writecode32(CODE_CODEPOINTER, (char *) v - cf->code_start);
    writeblock((char *) cf->digest, 16);
  } else {
    extern_invalid_argument("output_value: abstract value (outside heap)");
  }
  next_item:
    /* Pop one more item to marshal, if any */
    if (sp == extern_stack) {
        /* We are done.   Cleanup the stack and leave the function */
        extern_free_stack();
        return;
    }
    v = *((sp->v)++);
    if (--(sp->count) == 0) sp--;
  }
Ejemplo n.º 7
0
static void extern_rec_r(CAML_R, value v)
{
  struct code_fragment * cf;
  struct extern_item * sp;
  sp = extern_stack;

  while(1) {
    //?????DUMP("QQQ 0x%lx, or %li ", v, v);
  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_r(ctx, CODE_INT8, n);
    } else if (n >= -(1 << 15) && n < (1 << 15)) {
      writecode16_r(ctx, CODE_INT16, n);
#ifdef ARCH_SIXTYFOUR
    } else if (n < -((intnat)1 << 31) || n >= ((intnat)1 << 31)) {
      writecode64_r(ctx, CODE_INT64, n);
#endif
    } else
      writecode32_r(ctx, CODE_INT32, n);
    goto next_item;
  }
  if (Is_in_value_area(v)) {
    header_t hd = Hd_val(v);
    tag_t tag = Tag_hd(hd);
    mlsize_t sz = Wosize_hd(hd);
    //DUMP("dumping %p, tag %i, size %i", (void*)v, (int)tag, (int)sz); // !!!!!!!!!!!!!!!
    if (tag == Forward_tag) {
      value f = Forward_val (v);
      if (Is_block (f)
          && (!Is_in_value_area(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;
        continue;
      }
    }
    /* 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_r(ctx, CODE_BLOCK32, hd);
      }
      goto next_item;
    }
    /* Check if already seen */
    if (Color_hd(hd) == Caml_blue) {
      uintnat d = obj_counter - (uintnat) Field(v, 0);
      if (d < 0x100) {
        writecode8_r(ctx, CODE_SHARED8, d);
      } else if (d < 0x10000) {
        writecode16_r(ctx, CODE_SHARED16, d);
      } else {
        writecode32_r(ctx, CODE_SHARED32, d);
      }
      goto next_item;
    }

    /* 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_r(ctx, CODE_STRING8, len);
      } else {
        writecode32_r(ctx, CODE_STRING32, len);
      }
      writeblock_r(ctx, String_val(v), len);
      size_32 += 1 + (len + 4) / 4;
      size_64 += 1 + (len + 8) / 8;
      extern_record_location_r(ctx, v);
      break;
    }
    case Double_tag: {
      if (sizeof(double) != 8)
        extern_invalid_argument_r(ctx, "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_r(ctx,v);
      break;
    }
    case Double_array_tag: {
      mlsize_t nfloats;
      if (sizeof(double) != 8)
        extern_invalid_argument_r(ctx, "output_value: non-standard floats");
      nfloats = Wosize_val(v) / Double_wosize;
      if (nfloats < 0x100) {
        writecode8_r(ctx, CODE_DOUBLE_ARRAY8_NATIVE, nfloats);
      } else {
        writecode32_r(ctx, CODE_DOUBLE_ARRAY32_NATIVE, nfloats);
      }
      writeblock_float8((double *) v, nfloats);
      size_32 += 1 + nfloats * 2;
      size_64 += 1 + nfloats;
      extern_record_location_r(ctx, v);
      break;
    }
    case Abstract_tag:
      extern_invalid_argument_r(ctx, "output_value: abstract value (Abstract)");
      break;
    case Infix_tag:
      writecode32_r(ctx,CODE_INFIXPOINTER, Infix_offset_hd(hd));
      extern_rec_r(ctx, 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);
      //printf("[object at %p, which is a %s custom: BEGIN\n", (void*)v, Custom_ops_val(v)->identifier);
      if(extern_cross_context){
        //printf("About the object at %p, which is a %s custom: USING a cross-context serializer\n", (void*)v, Custom_ops_val(v)->identifier);
        serialize = Custom_ops_val(v)->cross_context_serialize;
      }
      else{
        //printf("About the object at %p, which is a %s custom: NOT using a cross-context serializer\n", (void*)v, Custom_ops_val(v)->identifier);
        serialize = Custom_ops_val(v)->serialize;
      }
      //printf("Still alive 100\n");
      if (serialize == NULL){
        //////
        //struct custom_operations *o = Custom_ops_val(v);
        //printf("About the object at %p, which is a %s custom\n", (void*)v, Custom_ops_val(v)->identifier); volatile int a = 1; a /= 0;
        ///////////
        extern_invalid_argument_r(ctx, "output_value: abstract value (Custom)");
      }
      //printf("Still alive 200\n");
      Write(CODE_CUSTOM);
      //printf("Still alive 300\n");
      writeblock_r(ctx, ident, strlen(ident) + 1);
      //printf("Still alive 400\n");
      serialize(v, &sz_32, &sz_64);
      //printf("Still alive 500\n");
      size_32 += 2 + ((sz_32 + 3) >> 2);  /* header + ops + data */
      size_64 += 2 + ((sz_64 + 7) >> 3);
      //printf("Still alive 600\n");
      extern_record_location_r(ctx,v); // This temporarily breaks the object, by replacing it with a forwarding pointer
      //printf("object at %p, which is a custom: END\n", (void*)v);
      break;
    }
    default: {
      value field0;
      if (tag < 16 && sz < 8) {
        Write(PREFIX_SMALL_BLOCK + tag + (sz << 4));
#ifdef ARCH_SIXTYFOUR
      } else if (hd >= ((uintnat)1 << 32)) {
        writecode64_r(ctx, CODE_BLOCK64, Whitehd_hd (hd));
#endif
      } else {
        writecode32_r(ctx, CODE_BLOCK32, Whitehd_hd (hd));
      }
      size_32 += 1 + sz;
      size_64 += 1 + sz;
      field0 = Field(v, 0);
      extern_record_location_r(ctx, v);
      /* Remember that we still have to serialize fields 1 ... sz - 1 */
      if (sz > 1) {
        sp++;
        if (sp >= extern_stack_limit) sp = extern_resize_stack_r(ctx, sp);
        sp->v = &Field(v,1);
        sp->count = sz-1;
      }
      /* Continue serialization with the first field */
      v = field0;
      continue;
    }
    }
  }
  else if ((cf = extern_find_code_r(ctx, (char *) v)) != NULL) {
    if (!extern_closures){
      extern_invalid_argument_r(ctx, "output_value: functional value"); // FIXME: this is the correct version. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      //DUMP("output_value: functional value"); {volatile int a = 1; a /= 0;}
      }
    //fprintf(stderr, "ZZZZ dumping a code pointer: BEGIN\n");
    //DUMP("dumping a code pointer 0x%lx, or %li; code start is at %p", v, v, cf->code_start);
    writecode32_r(ctx, CODE_CODEPOINTER, (char *) v - cf->code_start);
    writeblock_r(ctx, (char *) cf->digest, 16);
    //dump_digest(cf->digest);
    //fprintf(stderr, "ZZZZ dumping a code pointer: END\n");
  } else {
    if(extern_cross_context){
      fprintf(stderr, "ZZZZ working on the external pointer: %p, which is to say %li [cf is %p]\n", (void*)v, (long)v, cf);
      //fprintf(stderr, "ZZZZ I'm doing a horrible, horrible thing: serializing the pointer as a tagged 0.\n");
      DUMP("about to crash in the strange case I'm debugging");
      /* DUMP("the object is 0x%lx, or %li ", v, v); */
      /* DUMP("probably crashing now"); */
      /* DUMP("tag is %i", (int)Tag_val(v)); */
      /* DUMP("size is %i", (int)Wosize_val(v)); */
      //volatile int a = 1; a /= 0;
      //extern_rec_r(ctx, Val_int(0));
      /* fprintf(stderr, "ZZZZ [This is probably wrong: I'm marshalling an out-of-heap pointer as an int64]\n"); */
      /* writecode64_r(ctx, CODE_INT64, (v << 1) | 1); */
      extern_invalid_argument_r(ctx, "output_value: abstract value (outside heap) [FIXME: implement]");
    }
    else
      extern_invalid_argument_r(ctx, "output_value: abstract value (outside heap)");
  }
  next_item:
    /* Pop one more item to marshal, if any */
    if (sp == extern_stack) {
        /* We are done.   Cleanup the stack and leave the function */
        extern_free_stack_r(ctx);
        return;
    }
    v = *((sp->v)++);
    if (--(sp->count) == 0) sp--;
  }