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);
}
}
}
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);
}
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);
}
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;
}
}
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 &&
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--;
}
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--;
}