static void pd_check(ProcDict *pd)
{
unsigned int i;
Uint num;
if (pd == NULL)
return;
ASSERT(pd->size >= pd->used);
ASSERT(HASH_RANGE(pd) <= MAX_HASH);
for (i = 0, num = 0; i < pd->used; ++i) {
Eterm t = pd->data[i];
if (is_nil(t)) {
continue;
} else if (is_tuple(t)) {
++num;
ASSERT(arityval(*tuple_val(t)) == 2);
continue;
} else if (is_list(t)) {
while (t != NIL) {
++num;
ASSERT(is_tuple(TCAR(t)));
ASSERT(arityval(*(tuple_val(TCAR(t)))) == 2);
t = TCDR(t);
}
continue;
} else {
erl_exit(1,
"Found tag 0x%08x in process dictionary at position %d",
(unsigned long) t, (int) i);
}
}
ASSERT(num == pd->numElements);
ASSERT(pd->splitPosition <= pd->homeSize);
}
static void print_heap(Eterm *pos, Eterm *end)
{
printf("From: 0x%0*lx to 0x%0*lx\n\r",
2*(int)sizeof(long), (unsigned long)pos,
2*(int)sizeof(long), (unsigned long)end);
printf(" | H E A P |\r\n");
printf(" | %*s | %*s |\r\n",
2+2*(int)sizeof(long), "Address",
2+2*(int)sizeof(long), "Contents");
printf(" |%s|%s|\r\n", dashes, dashes);
while (pos < end) {
Eterm val = pos[0];
printf(" | 0x%0*lx | 0x%0*lx | ",
2*(int)sizeof(long), (unsigned long)pos,
2*(int)sizeof(long), (unsigned long)val);
++pos;
if (is_arity_value(val))
printf("Arity(%lu)", arityval(val));
else if (is_thing(val)) {
unsigned int ari = thing_arityval(val);
printf("Thing Arity(%u) Tag(%lu)", ari, thing_subtag(val));
while (ari) {
printf("\r\n | 0x%0*lx | 0x%0*lx | THING",
2*(int)sizeof(long), (unsigned long)pos,
2*(int)sizeof(long), (unsigned long)*pos);
++pos;
--ari;
}
} else
erts_printf("%.30T", val);
printf("\r\n");
}
printf(" |%s|%s|\r\n", dashes, dashes);
}
int enif_get_tuple(ErlNifEnv* env, Eterm tpl, int* arity, const Eterm** array)
{
Eterm* ptr;
if (is_not_tuple(tpl)) {
return 0;
}
ptr = tuple_val(tpl);
*arity = arityval(*ptr);
*array = ptr+1;
return 1;
}
BIF_RETTYPE erts_internal_check_process_code_2(BIF_ALIST_2)
{
int reds = 0;
Eterm res;
Eterm olist = BIF_ARG_2;
int allow_gc = 1;
if (is_not_atom(BIF_ARG_1))
goto badarg;
while (is_list(olist)) {
Eterm *lp = list_val(olist);
Eterm opt = CAR(lp);
if (is_tuple(opt)) {
Eterm* tp = tuple_val(opt);
switch (arityval(tp[0])) {
case 2:
switch (tp[1]) {
case am_allow_gc:
switch (tp[2]) {
case am_false:
allow_gc = 0;
break;
case am_true:
allow_gc = 1;
break;
default:
goto badarg;
}
break;
default:
goto badarg;
}
break;
default:
goto badarg;
}
}
else
goto badarg;
olist = CDR(lp);
}
if (is_not_nil(olist))
goto badarg;
res = erts_check_process_code(BIF_P, BIF_ARG_1, allow_gc, &reds);
ASSERT(is_value(res));
BIF_RET2(res, reds);
badarg:
BIF_ERROR(BIF_P, BADARG);
}
/*
* Record test cannot actually be a bif. The epp processor is involved in
* the real guard test, we have to add one more parameter, the
* return value of record_info(size, Rec), which is the arity of the TUPLE.
* his may seem awkward when applied from the shell, where the plain
* tuple test is more understandable, I think...
*/
BIF_RETTYPE is_record_3(BIF_ALIST_3)
{
Eterm *t;
if (is_not_atom(BIF_ARG_2) || is_not_small(BIF_ARG_3)) {
BIF_ERROR(BIF_P, BADARG);
}
if (is_tuple(BIF_ARG_1) &&
arityval(*(t = tuple_val(BIF_ARG_1))) == signed_val(BIF_ARG_3)
&& t[1] == BIF_ARG_2) {
BIF_RET(am_true);
}
BIF_RET(am_false);
}
/*
* print_tagged_memory will print contents of given memory area and
* display it as if it was tagged Erlang terms (which it hopefully
* is). This function knows about forwarding pointers to be able to
* print a heap during garbage collection. erts_printf("%T",val)
* do not know about forwarding pointers though, so it will still
* crash if they are encoutered...
*/
void print_tagged_memory(Eterm *pos, Eterm *end)
{
erts_printf("+-%s-+-%s-+\n",dashes,dashes);
erts_printf("| 0x%0*lx - 0x%0*lx |\n",
PTR_SIZE,(unsigned long)pos,
PTR_SIZE,(unsigned long)(end - 1));
erts_printf("| %-*s | %-*s |\n",PTR_SIZE,"Address",PTR_SIZE,"Contents");
erts_printf("|-%s-|-%s-|\n",dashes,dashes);
while( pos < end ) {
Eterm val = pos[0];
erts_printf("| 0x%0*lx | 0x%0*lx | ",
PTR_SIZE,(unsigned long)pos, PTR_SIZE,(unsigned long)val);
++pos;
if( is_arity_value(val) ) {
erts_printf("Arity(%lu)", arityval(val));
} else if( is_thing(val) ) {
unsigned int ari = thing_arityval(val);
erts_printf("Thing Arity(%u) Tag(%lu)", ari, thing_subtag(val));
while( ari ) {
erts_printf("\n| 0x%0*lx | 0x%0*lx | THING",
PTR_SIZE, (unsigned long)pos,
PTR_SIZE, (unsigned long)*pos);
++pos;
--ari;
}
} else {
switch (primary_tag(val)) {
case TAG_PRIMARY_BOXED:
if (!is_header(*boxed_val(val))) {
erts_printf("Moved -> 0x%0*lx\n",PTR_SIZE,
(unsigned long)*boxed_val(val));
continue;
}
break;
case TAG_PRIMARY_LIST:
if (is_non_value(*list_val(val))) {
erts_printf("Moved -> 0x%0*lx\n",PTR_SIZE,
(unsigned long)*(list_val(val) + 1));
continue;
}
break;
}
erts_printf("%.30T", val);
}
erts_printf("\n");
}
erts_printf("+-%s-+-%s-+\n",dashes,dashes);
}
/*
* The compiler usually translates calls to is_record/2 to more primitive
* operations. In some cases this is not possible. We'll need to implement
* a weak version of is_record/2 as BIF (the size of the record cannot
* be verified).
*/
BIF_RETTYPE is_record_2(BIF_ALIST_2)
{
Eterm *t;
if (is_not_atom(BIF_ARG_2)) {
BIF_ERROR(BIF_P, BADARG);
}
if (is_tuple(BIF_ARG_1) &&
arityval(*(t = tuple_val(BIF_ARG_1))) >= 1 &&
t[1] == BIF_ARG_2) {
BIF_RET(am_true);
}
BIF_RET(am_false);
}
BIF_RETTYPE size_1(BIF_ALIST_1)
{
if (is_tuple(BIF_ARG_1)) {
Eterm* tupleptr = tuple_val(BIF_ARG_1);
BIF_RET(make_small(arityval(*tupleptr)));
} else if (is_binary(BIF_ARG_1)) {
Uint sz = binary_size(BIF_ARG_1);
if (IS_USMALL(0, sz)) {
return make_small(sz);
} else {
Eterm* hp = HAlloc(BIF_P, BIG_UINT_HEAP_SIZE);
BIF_RET(uint_to_big(sz, hp));
}
}
BIF_ERROR(BIF_P, BADARG);
}
BIF_RETTYPE hipe_bifs_show_term_1(BIF_ALIST_1)
{
Eterm obj = BIF_ARG_1;
printf("0x%0*lx\r\n", 2*(int)sizeof(long), obj);
do {
Eterm *objp;
int i, ary;
if (is_list(obj)) {
objp = list_val(obj);
ary = 2;
} else if (is_boxed(obj)) {
Eterm header;
objp = boxed_val(obj);
header = objp[0];
if (is_thing(header))
ary = thing_arityval(header);
else if (is_arity_value(header))
ary = arityval(header);
else {
printf("bad header %#lx\r\n", header);
break;
}
ary += 1;
} else
break;
for (i = 0; i < ary; ++i)
printf("0x%0*lx: 0x%0*lx\r\n",
2*(int)sizeof(long), (unsigned long)&objp[i],
2*(int)sizeof(long), objp[i]);
} while (0);
erts_printf("%T", obj);
printf("\r\n");
BIF_RET(am_true);
}
Eterm copy_struct(Eterm obj, Uint sz, Eterm** hpp, ErlOffHeap* off_heap)
#endif
{
char* hstart;
Uint hsize;
Eterm* htop;
Eterm* hbot;
Eterm* hp;
Eterm* objp;
Eterm* tp;
Eterm res;
Eterm elem;
Eterm* tailp;
Eterm* argp;
Eterm* const_tuple;
Eterm hdr;
int i;
#ifdef DEBUG
Eterm org_obj = obj;
Uint org_sz = sz;
#endif
if (IS_CONST(obj))
return obj;
DTRACE1(copy_struct, (int32_t)sz);
hp = htop = *hpp;
hbot = htop + sz;
hstart = (char *)htop;
hsize = (char*) hbot - hstart;
const_tuple = 0;
/* Copy the object onto the heap */
switch (primary_tag(obj)) {
case TAG_PRIMARY_LIST:
argp = &res;
objp = list_val_rel(obj,src_base);
goto L_copy_list;
case TAG_PRIMARY_BOXED: argp = &res; goto L_copy_boxed;
default:
erl_exit(ERTS_ABORT_EXIT,
"%s, line %d: Internal error in copy_struct: 0x%08x\n",
__FILE__, __LINE__,obj);
}
L_copy:
while (hp != htop) {
obj = *hp;
switch (primary_tag(obj)) {
case TAG_PRIMARY_IMMED1:
hp++;
break;
case TAG_PRIMARY_LIST:
objp = list_val_rel(obj,src_base);
#if !HALFWORD_HEAP || defined(DEBUG)
if (in_area(objp,hstart,hsize)) {
ASSERT(!HALFWORD_HEAP);
hp++;
break;
}
#endif
argp = hp++;
/* Fall through */
L_copy_list:
tailp = argp;
for (;;) {
tp = tailp;
elem = CAR(objp);
if (IS_CONST(elem)) {
hbot -= 2;
CAR(hbot) = elem;
tailp = &CDR(hbot);
}
else {
CAR(htop) = elem;
#if HALFWORD_HEAP
CDR(htop) = CDR(objp);
*tailp = make_list_rel(htop,dst_base);
htop += 2;
goto L_copy;
#else
tailp = &CDR(htop);
htop += 2;
#endif
}
ASSERT(!HALFWORD_HEAP || tp < hp || tp >= hbot);
*tp = make_list_rel(tailp - 1, dst_base);
obj = CDR(objp);
if (!is_list(obj)) {
break;
}
objp = list_val_rel(obj,src_base);
}
switch (primary_tag(obj)) {
case TAG_PRIMARY_IMMED1: *tailp = obj; goto L_copy;
case TAG_PRIMARY_BOXED: argp = tailp; goto L_copy_boxed;
default:
erl_exit(ERTS_ABORT_EXIT,
"%s, line %d: Internal error in copy_struct: 0x%08x\n",
__FILE__, __LINE__,obj);
}
case TAG_PRIMARY_BOXED:
#if !HALFWORD_HEAP || defined(DEBUG)
if (in_area(boxed_val_rel(obj,src_base),hstart,hsize)) {
ASSERT(!HALFWORD_HEAP);
hp++;
break;
}
#endif
argp = hp++;
L_copy_boxed:
objp = boxed_val_rel(obj, src_base);
hdr = *objp;
switch (hdr & _TAG_HEADER_MASK) {
case ARITYVAL_SUBTAG:
{
int const_flag = 1; /* assume constant tuple */
i = arityval(hdr);
*argp = make_tuple_rel(htop, dst_base);
tp = htop; /* tp is pointer to new arity value */
*htop++ = *objp++; /* copy arity value */
while (i--) {
elem = *objp++;
if (!IS_CONST(elem)) {
const_flag = 0;
}
*htop++ = elem;
}
if (const_flag) {
const_tuple = tp; /* this is the latest const_tuple */
}
}
break;
case REFC_BINARY_SUBTAG:
{
ProcBin* pb;
pb = (ProcBin *) objp;
if (pb->flags) {
erts_emasculate_writable_binary(pb);
}
i = thing_arityval(*objp) + 1;
hbot -= i;
tp = hbot;
while (i--) {
*tp++ = *objp++;
}
*argp = make_binary_rel(hbot, dst_base);
pb = (ProcBin*) hbot;
erts_refc_inc(&pb->val->refc, 2);
pb->next = off_heap->first;
pb->flags = 0;
off_heap->first = (struct erl_off_heap_header*) pb;
OH_OVERHEAD(off_heap, pb->size / sizeof(Eterm));
}
break;
case SUB_BINARY_SUBTAG:
{
ErlSubBin* sb = (ErlSubBin *) objp;
Eterm real_bin = sb->orig;
Uint bit_offset = sb->bitoffs;
Uint bit_size = sb -> bitsize;
Uint offset = sb->offs;
size_t size = sb->size;
Uint extra_bytes;
Uint real_size;
if ((bit_size + bit_offset) > 8) {
extra_bytes = 2;
} else if ((bit_size + bit_offset) > 0) {
extra_bytes = 1;
} else {
extra_bytes = 0;
}
real_size = size+extra_bytes;
objp = binary_val_rel(real_bin,src_base);
if (thing_subtag(*objp) == HEAP_BINARY_SUBTAG) {
ErlHeapBin* from = (ErlHeapBin *) objp;
ErlHeapBin* to;
i = heap_bin_size(real_size);
hbot -= i;
to = (ErlHeapBin *) hbot;
to->thing_word = header_heap_bin(real_size);
to->size = real_size;
sys_memcpy(to->data, ((byte *)from->data)+offset, real_size);
} else {
ProcBin* from = (ProcBin *) objp;
ProcBin* to;
ASSERT(thing_subtag(*objp) == REFC_BINARY_SUBTAG);
if (from->flags) {
erts_emasculate_writable_binary(from);
}
hbot -= PROC_BIN_SIZE;
to = (ProcBin *) hbot;
to->thing_word = HEADER_PROC_BIN;
to->size = real_size;
to->val = from->val;
erts_refc_inc(&to->val->refc, 2);
to->bytes = from->bytes + offset;
to->next = off_heap->first;
to->flags = 0;
off_heap->first = (struct erl_off_heap_header*) to;
OH_OVERHEAD(off_heap, to->size / sizeof(Eterm));
}
*argp = make_binary_rel(hbot, dst_base);
if (extra_bytes != 0) {
ErlSubBin* res;
hbot -= ERL_SUB_BIN_SIZE;
res = (ErlSubBin *) hbot;
res->thing_word = HEADER_SUB_BIN;
res->size = size;
res->bitsize = bit_size;
res->bitoffs = bit_offset;
res->offs = 0;
res->is_writable = 0;
res->orig = *argp;
*argp = make_binary_rel(hbot, dst_base);
}
break;
}
break;
case FUN_SUBTAG:
{
ErlFunThing* funp = (ErlFunThing *) objp;
i = thing_arityval(hdr) + 2 + funp->num_free;
tp = htop;
while (i--) {
*htop++ = *objp++;
}
funp = (ErlFunThing *) tp;
funp->next = off_heap->first;
off_heap->first = (struct erl_off_heap_header*) funp;
erts_refc_inc(&funp->fe->refc, 2);
*argp = make_fun_rel(tp, dst_base);
}
break;
case EXTERNAL_PID_SUBTAG:
case EXTERNAL_PORT_SUBTAG:
case EXTERNAL_REF_SUBTAG:
{
ExternalThing *etp = (ExternalThing *) htop;
i = thing_arityval(hdr) + 1;
tp = htop;
while (i--) {
*htop++ = *objp++;
}
etp->next = off_heap->first;
off_heap->first = (struct erl_off_heap_header*)etp;
erts_refc_inc(&etp->node->refc, 2);
*argp = make_external_rel(tp, dst_base);
}
break;
case MAP_SUBTAG:
tp = htop;
switch (MAP_HEADER_TYPE(hdr)) {
case MAP_HEADER_TAG_FLATMAP_HEAD :
i = flatmap_get_size(objp) + 3;
*argp = make_flatmap_rel(htop, dst_base);
while (i--) {
*htop++ = *objp++;
}
break;
case MAP_HEADER_TAG_HAMT_HEAD_BITMAP :
case MAP_HEADER_TAG_HAMT_HEAD_ARRAY :
*htop++ = *objp++;
case MAP_HEADER_TAG_HAMT_NODE_BITMAP :
i = 1 + hashmap_bitcount(MAP_HEADER_VAL(hdr));
while (i--) { *htop++ = *objp++; }
*argp = make_hashmap_rel(tp, dst_base);
break;
default:
erl_exit(ERTS_ABORT_EXIT, "copy_struct: bad hashmap type %d\n", MAP_HEADER_TYPE(hdr));
}
break;
case BIN_MATCHSTATE_SUBTAG:
erl_exit(ERTS_ABORT_EXIT,
"copy_struct: matchstate term not allowed");
default:
i = thing_arityval(hdr)+1;
hbot -= i;
tp = hbot;
*argp = make_boxed_rel(hbot, dst_base);
while (i--) {
*tp++ = *objp++;
}
}
break;
case TAG_PRIMARY_HEADER:
if (header_is_thing(obj) || hp == const_tuple) {
hp += header_arity(obj) + 1;
} else {
hp++;
}
break;
}
}
#ifdef DEBUG
if (htop != hbot)
erl_exit(ERTS_ABORT_EXIT,
"Internal error in copy_struct() when copying %T:"
" htop=%p != hbot=%p (sz=%beu)\n",
org_obj, htop, hbot, org_sz);
#else
if (htop > hbot) {
erl_exit(ERTS_ABORT_EXIT,
"Internal error in copy_struct(): htop, hbot overrun\n");
}
#endif
*hpp = (Eterm *) (hstart+hsize);
return res;
}
static int
pdisplay1(fmtfn_t to, void *to_arg, Process* p, Eterm obj)
{
int i, k;
Eterm* nobj;
if (dcount-- <= 0)
return(1);
if (is_CP(obj)) {
erts_print(to, to_arg, "<cp/header:%0*lX",PTR_SIZE,obj);
return 0;
}
switch (tag_val_def(obj)) {
case NIL_DEF:
erts_print(to, to_arg, "[]");
break;
case ATOM_DEF:
erts_print(to, to_arg, "%T", obj);
break;
case SMALL_DEF:
erts_print(to, to_arg, "%ld", signed_val(obj));
break;
case BIG_DEF:
nobj = big_val(obj);
if (!IN_HEAP(p, nobj)) {
erts_print(to, to_arg, "#<bad big %X>#", obj);
return 1;
}
i = BIG_SIZE(nobj);
if (BIG_SIGN(nobj))
erts_print(to, to_arg, "-#integer(%d) = {", i);
else
erts_print(to, to_arg, "#integer(%d) = {", i);
erts_print(to, to_arg, "%d", BIG_DIGIT(nobj, 0));
for (k = 1; k < i; k++)
erts_print(to, to_arg, ",%d", BIG_DIGIT(nobj, k));
erts_putc(to, to_arg, '}');
break;
case REF_DEF:
case EXTERNAL_REF_DEF: {
Uint32 *ref_num;
erts_print(to, to_arg, "#Ref<%lu", ref_channel_no(obj));
ref_num = ref_numbers(obj);
for (i = ref_no_numbers(obj)-1; i >= 0; i--)
erts_print(to, to_arg, ",%lu", ref_num[i]);
erts_print(to, to_arg, ">");
break;
}
case PID_DEF:
case EXTERNAL_PID_DEF:
erts_print(to, to_arg, "<%lu.%lu.%lu>",
pid_channel_no(obj),
pid_number(obj),
pid_serial(obj));
break;
case PORT_DEF:
case EXTERNAL_PORT_DEF:
erts_print(to, to_arg, "#Port<%lu.%lu>",
port_channel_no(obj),
port_number(obj));
break;
case LIST_DEF:
erts_putc(to, to_arg, '[');
nobj = list_val(obj);
while (1) {
if (!IN_HEAP(p, nobj)) {
erts_print(to, to_arg, "#<bad list %X>", obj);
return 1;
}
if (pdisplay1(to, to_arg, p, *nobj++) != 0)
return(1);
if (is_not_list(*nobj))
break;
erts_putc(to, to_arg, ',');
nobj = list_val(*nobj);
}
if (is_not_nil(*nobj)) {
erts_putc(to, to_arg, '|');
if (pdisplay1(to, to_arg, p, *nobj) != 0)
return(1);
}
erts_putc(to, to_arg, ']');
break;
case TUPLE_DEF:
nobj = tuple_val(obj); /* pointer to arity */
i = arityval(*nobj); /* arity */
erts_putc(to, to_arg, '{');
while (i--) {
if (pdisplay1(to, to_arg, p, *++nobj) != 0) return(1);
if (i >= 1) erts_putc(to, to_arg, ',');
}
erts_putc(to, to_arg, '}');
break;
case FLOAT_DEF: {
FloatDef ff;
GET_DOUBLE(obj, ff);
erts_print(to, to_arg, "%.20e", ff.fd);
}
break;
case BINARY_DEF:
erts_print(to, to_arg, "#Bin");
break;
case MATCHSTATE_DEF:
erts_print(to, to_arg, "#Matchstate");
break;
default:
erts_print(to, to_arg, "unknown object %x", obj);
}
return(0);
}
static Eterm
reference_table_term(Uint **hpp, Uint *szp)
{
#undef MK_2TUP
#undef MK_3TUP
#undef MK_CONS
#undef MK_UINT
#define MK_2TUP(E1, E2) erts_bld_tuple(hpp, szp, 2, (E1), (E2))
#define MK_3TUP(E1, E2, E3) erts_bld_tuple(hpp, szp, 3, (E1), (E2), (E3))
#define MK_CONS(CAR, CDR) erts_bld_cons(hpp, szp, (CAR), (CDR))
#define MK_UINT(UI) erts_bld_uint(hpp, szp, (UI))
int i;
Eterm tup;
Eterm tup2;
Eterm nl = NIL;
Eterm dl = NIL;
Eterm nrid;
for(i = 0; i < no_referred_nodes; i++) {
NodeReferrer *nrp;
Eterm nril = NIL;
for(nrp = referred_nodes[i].referrers; nrp; nrp = nrp->next) {
Eterm nrl = NIL;
/* NodeReferenceList = [{ReferenceType,References}] */
if(nrp->heap_ref) {
tup = MK_2TUP(AM_heap, MK_UINT(nrp->heap_ref));
nrl = MK_CONS(tup, nrl);
}
if(nrp->link_ref) {
tup = MK_2TUP(AM_link, MK_UINT(nrp->link_ref));
nrl = MK_CONS(tup, nrl);
}
if(nrp->monitor_ref) {
tup = MK_2TUP(AM_monitor, MK_UINT(nrp->monitor_ref));
nrl = MK_CONS(tup, nrl);
}
if(nrp->ets_ref) {
tup = MK_2TUP(AM_ets, MK_UINT(nrp->ets_ref));
nrl = MK_CONS(tup, nrl);
}
if(nrp->bin_ref) {
tup = MK_2TUP(AM_binary, MK_UINT(nrp->bin_ref));
nrl = MK_CONS(tup, nrl);
}
if(nrp->timer_ref) {
tup = MK_2TUP(AM_timer, MK_UINT(nrp->timer_ref));
nrl = MK_CONS(tup, nrl);
}
if(nrp->system_ref) {
tup = MK_2TUP(AM_system, MK_UINT(nrp->system_ref));
nrl = MK_CONS(tup, nrl);
}
nrid = nrp->id;
if (!IS_CONST(nrp->id)) {
Uint nrid_sz = size_object(nrp->id);
if (szp)
*szp += nrid_sz;
if (hpp)
nrid = copy_struct(nrp->id, nrid_sz, hpp, NULL);
}
if (is_internal_pid(nrid) || nrid == am_error_logger) {
ASSERT(!nrp->ets_ref && !nrp->bin_ref && !nrp->system_ref);
tup = MK_2TUP(AM_process, nrid);
}
else if (is_tuple(nrid)) {
Eterm *t;
ASSERT(!nrp->ets_ref && !nrp->bin_ref);
t = tuple_val(nrid);
ASSERT(2 == arityval(t[0]));
tup = MK_2TUP(t[1], t[2]);
}
else if(is_internal_port(nrid)) {
ASSERT(!nrp->heap_ref && !nrp->ets_ref && !nrp->bin_ref
&& !nrp->timer_ref && !nrp->system_ref);
tup = MK_2TUP(AM_port, nrid);
}
else if(nrp->ets_ref) {
ASSERT(!nrp->heap_ref && !nrp->link_ref &&
!nrp->monitor_ref && !nrp->bin_ref
&& !nrp->timer_ref && !nrp->system_ref);
tup = MK_2TUP(AM_ets, nrid);
}
else if(nrp->bin_ref) {
ASSERT(is_small(nrid) || is_big(nrid));
ASSERT(!nrp->heap_ref && !nrp->ets_ref && !nrp->link_ref &&
!nrp->monitor_ref && !nrp->timer_ref
&& !nrp->system_ref);
tup = MK_2TUP(AM_match_spec, nrid);
}
else {
ASSERT(!nrp->heap_ref && !nrp->ets_ref && !nrp->bin_ref);
ASSERT(is_atom(nrid));
tup = MK_2TUP(AM_dist, nrid);
}
tup = MK_2TUP(tup, nrl);
/* NodeReferenceIdList = [{{ReferrerType, ID}, NodeReferenceList}] */
nril = MK_CONS(tup, nril);
}
/* NodeList = [{{Node, Creation}, Refc, NodeReferenceIdList}] */
tup = MK_2TUP(referred_nodes[i].node->sysname,
MK_UINT(referred_nodes[i].node->creation));
tup = MK_3TUP(tup, MK_UINT(erts_refc_read(&referred_nodes[i].node->refc, 1)), nril);
nl = MK_CONS(tup, nl);
}
for(i = 0; i < no_referred_dists; i++) {
DistReferrer *drp;
Eterm dril = NIL;
for(drp = referred_dists[i].referrers; drp; drp = drp->next) {
Eterm drl = NIL;
/* DistReferenceList = [{ReferenceType,References}] */
if(drp->node_ref) {
tup = MK_2TUP(AM_node, MK_UINT(drp->node_ref));
drl = MK_CONS(tup, drl);
}
if(drp->ctrl_ref) {
tup = MK_2TUP(AM_control, MK_UINT(drp->ctrl_ref));
drl = MK_CONS(tup, drl);
}
if (is_internal_pid(drp->id)) {
ASSERT(drp->ctrl_ref && !drp->node_ref);
tup = MK_2TUP(AM_process, drp->id);
}
else if(is_internal_port(drp->id)) {
ASSERT(drp->ctrl_ref && !drp->node_ref);
tup = MK_2TUP(AM_port, drp->id);
}
else {
ASSERT(!drp->ctrl_ref && drp->node_ref);
ASSERT(is_atom(drp->id));
tup = MK_2TUP(drp->id, MK_UINT(drp->creation));
tup = MK_2TUP(AM_node, tup);
}
tup = MK_2TUP(tup, drl);
/* DistReferenceIdList =
[{{ReferrerType, ID}, DistReferenceList}] */
dril = MK_CONS(tup, dril);
}
/* DistList = [{Dist, Refc, ReferenceIdList}] */
tup = MK_3TUP(referred_dists[i].dist->sysname,
MK_UINT(erts_refc_read(&referred_dists[i].dist->refc, 1)),
dril);
dl = MK_CONS(tup, dl);
}
/* {{node_references, NodeList}, {dist_references, DistList}} */
tup = MK_2TUP(AM_node_references, nl);
tup2 = MK_2TUP(AM_dist_references, dl);
tup = MK_2TUP(tup, tup2);
return tup;
#undef MK_2TUP
#undef MK_3TUP
#undef MK_CONS
#undef MK_UINT
}
static Eterm
keyfind(int Bif, Process* p, Eterm Key, Eterm Pos, Eterm List)
{
int max_iter = 10 * CONTEXT_REDS;
Sint pos;
Eterm term;
if (!is_small(Pos) || (pos = signed_val(Pos)) < 1) {
BIF_ERROR(p, BADARG);
}
if (is_small(Key)) {
double float_key = (double) signed_val(Key);
while (is_list(List)) {
if (--max_iter < 0) {
BUMP_ALL_REDS(p);
BIF_TRAP3(bif_export[Bif], p, Key, Pos, List);
}
term = CAR(list_val(List));
List = CDR(list_val(List));
if (is_tuple(term)) {
Eterm *tuple_ptr = tuple_val(term);
if (pos <= arityval(*tuple_ptr)) {
Eterm element = tuple_ptr[pos];
if (Key == element) {
return term;
} else if (is_float(element)) {
FloatDef f;
GET_DOUBLE(element, f);
if (f.fd == float_key) {
return term;
}
}
}
}
}
} else if (is_immed(Key)) {
while (is_list(List)) {
if (--max_iter < 0) {
BUMP_ALL_REDS(p);
BIF_TRAP3(bif_export[Bif], p, Key, Pos, List);
}
term = CAR(list_val(List));
List = CDR(list_val(List));
if (is_tuple(term)) {
Eterm *tuple_ptr = tuple_val(term);
if (pos <= arityval(*tuple_ptr)) {
Eterm element = tuple_ptr[pos];
if (Key == element) {
return term;
}
}
}
}
} else {
while (is_list(List)) {
if (--max_iter < 0) {
BUMP_ALL_REDS(p);
BIF_TRAP3(bif_export[Bif], p, Key, Pos, List);
}
term = CAR(list_val(List));
List = CDR(list_val(List));
if (is_tuple(term)) {
Eterm *tuple_ptr = tuple_val(term);
if (pos <= arityval(*tuple_ptr)) {
Eterm element = tuple_ptr[pos];
if (CMP(Key, element) == 0) {
return term;
}
}
}
}
}
if (is_not_nil(List)) {
BIF_ERROR(p, BADARG);
}
return am_false;
}
static int
print_op(int to, void *to_arg, int op, int size, BeamInstr* addr)
{
int i;
BeamInstr tag;
char* sign;
char* start_prog; /* Start of program for packer. */
char* prog; /* Current position in packer program. */
BeamInstr stack[8]; /* Stack for packer. */
BeamInstr* sp = stack; /* Points to next free position. */
BeamInstr packed = 0; /* Accumulator for packed operations. */
BeamInstr args[8]; /* Arguments for this instruction. */
BeamInstr* ap; /* Pointer to arguments. */
BeamInstr* unpacked; /* Unpacked arguments */
start_prog = opc[op].pack;
if (start_prog[0] == '\0') {
/*
* There is no pack program.
* Avoid copying because instructions containing bignum operands
* are bigger than actually declared.
*/
ap = (BeamInstr *) addr;
} else {
/*
* Copy all arguments to a local buffer for the unpacking.
*/
ASSERT(size <= sizeof(args)/sizeof(args[0]));
ap = args;
for (i = 0; i < size; i++) {
*ap++ = addr[i];
}
/*
* Undo any packing done by the loader. This is easily done by running
* the packing program backwards and in reverse.
*/
prog = start_prog + strlen(start_prog);
while (start_prog < prog) {
prog--;
switch (*prog) {
case 'g':
*ap++ = *--sp;
break;
case 'i': /* Initialize packing accumulator. */
*ap++ = packed;
break;
case 's':
*ap++ = packed & 0x3ff;
packed >>= 10;
break;
case '0': /* Tight shift */
*ap++ = packed & (BEAM_TIGHT_MASK / sizeof(Eterm));
packed >>= BEAM_TIGHT_SHIFT;
break;
case '6': /* Shift 16 steps */
*ap++ = packed & BEAM_LOOSE_MASK;
packed >>= BEAM_LOOSE_SHIFT;
break;
#ifdef ARCH_64
case 'w': /* Shift 32 steps */
*ap++ = packed & BEAM_WIDE_MASK;
packed >>= BEAM_WIDE_SHIFT;
break;
#endif
case 'p':
*sp++ = *--ap;
break;
case 'P':
packed = *--sp;
break;
default:
ASSERT(0);
}
}
ap = args;
}
/*
* Print the name and all operands of the instructions.
*/
erts_print(to, to_arg, "%s ", opc[op].name);
sign = opc[op].sign;
while (*sign) {
switch (*sign) {
case 'r': /* x(0) */
erts_print(to, to_arg, "r(0)");
break;
case 'x': /* x(N) */
{
Uint n = ap[0] / sizeof(Eterm);
erts_print(to, to_arg, "x(%d)", n);
ap++;
}
break;
case 'y': /* y(N) */
{
Uint n = ap[0] / sizeof(Eterm) - CP_SIZE;
erts_print(to, to_arg, "y(%d)", n);
ap++;
}
break;
case 'n': /* Nil */
erts_print(to, to_arg, "[]");
break;
case 's': /* Any source (tagged constant or register) */
tag = loader_tag(*ap);
if (tag == LOADER_X_REG) {
erts_print(to, to_arg, "x(%d)", loader_x_reg_index(*ap));
ap++;
break;
} else if (tag == LOADER_Y_REG) {
erts_print(to, to_arg, "y(%d)", loader_y_reg_index(*ap) - CP_SIZE);
ap++;
break;
}
/*FALLTHROUGH*/
case 'a': /* Tagged atom */
case 'i': /* Tagged integer */
case 'c': /* Tagged constant */
case 'q': /* Tagged literal */
erts_print(to, to_arg, "%T", (Eterm) *ap);
ap++;
break;
case 'A':
erts_print(to, to_arg, "%d", arityval( (Eterm) ap[0]));
ap++;
break;
case 'd': /* Destination (x(0), x(N), y(N)) */
if (*ap & 1) {
erts_print(to, to_arg, "y(%d)",
*ap / sizeof(Eterm) - CP_SIZE);
} else {
erts_print(to, to_arg, "x(%d)",
*ap / sizeof(Eterm));
}
ap++;
break;
case 'I': /* Untagged integer. */
case 't':
erts_print(to, to_arg, "%d", *ap);
ap++;
break;
case 'f': /* Destination label */
{
BeamInstr* f = find_function_from_pc((BeamInstr *)*ap);
if (f+3 != (BeamInstr *) *ap) {
erts_print(to, to_arg, "f(" HEXF ")", *ap);
} else {
erts_print(to, to_arg, "%T:%T/%bpu", (Eterm) f[0], (Eterm) f[1], f[2]);
}
ap++;
}
break;
case 'p': /* Pointer (to label) */
{
BeamInstr* f = find_function_from_pc((BeamInstr *)*ap);
if (f+3 != (BeamInstr *) *ap) {
erts_print(to, to_arg, "p(" HEXF ")", *ap);
} else {
erts_print(to, to_arg, "%T:%T/%bpu", (Eterm) f[0], (Eterm) f[1], f[2]);
}
ap++;
}
break;
case 'j': /* Pointer (to label) */
erts_print(to, to_arg, "j(" HEXF ")", *ap);
ap++;
break;
case 'e': /* Export entry */
{
Export* ex = (Export *) *ap;
erts_print(to, to_arg,
"%T:%T/%bpu", (Eterm) ex->code[0], (Eterm) ex->code[1], ex->code[2]);
ap++;
}
break;
case 'F': /* Function definition */
break;
case 'b':
for (i = 0; i < BIF_SIZE; i++) {
BifFunction bif = (BifFunction) *ap;
if (bif == bif_table[i].f) {
break;
}
}
if (i == BIF_SIZE) {
erts_print(to, to_arg, "b(%d)", (Uint) *ap);
} else {
Eterm name = bif_table[i].name;
unsigned arity = bif_table[i].arity;
erts_print(to, to_arg, "%T/%u", name, arity);
}
ap++;
break;
case 'P': /* Byte offset into tuple (see beam_load.c) */
case 'Q': /* Like 'P', but packable */
erts_print(to, to_arg, "%d", (*ap / sizeof(Eterm)) - 1);
ap++;
break;
case 'l': /* fr(N) */
erts_print(to, to_arg, "fr(%d)", loader_reg_index(ap[0]));
ap++;
break;
default:
erts_print(to, to_arg, "???");
ap++;
break;
}
erts_print(to, to_arg, " ");
sign++;
}
/*
* Print more information about certain instructions.
*/
unpacked = ap;
ap = addr + size;
switch (op) {
case op_i_select_val_lins_xfI:
case op_i_select_val_lins_yfI:
{
int n = ap[-1];
int ix = n;
while (ix--) {
erts_print(to, to_arg, "%T ", (Eterm) ap[0]);
ap++;
size++;
}
ix = n;
while (ix--) {
erts_print(to, to_arg, "f(" HEXF ") ", (Eterm) ap[0]);
ap++;
size++;
}
}
break;
case op_i_select_val_bins_xfI:
case op_i_select_val_bins_yfI:
{
int n = ap[-1];
while (n > 0) {
erts_print(to, to_arg, "%T f(" HEXF ") ", (Eterm) ap[0], ap[1]);
ap += 2;
size += 2;
n--;
}
}
break;
case op_i_select_tuple_arity_xfI:
case op_i_select_tuple_arity_yfI:
{
int n = ap[-1];
int ix = n - 1; /* without sentinel */
while (ix--) {
Uint arity = arityval(ap[0]);
erts_print(to, to_arg, "{%d} ", arity, ap[1]);
ap++;
size++;
}
/* print sentinel */
erts_print(to, to_arg, "{%T} ", ap[0], ap[1]);
ap++;
size++;
ix = n;
while (ix--) {
erts_print(to, to_arg, "f(" HEXF ") ", ap[0]);
ap++;
size++;
}
}
break;
case op_i_jump_on_val_xfII:
case op_i_jump_on_val_yfII:
{
int n;
for (n = ap[-2]; n > 0; n--) {
erts_print(to, to_arg, "f(" HEXF ") ", ap[0]);
ap++;
size++;
}
}
break;
case op_i_jump_on_val_zero_xfI:
case op_i_jump_on_val_zero_yfI:
{
int n;
for (n = ap[-1]; n > 0; n--) {
erts_print(to, to_arg, "f(" HEXF ") ", ap[0]);
ap++;
size++;
}
}
break;
case op_i_put_tuple_xI:
case op_i_put_tuple_yI:
case op_new_map_dII:
case op_update_map_assoc_jsdII:
case op_update_map_exact_jsdII:
{
int n = unpacked[-1];
while (n > 0) {
switch (loader_tag(ap[0])) {
case LOADER_X_REG:
erts_print(to, to_arg, " x(%d)", loader_x_reg_index(ap[0]));
break;
case LOADER_Y_REG:
erts_print(to, to_arg, " x(%d)", loader_y_reg_index(ap[0]));
break;
default:
erts_print(to, to_arg, " %T", (Eterm) ap[0]);
break;
}
ap++, size++, n--;
}
}
break;
case op_i_get_map_elements_fsI:
{
int n = unpacked[-1];
while (n > 0) {
if (n % 3 == 1) {
erts_print(to, to_arg, " %X", ap[0]);
} else {
switch (loader_tag(ap[0])) {
case LOADER_X_REG:
erts_print(to, to_arg, " x(%d)", loader_x_reg_index(ap[0]));
break;
case LOADER_Y_REG:
erts_print(to, to_arg, " y(%d)", loader_y_reg_index(ap[0]));
break;
default:
erts_print(to, to_arg, " %T", (Eterm) ap[0]);
break;
}
}
ap++, size++, n--;
}
}
break;
}
erts_print(to, to_arg, "\n");
return size;
}
/* Copy a message to the message area. */
Eterm copy_struct_lazy(Process *from, Eterm orig, Uint offs)
{
Eterm obj;
Eterm dest;
#ifdef INCREMENTAL
int alloc_old = 0;
#else
int total_need = 0;
#endif
VERBOSE(DEBUG_MESSAGES,
("COPY START; %T is sending a message @ 0x%016x\n%T\n",
from->id, orig, orig));
#ifndef INCREMENTAL
copy_start:
#endif
MA_STACK_PUSH(src,orig);
MA_STACK_PUSH(dst,&dest);
MA_STACK_PUSH(offset,offs);
while (ma_src_top > 0) {
obj = MA_STACK_POP(src);
/* copy_struct_lazy should never be called with something that
* do not need to be copied. Within the loop, nothing that do
* not need copying should be placed in the src-stack.
*/
ASSERT(!NO_COPY(obj));
switch (primary_tag(obj)) {
case TAG_PRIMARY_LIST: {
Eterm *hp;
Eterm *objp;
GlobalAlloc(from,2,hp);
objp = list_val(obj);
MA_STACK_UPDATE(dst,MA_STACK_POP(offset),make_list(hp));
MA_STACK_POP(dst);
/* TODO: Byt ordningen nedan så att CDR pushas först. */
if (NO_COPY(*objp)) {
hp[0] = *objp;
#ifdef INCREMENTAL
if (ptr_within(ptr_val(*objp),inc_fromspc,inc_fromend))
INC_STORE(gray,hp,2);
#endif
} else {
MA_STACK_PUSH(src,*objp);
MA_STACK_PUSH(dst,hp);
MA_STACK_PUSH(offset,0);
}
objp++;
if (NO_COPY(*objp)) {
hp[1] = *objp;
#ifdef INCREMENTAL
if (ptr_within(ptr_val(*objp),inc_fromspc,inc_fromend))
INC_STORE(gray,hp,2);
#endif
}
else {
MA_STACK_PUSH(src,*objp);
MA_STACK_PUSH(dst,hp);
MA_STACK_PUSH(offset,1);
}
continue;
}
case TAG_PRIMARY_BOXED: {
Eterm *objp = boxed_val(obj);
switch (*objp & _TAG_HEADER_MASK) {
case ARITYVAL_SUBTAG: {
Uint ari = arityval(*objp);
Uint i;
Eterm *hp;
GlobalAlloc(from,ari + 1,hp);
/* A GC above might invalidate the value of objp */
objp = boxed_val(obj);
MA_STACK_UPDATE(dst,MA_STACK_POP(offset),make_tuple(hp));
MA_STACK_POP(dst);
*hp = *objp++;
for (i = 1; i <= ari; i++) {
switch (primary_tag(*objp)) {
case TAG_PRIMARY_LIST:
case TAG_PRIMARY_BOXED:
if (NO_COPY(*objp)) {
hp[i] = *objp;
#ifdef INCREMENTAL
if (ptr_within(ptr_val(*objp),
inc_fromspc,inc_fromend))
INC_STORE(gray,hp,BOXED_NEED(hp,*hp));
#endif
objp++;
} else {
MA_STACK_PUSH(src,*objp++);
MA_STACK_PUSH(dst,hp);
MA_STACK_PUSH(offset,i);
}
break;
default:
hp[i] = *objp++;
}
}
continue;
}
case REFC_BINARY_SUBTAG: {
ProcBin *pb;
Uint i = thing_arityval(*objp) + 1;
Eterm *hp;
GlobalAlloc(from,i,hp);
/* A GC above might invalidate the value of objp */
objp = boxed_val(obj);
MA_STACK_UPDATE(dst,MA_STACK_POP(offset),make_binary(hp));
MA_STACK_POP(dst);
pb = (ProcBin*) hp;
while (i--) {
*hp++ = *objp++;
}
erts_refc_inc(&pb->val->refc, 2);
pb->next = erts_global_offheap.mso;
erts_global_offheap.mso = pb;
erts_global_offheap.overhead += pb->size / sizeof(Eterm);
continue;
}
case FUN_SUBTAG: {
ErlFunThing *funp = (ErlFunThing*) objp;
Uint i = thing_arityval(*objp) + 1;
Uint j = i + 1 + funp->num_free;
Uint k = i;
Eterm *hp, *hp_start;
GlobalAlloc(from,j,hp);
/* A GC above might invalidate the value of objp */
objp = boxed_val(obj);
hp_start = hp;
MA_STACK_UPDATE(dst,MA_STACK_POP(offset),make_fun(hp));
MA_STACK_POP(dst);
funp = (ErlFunThing*) hp;
while (i--) {
*hp++ = *objp++;
}
#ifndef HYBRID // FIND ME!
funp->next = erts_global_offheap.funs;
erts_global_offheap.funs = funp;
erts_refc_inc(&funp->fe->refc, 2);
#endif
for (i = k; i < j; i++) {
switch (primary_tag(*objp)) {
case TAG_PRIMARY_LIST:
case TAG_PRIMARY_BOXED:
if (NO_COPY(*objp)) {
#ifdef INCREMENTAL
if (ptr_within(ptr_val(*objp),
inc_fromspc,inc_fromend))
INC_STORE(gray,hp,BOXED_NEED(hp,*hp));
#endif
*hp++ = *objp++;
} else {
MA_STACK_PUSH(src,*objp++);
MA_STACK_PUSH(dst,hp_start);
MA_STACK_PUSH(offset,i);
hp++;
}
break;
default:
*hp++ = *objp++;
}
}
continue;
}
case EXTERNAL_PID_SUBTAG:
case EXTERNAL_PORT_SUBTAG:
case EXTERNAL_REF_SUBTAG: {
ExternalThing *etp;
Uint i = thing_arityval(*objp) + 1;
Eterm *hp;
GlobalAlloc(from,i,hp);
/* A GC above might invalidate the value of objp */
objp = boxed_val(obj);
MA_STACK_UPDATE(dst,MA_STACK_POP(offset),make_external(hp));
MA_STACK_POP(dst);
etp = (ExternalThing*) hp;
while (i--) {
*hp++ = *objp++;
}
etp->next = erts_global_offheap.externals;
erts_global_offheap.externals = etp;
erts_refc_inc(&etp->node->refc, 2);
continue;
}
case SUB_BINARY_SUBTAG: {
ErlSubBin *sb = (ErlSubBin *) objp;
Eterm *hp;
Eterm res_binary;
Eterm real_bin = sb->orig;
Uint bit_offset = sb->bitoffs;
Uint bit_size = sb -> bitsize;
Uint sub_offset = sb->offs;
size_t size = sb->size;
Uint extra_bytes;
Uint real_size;
Uint sub_binary_heapneed;
if ((bit_size + bit_offset) > 8) {
extra_bytes = 2;
sub_binary_heapneed = ERL_SUB_BIN_SIZE;
} else if ((bit_size + bit_offset) > 0) {
extra_bytes = 1;
sub_binary_heapneed = ERL_SUB_BIN_SIZE;
} else {
extra_bytes = 0;
sub_binary_heapneed = 0;
}
real_size = size+extra_bytes;
objp = binary_val(real_bin);
if (thing_subtag(*objp) == HEAP_BINARY_SUBTAG) {
ErlHeapBin *from_bin;
ErlHeapBin *to_bin;
Uint i = heap_bin_size(real_size);
GlobalAlloc(from,i+sub_binary_heapneed,hp);
from_bin = (ErlHeapBin *) objp;
to_bin = (ErlHeapBin *) hp;
to_bin->thing_word = header_heap_bin(real_size);
to_bin->size = real_size;
sys_memcpy(to_bin->data, ((byte *)from_bin->data) +
sub_offset, real_size);
res_binary = make_binary(to_bin);
hp += i;
} else {
ProcBin *from_bin;
ProcBin *to_bin;
ASSERT(thing_subtag(*objp) == REFC_BINARY_SUBTAG);
from_bin = (ProcBin *) objp;
erts_refc_inc(&from_bin->val->refc, 2);
GlobalAlloc(from,PROC_BIN_SIZE+sub_binary_heapneed,hp);
to_bin = (ProcBin *) hp;
to_bin->thing_word = HEADER_PROC_BIN;
to_bin->size = real_size;
to_bin->val = from_bin->val;
to_bin->bytes = from_bin->bytes + sub_offset;
to_bin->next = erts_global_offheap.mso;
erts_global_offheap.mso = to_bin;
erts_global_offheap.overhead += to_bin->size / sizeof(Eterm);
res_binary=make_binary(to_bin);
hp += PROC_BIN_SIZE;
}
if (extra_bytes != 0) {
ErlSubBin* res;
res = (ErlSubBin *) hp;
res->thing_word = HEADER_SUB_BIN;
res->size = size;
res->bitsize = bit_size;
res->bitoffs = bit_offset;
res->offs = 0;
res->is_writable = 0;
res->orig = res_binary;
res_binary = make_binary(hp);
}
MA_STACK_UPDATE(dst,MA_STACK_POP(offset),res_binary);
MA_STACK_POP(dst);
continue;
}
case BIN_MATCHSTATE_SUBTAG:
erl_exit(ERTS_ABORT_EXIT,
"copy_struct_lazy: matchstate term not allowed");
default: {
Uint size = thing_arityval(*objp) + 1;
Eterm *hp;
GlobalAlloc(from,size,hp);
/* A GC above might invalidate the value of objp */
objp = boxed_val(obj);
MA_STACK_UPDATE(dst,MA_STACK_POP(offset),make_boxed(hp));
MA_STACK_POP(dst);
while (size--) {
*hp++ = *objp++;
}
continue;
}
}
continue;
}
case TAG_PRIMARY_HEADER:
ASSERT((obj & _TAG_HEADER_MASK) == ARITYVAL_SUBTAG);
{
Eterm *objp = &obj;
Uint ari = arityval(obj);
Uint i;
Eterm *hp;
GlobalAlloc(from,ari + 1,hp);
MA_STACK_UPDATE(dst,MA_STACK_POP(offset),make_tuple(hp));
MA_STACK_POP(dst);
*hp = *objp++;
for (i = 1; i <= ari; i++) {
switch (primary_tag(*objp)) {
case TAG_PRIMARY_LIST:
case TAG_PRIMARY_BOXED:
if (NO_COPY(*objp)) {
#ifdef INCREMENTAL
if (ptr_within(ptr_val(*objp),inc_fromspc,inc_fromend))
INC_STORE(gray,hp,ari + 1);
#endif
hp[i] = *objp++;
} else {
MA_STACK_PUSH(src,*objp++);
MA_STACK_PUSH(dst,hp);
MA_STACK_PUSH(offset,i);
}
break;
default:
hp[i] = *objp++;
}
}
continue;
}
default:
erl_exit(ERTS_ABORT_EXIT,
"%s, line %d: Internal error in copy_struct_lazy: 0x%08x\n",
__FILE__, __LINE__,obj);
}
}
VERBOSE(DEBUG_MESSAGES,
("Copy allocated @ 0x%08lx:\n%T\n",
(unsigned long)ptr_val(dest),dest));
ma_gc_flags &= ~GC_CYCLE_START;
ASSERT(eq(orig, dest));
ASSERT(ma_src_top == 0);
ASSERT(ma_dst_top == 0);
ASSERT(ma_offset_top == 0);
return dest;
}
/*
* Copy a structure to a heap.
*/
Eterm
copy_struct(Eterm obj, Uint sz, Eterm** hpp, ErlOffHeap* off_heap)
{
char* hstart;
Uint hsize;
Eterm* htop;
Eterm* hbot;
Eterm* hp;
Eterm* objp;
Eterm* tp;
Eterm res;
Eterm elem;
Eterm* tailp;
Eterm* argp;
Eterm* const_tuple;
Eterm hdr;
int i;
#ifdef DEBUG
Eterm org_obj = obj;
Uint org_sz = sz;
#endif
if (IS_CONST(obj))
return obj;
hp = htop = *hpp;
hbot = htop + sz;
hstart = (char *)htop;
hsize = (char*) hbot - hstart;
const_tuple = 0;
/* Copy the object onto the heap */
switch (primary_tag(obj)) {
case TAG_PRIMARY_LIST: argp = &res; goto L_copy_list;
case TAG_PRIMARY_BOXED: argp = &res; goto L_copy_boxed;
default:
erl_exit(ERTS_ABORT_EXIT,
"%s, line %d: Internal error in copy_struct: 0x%08x\n",
__FILE__, __LINE__,obj);
}
L_copy:
while (hp != htop) {
obj = *hp;
switch (primary_tag(obj)) {
case TAG_PRIMARY_IMMED1:
hp++;
break;
case TAG_PRIMARY_LIST:
objp = list_val(obj);
if (in_area(objp,hstart,hsize)) {
hp++;
break;
}
argp = hp++;
/* Fall through */
L_copy_list:
tailp = argp;
while (is_list(obj)) {
objp = list_val(obj);
tp = tailp;
elem = *objp;
if (IS_CONST(elem)) {
*(hbot-2) = elem;
tailp = hbot-1;
hbot -= 2;
}
else {
*htop = elem;
tailp = htop+1;
htop += 2;
}
*tp = make_list(tailp - 1);
obj = *(objp+1);
}
switch (primary_tag(obj)) {
case TAG_PRIMARY_IMMED1: *tailp = obj; goto L_copy;
case TAG_PRIMARY_BOXED: argp = tailp; goto L_copy_boxed;
default:
erl_exit(ERTS_ABORT_EXIT,
"%s, line %d: Internal error in copy_struct: 0x%08x\n",
__FILE__, __LINE__,obj);
}
case TAG_PRIMARY_BOXED:
if (in_area(boxed_val(obj),hstart,hsize)) {
hp++;
break;
}
argp = hp++;
L_copy_boxed:
objp = boxed_val(obj);
hdr = *objp;
switch (hdr & _TAG_HEADER_MASK) {
case ARITYVAL_SUBTAG:
{
int const_flag = 1; /* assume constant tuple */
i = arityval(hdr);
*argp = make_tuple(htop);
tp = htop; /* tp is pointer to new arity value */
*htop++ = *objp++; /* copy arity value */
while (i--) {
elem = *objp++;
if (!IS_CONST(elem)) {
const_flag = 0;
}
*htop++ = elem;
}
if (const_flag) {
const_tuple = tp; /* this is the latest const_tuple */
}
}
break;
case REFC_BINARY_SUBTAG:
{
ProcBin* pb;
pb = (ProcBin *) objp;
if (pb->flags) {
erts_emasculate_writable_binary(pb);
}
i = thing_arityval(*objp) + 1;
hbot -= i;
tp = hbot;
while (i--) {
*tp++ = *objp++;
}
*argp = make_binary(hbot);
pb = (ProcBin*) hbot;
erts_refc_inc(&pb->val->refc, 2);
pb->next = off_heap->mso;
pb->flags = 0;
off_heap->mso = pb;
off_heap->overhead += pb->size / sizeof(Eterm);
}
break;
case SUB_BINARY_SUBTAG:
{
ErlSubBin* sb = (ErlSubBin *) objp;
Eterm real_bin = sb->orig;
Uint bit_offset = sb->bitoffs;
Uint bit_size = sb -> bitsize;
Uint offset = sb->offs;
size_t size = sb->size;
Uint extra_bytes;
Uint real_size;
if ((bit_size + bit_offset) > 8) {
extra_bytes = 2;
} else if ((bit_size + bit_offset) > 0) {
extra_bytes = 1;
} else {
extra_bytes = 0;
}
real_size = size+extra_bytes;
objp = binary_val(real_bin);
if (thing_subtag(*objp) == HEAP_BINARY_SUBTAG) {
ErlHeapBin* from = (ErlHeapBin *) objp;
ErlHeapBin* to;
i = heap_bin_size(real_size);
hbot -= i;
to = (ErlHeapBin *) hbot;
to->thing_word = header_heap_bin(real_size);
to->size = real_size;
sys_memcpy(to->data, ((byte *)from->data)+offset, real_size);
} else {
ProcBin* from = (ProcBin *) objp;
ProcBin* to;
ASSERT(thing_subtag(*objp) == REFC_BINARY_SUBTAG);
if (from->flags) {
erts_emasculate_writable_binary(from);
}
hbot -= PROC_BIN_SIZE;
to = (ProcBin *) hbot;
to->thing_word = HEADER_PROC_BIN;
to->size = real_size;
to->val = from->val;
erts_refc_inc(&to->val->refc, 2);
to->bytes = from->bytes + offset;
to->next = off_heap->mso;
to->flags = 0;
off_heap->mso = to;
off_heap->overhead += to->size / sizeof(Eterm);
}
*argp = make_binary(hbot);
if (extra_bytes != 0) {
ErlSubBin* res;
hbot -= ERL_SUB_BIN_SIZE;
res = (ErlSubBin *) hbot;
res->thing_word = HEADER_SUB_BIN;
res->size = size;
res->bitsize = bit_size;
res->bitoffs = bit_offset;
res->offs = 0;
res->is_writable = 0;
res->orig = *argp;
*argp = make_binary(hbot);
}
break;
}
break;
case FUN_SUBTAG:
{
ErlFunThing* funp = (ErlFunThing *) objp;
i = thing_arityval(hdr) + 2 + funp->num_free;
tp = htop;
while (i--) {
*htop++ = *objp++;
}
#ifndef HYBRID /* FIND ME! */
funp = (ErlFunThing *) tp;
funp->next = off_heap->funs;
off_heap->funs = funp;
erts_refc_inc(&funp->fe->refc, 2);
#endif
*argp = make_fun(tp);
}
break;
case EXTERNAL_PID_SUBTAG:
case EXTERNAL_PORT_SUBTAG:
case EXTERNAL_REF_SUBTAG:
{
ExternalThing *etp = (ExternalThing *) htop;
i = thing_arityval(hdr) + 1;
tp = htop;
while (i--) {
*htop++ = *objp++;
}
etp->next = off_heap->externals;
off_heap->externals = etp;
erts_refc_inc(&etp->node->refc, 2);
*argp = make_external(tp);
}
break;
case BIN_MATCHSTATE_SUBTAG:
erl_exit(ERTS_ABORT_EXIT,
"copy_struct: matchstate term not allowed");
default:
i = thing_arityval(hdr)+1;
hbot -= i;
tp = hbot;
*argp = make_boxed(hbot);
while (i--) {
*tp++ = *objp++;
}
}
break;
case TAG_PRIMARY_HEADER:
if (header_is_thing(obj) || hp == const_tuple) {
hp += header_arity(obj) + 1;
} else {
hp++;
}
break;
}
}
#ifdef DEBUG
if (htop != hbot)
erl_exit(ERTS_ABORT_EXIT,
"Internal error in copy_struct() when copying %T:"
" htop=%p != hbot=%p (sz=%bpu)\n",
org_obj, htop, hbot, org_sz);
#else
if (htop > hbot) {
erl_exit(ERTS_ABORT_EXIT,
"Internal error in copy_struct(): htop, hbot overrun\n");
}
#endif
*hpp = (Eterm *) (hstart+hsize);
return res;
}
static int
print_op(fmtfn_t to, void *to_arg, int op, int size, BeamInstr* addr)
{
int i;
BeamInstr tag;
char* sign;
char* start_prog; /* Start of program for packer. */
char* prog; /* Current position in packer program. */
BeamInstr stack[8]; /* Stack for packer. */
BeamInstr* sp = stack; /* Points to next free position. */
BeamInstr packed = 0; /* Accumulator for packed operations. */
BeamInstr args[8]; /* Arguments for this instruction. */
BeamInstr* ap; /* Pointer to arguments. */
BeamInstr* unpacked; /* Unpacked arguments */
BeamInstr* first_arg; /* First argument */
start_prog = opc[op].pack;
if (start_prog[0] == '\0') {
/*
* There is no pack program.
* Avoid copying because instructions containing bignum operands
* are bigger than actually declared.
*/
addr++;
ap = addr;
} else {
#if defined(ARCH_64) && defined(CODE_MODEL_SMALL)
BeamInstr instr_word = addr[0];
#endif
addr++;
/*
* Copy all arguments to a local buffer for the unpacking.
*/
ASSERT(size <= sizeof(args)/sizeof(args[0]));
ap = args;
for (i = 0; i < size; i++) {
*ap++ = addr[i];
}
/*
* Undo any packing done by the loader. This is easily done by running
* the packing program backwards and in reverse.
*/
prog = start_prog + sys_strlen(start_prog);
while (start_prog < prog) {
prog--;
switch (*prog) {
case 'f':
case 'g':
case 'q':
*ap++ = *--sp;
break;
#ifdef ARCH_64
case '1': /* Tightest shift */
*ap++ = (packed & BEAM_TIGHTEST_MASK) << 3;
packed >>= BEAM_TIGHTEST_SHIFT;
break;
#endif
case '2': /* Tight shift */
*ap++ = packed & BEAM_TIGHT_MASK;
packed >>= BEAM_TIGHT_SHIFT;
break;
case '3': /* Loose shift */
*ap++ = packed & BEAM_LOOSE_MASK;
packed >>= BEAM_LOOSE_SHIFT;
break;
#ifdef ARCH_64
case '4': /* Shift 32 steps */
*ap++ = packed & BEAM_WIDE_MASK;
packed >>= BEAM_WIDE_SHIFT;
break;
#endif
case 'p':
*sp++ = *--ap;
break;
case 'P':
packed = *--sp;
break;
#if defined(ARCH_64) && defined(CODE_MODEL_SMALL)
case '#': /* -1 */
case '$': /* -2 */
case '%': /* -3 */
case '&': /* -4 */
case '\'': /* -5 */
case '(': /* -6 */
packed = (packed << BEAM_WIDE_SHIFT) | BeamExtraData(instr_word);
break;
#endif
default:
erts_exit(ERTS_ERROR_EXIT, "beam_debug: invalid packing op: %c\n", *prog);
}
}
ap = args;
}
first_arg = ap;
/*
* Print the name and all operands of the instructions.
*/
erts_print(to, to_arg, "%s ", opc[op].name);
sign = opc[op].sign;
while (*sign) {
switch (*sign) {
case 'r': /* x(0) */
erts_print(to, to_arg, "r(0)");
break;
case 'x': /* x(N) */
{
Uint n = ap[0] / sizeof(Eterm);
erts_print(to, to_arg, "x(%d)", n);
ap++;
}
break;
case 'y': /* y(N) */
{
Uint n = ap[0] / sizeof(Eterm) - CP_SIZE;
erts_print(to, to_arg, "y(%d)", n);
ap++;
}
break;
case 'n': /* Nil */
erts_print(to, to_arg, "[]");
break;
case 'S': /* Register */
{
Uint reg_type = (*ap & 1) ? 'y' : 'x';
Uint n = ap[0] / sizeof(Eterm);
erts_print(to, to_arg, "%c(%d)", reg_type, n);
ap++;
break;
}
case 's': /* Any source (tagged constant or register) */
tag = loader_tag(*ap);
if (tag == LOADER_X_REG) {
erts_print(to, to_arg, "x(%d)", loader_x_reg_index(*ap));
ap++;
break;
} else if (tag == LOADER_Y_REG) {
erts_print(to, to_arg, "y(%d)", loader_y_reg_index(*ap) - CP_SIZE);
ap++;
break;
}
/*FALLTHROUGH*/
case 'a': /* Tagged atom */
case 'i': /* Tagged integer */
case 'c': /* Tagged constant */
case 'q': /* Tagged literal */
erts_print(to, to_arg, "%T", (Eterm) *ap);
ap++;
break;
case 'A':
erts_print(to, to_arg, "%d", arityval( (Eterm) ap[0]));
ap++;
break;
case 'd': /* Destination (x(0), x(N), y(N)) */
if (*ap & 1) {
erts_print(to, to_arg, "y(%d)",
*ap / sizeof(Eterm) - CP_SIZE);
} else {
erts_print(to, to_arg, "x(%d)",
*ap / sizeof(Eterm));
}
ap++;
break;
case 't': /* Untagged integers */
case 'I':
case 'W':
switch (op) {
case op_i_gc_bif1_jWstd:
case op_i_gc_bif2_jWtssd:
case op_i_gc_bif3_jWtssd:
{
const ErtsGcBif* p;
BifFunction gcf = (BifFunction) *ap;
for (p = erts_gc_bifs; p->bif != 0; p++) {
if (p->gc_bif == gcf) {
print_bif_name(to, to_arg, p->bif);
break;
}
}
if (p->bif == 0) {
erts_print(to, to_arg, "%d", (Uint)gcf);
}
break;
}
case op_i_make_fun_Wt:
if (*sign == 'W') {
ErlFunEntry* fe = (ErlFunEntry *) *ap;
ErtsCodeMFA* cmfa = find_function_from_pc(fe->address);
erts_print(to, to_arg, "%T:%T/%bpu", cmfa->module,
cmfa->function, cmfa->arity);
} else {
erts_print(to, to_arg, "%d", *ap);
}
break;
case op_i_bs_match_string_xfWW:
if (ap - first_arg < 3) {
erts_print(to, to_arg, "%d", *ap);
} else {
Uint bits = ap[-1];
Uint bytes = (bits+7)/8;
byte* str = (byte *) *ap;
print_byte_string(to, to_arg, str, bytes);
}
break;
case op_bs_put_string_WW:
if (ap - first_arg == 0) {
erts_print(to, to_arg, "%d", *ap);
} else {
Uint bytes = ap[-1];
byte* str = (byte *) ap[0];
print_byte_string(to, to_arg, str, bytes);
}
break;
default:
erts_print(to, to_arg, "%d", *ap);
}
ap++;
break;
case 'f': /* Destination label */
switch (op) {
case op_catch_yf:
erts_print(to, to_arg, "f(" HEXF ")", catch_pc((BeamInstr)*ap));
break;
default:
{
BeamInstr* target = f_to_addr(addr, op, ap);
ErtsCodeMFA* cmfa = find_function_from_pc(target);
if (!cmfa || erts_codemfa_to_code(cmfa) != target) {
erts_print(to, to_arg, "f(" HEXF ")", target);
} else {
erts_print(to, to_arg, "%T:%T/%bpu", cmfa->module,
cmfa->function, cmfa->arity);
}
ap++;
}
break;
}
break;
case 'p': /* Pointer (to label) */
{
BeamInstr* target = f_to_addr(addr, op, ap);
erts_print(to, to_arg, "p(" HEXF ")", target);
ap++;
}
break;
case 'j': /* Pointer (to label) */
if (*ap == 0) {
erts_print(to, to_arg, "j(0)");
} else {
BeamInstr* target = f_to_addr(addr, op, ap);
erts_print(to, to_arg, "j(" HEXF ")", target);
}
ap++;
break;
case 'e': /* Export entry */
{
Export* ex = (Export *) *ap;
erts_print(to, to_arg,
"%T:%T/%bpu", (Eterm) ex->info.mfa.module,
(Eterm) ex->info.mfa.function,
ex->info.mfa.arity);
ap++;
}
break;
case 'F': /* Function definition */
break;
case 'b':
print_bif_name(to, to_arg, (BifFunction) *ap);
ap++;
break;
case 'P': /* Byte offset into tuple (see beam_load.c) */
case 'Q': /* Like 'P', but packable */
erts_print(to, to_arg, "%d", (*ap / sizeof(Eterm)) - 1);
ap++;
break;
case 'l': /* fr(N) */
erts_print(to, to_arg, "fr(%d)", loader_reg_index(ap[0]));
ap++;
break;
default:
erts_print(to, to_arg, "???");
ap++;
break;
}
erts_print(to, to_arg, " ");
sign++;
}
/*
* Print more information about certain instructions.
*/
unpacked = ap;
ap = addr + size;
/*
* In the code below, never use ap[-1], ap[-2], ...
* (will not work if the arguments have been packed).
*
* Instead use unpacked[-1], unpacked[-2], ...
*/
switch (op) {
case op_i_select_val_lins_xfI:
case op_i_select_val_lins_yfI:
case op_i_select_val_bins_xfI:
case op_i_select_val_bins_yfI:
{
int n = unpacked[-1];
int ix = n;
Sint32* jump_tab = (Sint32 *)(ap + n);
while (ix--) {
erts_print(to, to_arg, "%T ", (Eterm) ap[0]);
ap++;
size++;
}
ix = n;
while (ix--) {
BeamInstr* target = f_to_addr_packed(addr, op, jump_tab);
erts_print(to, to_arg, "f(" HEXF ") ", target);
jump_tab++;
}
size += (n+1) / 2;
}
break;
case op_i_select_tuple_arity_xfI:
case op_i_select_tuple_arity_yfI:
{
int n = unpacked[-1];
int ix = n - 1; /* without sentinel */
Sint32* jump_tab = (Sint32 *)(ap + n);
while (ix--) {
Uint arity = arityval(ap[0]);
erts_print(to, to_arg, "{%d} ", arity, ap[1]);
ap++;
size++;
}
/* print sentinel */
erts_print(to, to_arg, "{%T} ", ap[0], ap[1]);
ap++;
size++;
ix = n;
while (ix--) {
BeamInstr* target = f_to_addr_packed(addr, op, jump_tab);
erts_print(to, to_arg, "f(" HEXF ") ", target);
jump_tab++;
}
size += (n+1) / 2;
}
break;
case op_i_select_val2_xfcc:
case op_i_select_val2_yfcc:
case op_i_select_tuple_arity2_xfAA:
case op_i_select_tuple_arity2_yfAA:
{
Sint32* jump_tab = (Sint32 *) ap;
BeamInstr* target;
int i;
for (i = 0; i < 2; i++) {
target = f_to_addr_packed(addr, op, jump_tab++);
erts_print(to, to_arg, "f(" HEXF ") ", target);
}
size += 1;
}
break;
case op_i_jump_on_val_xfIW:
case op_i_jump_on_val_yfIW:
{
int n = unpacked[-2];
Sint32* jump_tab = (Sint32 *) ap;
size += (n+1) / 2;
while (n-- > 0) {
BeamInstr* target = f_to_addr_packed(addr, op, jump_tab);
erts_print(to, to_arg, "f(" HEXF ") ", target);
jump_tab++;
}
}
break;
case op_i_jump_on_val_zero_xfI:
case op_i_jump_on_val_zero_yfI:
{
int n = unpacked[-1];
Sint32* jump_tab = (Sint32 *) ap;
size += (n+1) / 2;
while (n-- > 0) {
BeamInstr* target = f_to_addr_packed(addr, op, jump_tab);
erts_print(to, to_arg, "f(" HEXF ") ", target);
jump_tab++;
}
}
break;
case op_i_put_tuple_xI:
case op_i_put_tuple_yI:
case op_new_map_dtI:
case op_update_map_assoc_sdtI:
case op_update_map_exact_jsdtI:
{
int n = unpacked[-1];
while (n > 0) {
switch (loader_tag(ap[0])) {
case LOADER_X_REG:
erts_print(to, to_arg, " x(%d)", loader_x_reg_index(ap[0]));
break;
case LOADER_Y_REG:
erts_print(to, to_arg, " y(%d)", loader_y_reg_index(ap[0]) - CP_SIZE);
break;
default:
erts_print(to, to_arg, " %T", (Eterm) ap[0]);
break;
}
ap++, size++, n--;
}
}
break;
case op_i_new_small_map_lit_dtq:
{
Eterm *tp = tuple_val(unpacked[-1]);
int n = arityval(*tp);
while (n > 0) {
switch (loader_tag(ap[0])) {
case LOADER_X_REG:
erts_print(to, to_arg, " x(%d)", loader_x_reg_index(ap[0]));
break;
case LOADER_Y_REG:
erts_print(to, to_arg, " y(%d)", loader_y_reg_index(ap[0]) - CP_SIZE);
break;
default:
erts_print(to, to_arg, " %T", (Eterm) ap[0]);
break;
}
ap++, size++, n--;
}
}
break;
case op_i_get_map_elements_fsI:
{
int n = unpacked[-1];
while (n > 0) {
if (n % 3 == 1) {
erts_print(to, to_arg, " %X", ap[0]);
} else {
switch (loader_tag(ap[0])) {
case LOADER_X_REG:
erts_print(to, to_arg, " x(%d)", loader_x_reg_index(ap[0]));
break;
case LOADER_Y_REG:
erts_print(to, to_arg, " y(%d)", loader_y_reg_index(ap[0]) - CP_SIZE);
break;
default:
erts_print(to, to_arg, " %T", (Eterm) ap[0]);
break;
}
}
ap++, size++, n--;
}
}
break;
}
erts_print(to, to_arg, "\n");
return size;
}
Eterm copy_struct(Eterm obj, Uint sz, Eterm** hpp, ErlOffHeap* off_heap)
#endif
{
char* hstart;
Uint hsize;
Eterm* htop;
Eterm* hbot;
Eterm* hp;
Eterm* objp;
Eterm* tp;
Eterm res;
Eterm elem;
Eterm* tailp;
Eterm* argp;
Eterm* const_tuple;
Eterm hdr;
int i;
#ifdef DEBUG
Eterm org_obj = obj;
Uint org_sz = sz;
#endif
if (IS_CONST(obj))
return obj;
DTRACE1(copy_struct, (int32_t)sz);
hp = htop = *hpp;
hbot = htop + sz;
hstart = (char *)htop;
hsize = (char*) hbot - hstart;
const_tuple = 0;
/* Copy the object onto the heap */
switch (primary_tag(obj)) {
case TAG_PRIMARY_LIST:
argp = &res;
objp = list_val_rel(obj,src_base);
goto L_copy_list;
case TAG_PRIMARY_BOXED: argp = &res; goto L_copy_boxed;
default:
erl_exit(ERTS_ABORT_EXIT,
"%s, line %d: Internal error in copy_struct: 0x%08x\n",
__FILE__, __LINE__,obj);
}
L_copy:
while (hp != htop) {
obj = *hp;
switch (primary_tag(obj)) {
case TAG_PRIMARY_IMMED1:
hp++;
break;
case TAG_PRIMARY_LIST:
objp = list_val_rel(obj,src_base);
#if !HALFWORD_HEAP || defined(DEBUG)
if (in_area(objp,hstart,hsize)) {
ASSERT(!HALFWORD_HEAP);
hp++;
break;
}
#endif
argp = hp++;
/* Fall through */
L_copy_list:
tailp = argp;
for (;;) {
tp = tailp;
elem = CAR(objp);
if (IS_CONST(elem)) {
hbot -= 2;
CAR(hbot) = elem;
tailp = &CDR(hbot);
}
else {
CAR(htop) = elem;
#if HALFWORD_HEAP
CDR(htop) = CDR(objp);
*tailp = make_list_rel(htop,dst_base);
htop += 2;
goto L_copy;
#else
tailp = &CDR(htop);
htop += 2;
#endif
}
ASSERT(!HALFWORD_HEAP || tp < hp || tp >= hbot);
*tp = make_list_rel(tailp - 1, dst_base);
obj = CDR(objp);
if (!is_list(obj)) {
break;
}
objp = list_val_rel(obj,src_base);
}
switch (primary_tag(obj)) {
case TAG_PRIMARY_IMMED1: *tailp = obj; goto L_copy;
case TAG_PRIMARY_BOXED: argp = tailp; goto L_copy_boxed;
default:
erl_exit(ERTS_ABORT_EXIT,
"%s, line %d: Internal error in copy_struct: 0x%08x\n",
__FILE__, __LINE__,obj);
}
case TAG_PRIMARY_BOXED:
#if !HALFWORD_HEAP || defined(DEBUG)
if (in_area(boxed_val_rel(obj,src_base),hstart,hsize)) {
ASSERT(!HALFWORD_HEAP);
hp++;
break;
}
#endif
argp = hp++;
L_copy_boxed:
objp = boxed_val_rel(obj, src_base);
hdr = *objp;
switch (hdr & _TAG_HEADER_MASK) {
case ARITYVAL_SUBTAG:
{
int const_flag = 1; /* assume constant tuple */
i = arityval(hdr);
*argp = make_tuple_rel(htop, dst_base);
tp = htop; /* tp is pointer to new arity value */
*htop++ = *objp++; /* copy arity value */
while (i--) {
elem = *objp++;
if (!IS_CONST(elem)) {
const_flag = 0;
}
*htop++ = elem;
}
if (const_flag) {
const_tuple = tp; /* this is the latest const_tuple */
}
}
break;
case MAP_SUBTAG:
{
i = map_get_size(objp) + 3;
*argp = make_map_rel(htop, dst_base);
while (i--) {
*htop++ = *objp++;
}
}
break;
case REFC_BINARY_SUBTAG:
{
EPIPHANY_STUB(copy_struct);
}
break;
case SUB_BINARY_SUBTAG:
{
EPIPHANY_STUB(copy_struct);
}
break;
case FUN_SUBTAG:
{
ErlFunThing* funp = (ErlFunThing *) objp;
i = thing_arityval(hdr) + 2 + funp->num_free;
tp = htop;
while (i--) {
*htop++ = *objp++;
}
funp = (ErlFunThing *) tp;
funp->next = off_heap->first;
off_heap->first = (struct erl_off_heap_header*) funp;
erts_refc_inc(&funp->fe->refc, 2);
*argp = make_fun_rel(tp, dst_base);
}
break;
case EXTERNAL_PID_SUBTAG:
case EXTERNAL_PORT_SUBTAG:
case EXTERNAL_REF_SUBTAG:
{
ExternalThing *etp = (ExternalThing *) htop;
i = thing_arityval(hdr) + 1;
tp = htop;
while (i--) {
*htop++ = *objp++;
}
etp->next = off_heap->first;
off_heap->first = (struct erl_off_heap_header*)etp;
erts_refc_inc(&etp->node->refc, 2);
*argp = make_external_rel(tp, dst_base);
}
break;
case BIN_MATCHSTATE_SUBTAG:
erl_exit(ERTS_ABORT_EXIT,
"copy_struct: matchstate term not allowed");
default:
i = thing_arityval(hdr)+1;
hbot -= i;
tp = hbot;
*argp = make_boxed_rel(hbot, dst_base);
while (i--) {
*tp++ = *objp++;
}
}
break;
case TAG_PRIMARY_HEADER:
if (header_is_thing(obj) || hp == const_tuple) {
hp += header_arity(obj) + 1;
} else {
hp++;
}
break;
}
}
#ifdef DEBUG
if (htop != hbot)
erl_exit(ERTS_ABORT_EXIT,
"Internal error in copy_struct() when copying %T:"
" htop=%p != hbot=%p (sz=%beu)\n",
org_obj, htop, hbot, org_sz);
#else
if (htop > hbot) {
erl_exit(ERTS_ABORT_EXIT,
"Internal error in copy_struct(): htop, hbot overrun\n");
}
#endif
*hpp = (Eterm *) (hstart+hsize);
return res;
}