CAMLexport value caml_copy_double(double d)
{
value res;
#define Setup_for_gc
#define Restore_after_gc
Alloc_small(res, Double_wosize, Double_tag);
#undef Setup_for_gc
#undef Restore_after_gc
Store_double_val(res, d);
return res;
}
CAMLprim value caml_array_unsafe_get_float(value array, value index)
{
double d;
value res;
d = Double_field(array, Long_val(index));
#define Setup_for_gc
#define Restore_after_gc
Alloc_small(res, Double_wosize, Double_tag);
#undef Setup_for_gc
#undef Restore_after_gc
Store_double_val(res, d);
return res;
}
CAMLprim value caml_array_get_float(value array, value index)
{
intnat idx = Long_val(index);
double d;
value res;
if (idx < 0 || idx >= Wosize_val(array) / Double_wosize)
caml_array_bound_error();
d = Double_field(array, idx);
#define Setup_for_gc
#define Restore_after_gc
Alloc_small(res, Double_wosize, Double_tag);
#undef Setup_for_gc
#undef Restore_after_gc
Store_double_val(res, d);
return res;
}
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;
}
