BIF_RETTYPE abs_1(BIF_ALIST_1)
{
Eterm res;
Sint i0, i;
Eterm* hp;
/* integer arguments */
if (is_small(BIF_ARG_1)) {
i0 = signed_val(BIF_ARG_1);
i = ERTS_SMALL_ABS(i0);
if (i0 == MIN_SMALL) {
hp = HAlloc(BIF_P, BIG_UINT_HEAP_SIZE);
BIF_RET(uint_to_big(i, hp));
} else {
BIF_RET(make_small(i));
}
} else if (is_big(BIF_ARG_1)) {
if (!big_sign(BIF_ARG_1)) {
BIF_RET(BIF_ARG_1);
} else {
int sz = big_arity(BIF_ARG_1) + 1;
Uint* x;
hp = HAlloc(BIF_P, sz); /* See note at beginning of file */
sz--;
res = make_big(hp);
x = big_val(BIF_ARG_1);
*hp++ = make_pos_bignum_header(sz);
x++; /* skip thing */
while(sz--)
*hp++ = *x++;
BIF_RET(res);
}
} else if (is_float(BIF_ARG_1)) {
FloatDef f;
GET_DOUBLE(BIF_ARG_1, f);
if (f.fd < 0.0) {
hp = HAlloc(BIF_P, FLOAT_SIZE_OBJECT);
f.fd = fabs(f.fd);
res = make_float(hp);
PUT_DOUBLE(f, hp);
BIF_RET(res);
}
else
BIF_RET(BIF_ARG_1);
}
BIF_ERROR(BIF_P, BADARG);
}
Eterm erl_is_function(Process* p, Eterm arg1, Eterm arg2)
{
Sint arity;
/*
* Verify argument 2 (arity); arity must be >= 0.
*/
if (is_small(arg2)) {
arity = signed_val(arg2);
if (arity < 0) {
error:
BIF_ERROR(p, BADARG);
}
} else if (is_big(arg2) && !bignum_header_is_neg(*big_val(arg2))) {
/* A positive bignum is OK, but can't possibly match. */
arity = -1;
} else {
/* Everything else (including negative bignum) is an error. */
goto error;
}
if (is_fun(arg1)) {
ErlFunThing* funp = (ErlFunThing *) fun_val(arg1);
if (funp->arity == (Uint) arity) {
BIF_RET(am_true);
}
} else if (is_export(arg1)) {
Export* exp = (Export *) (export_val(arg1)[1]);
if (exp->info.mfa.arity == (Uint) arity) {
BIF_RET(am_true);
}
}
BIF_RET(am_false);
}
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
check_process_code(Process* rp, Module* modp, Uint flags, int *redsp, int fcalls)
{
BeamInstr* start;
char* literals;
Uint lit_bsize;
char* mod_start;
Uint mod_size;
Eterm* sp;
int done_gc = 0;
int need_gc = 0;
ErtsMessage *msgp;
ErlHeapFragment *hfrag;
#define ERTS_ORDINARY_GC__ (1 << 0)
#define ERTS_LITERAL_GC__ (1 << 1)
/*
* Pick up limits for the module.
*/
start = (BeamInstr*) modp->old.code_hdr;
mod_start = (char *) start;
mod_size = modp->old.code_length;
/*
* Check if current instruction or continuation pointer points into module.
*/
if (ErtsInArea(rp->i, mod_start, mod_size)
|| ErtsInArea(rp->cp, mod_start, mod_size)) {
return am_true;
}
/*
* Check all continuation pointers stored on the stack.
*/
for (sp = rp->stop; sp < STACK_START(rp); sp++) {
if (is_CP(*sp) && ErtsInArea(cp_val(*sp), mod_start, mod_size)) {
return am_true;
}
}
/*
* Check all continuation pointers stored in stackdump
* and clear exception stackdump if there is a pointer
* to the module.
*/
if (rp->ftrace != NIL) {
struct StackTrace *s;
ASSERT(is_list(rp->ftrace));
s = (struct StackTrace *) big_val(CDR(list_val(rp->ftrace)));
if ((s->pc && ErtsInArea(s->pc, mod_start, mod_size)) ||
(s->current && ErtsInArea(s->current, mod_start, mod_size))) {
rp->freason = EXC_NULL;
rp->fvalue = NIL;
rp->ftrace = NIL;
} else {
int i;
for (i = 0; i < s->depth; i++) {
if (ErtsInArea(s->trace[i], mod_start, mod_size)) {
rp->freason = EXC_NULL;
rp->fvalue = NIL;
rp->ftrace = NIL;
break;
}
}
}
}
if (rp->flags & F_DISABLE_GC) {
/*
* Cannot proceed. Process has disabled gc in order to
* safely leave inconsistent data on the heap and/or
* off heap lists. Need to wait for gc to be enabled
* again.
*/
return THE_NON_VALUE;
}
/*
* Message queue can contains funs, but (at least currently) no
* literals. If we got references to this module from the message
* queue, a GC cannot remove these...
*/
erts_smp_proc_lock(rp, ERTS_PROC_LOCK_MSGQ);
ERTS_SMP_MSGQ_MV_INQ2PRIVQ(rp);
erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_MSGQ);
literals = (char*) modp->old.code_hdr->literals_start;
lit_bsize = (char*) modp->old.code_hdr->literals_end - literals;
for (msgp = rp->msg.first; msgp; msgp = msgp->next) {
if (msgp->data.attached == ERTS_MSG_COMBINED_HFRAG)
hfrag = &msgp->hfrag;
else if (is_value(ERL_MESSAGE_TERM(msgp)) && msgp->data.heap_frag)
hfrag = msgp->data.heap_frag;
else
continue;
for (; hfrag; hfrag = hfrag->next) {
if (check_mod_funs(rp, &hfrag->off_heap, mod_start, mod_size))
return am_true;
/* Should not contain any literals... */
ASSERT(!any_heap_refs(&hfrag->mem[0],
&hfrag->mem[hfrag->used_size],
literals,
lit_bsize));
}
}
while (1) {
/* Check heap, stack etc... */
if (check_mod_funs(rp, &rp->off_heap, mod_start, mod_size))
goto try_gc;
if (!(flags & ERTS_CPC_COPY_LITERALS)) {
/* Process ok. May contain old literals but we will be called
* again before module is purged.
*/
return am_false;
}
if (any_heap_ref_ptrs(&rp->fvalue, &rp->fvalue+1, literals, lit_bsize)) {
rp->freason = EXC_NULL;
rp->fvalue = NIL;
rp->ftrace = NIL;
}
if (any_heap_ref_ptrs(rp->stop, rp->hend, literals, lit_bsize))
goto try_literal_gc;
if (any_heap_refs(rp->heap, rp->htop, literals, lit_bsize))
goto try_literal_gc;
if (any_heap_refs(rp->old_heap, rp->old_htop, literals, lit_bsize))
goto try_literal_gc;
/* Check dictionary */
if (rp->dictionary) {
Eterm* start = ERTS_PD_START(rp->dictionary);
Eterm* end = start + ERTS_PD_SIZE(rp->dictionary);
if (any_heap_ref_ptrs(start, end, literals, lit_bsize))
goto try_literal_gc;
}
/* Check heap fragments */
for (hfrag = rp->mbuf; hfrag; hfrag = hfrag->next) {
Eterm *hp, *hp_end;
/* Off heap lists should already have been moved into process */
ASSERT(!check_mod_funs(rp, &hfrag->off_heap, mod_start, mod_size));
hp = &hfrag->mem[0];
hp_end = &hfrag->mem[hfrag->used_size];
if (any_heap_refs(hp, hp_end, literals, lit_bsize))
goto try_literal_gc;
}
#ifdef DEBUG
/*
* Message buffer fragments should not have any references
* to literals, and off heap lists should already have
* been moved into process off heap structure.
*/
for (msgp = rp->msg_frag; msgp; msgp = msgp->next) {
if (msgp->data.attached == ERTS_MSG_COMBINED_HFRAG)
hfrag = &msgp->hfrag;
else
hfrag = msgp->data.heap_frag;
for (; hfrag; hfrag = hfrag->next) {
Eterm *hp, *hp_end;
ASSERT(!check_mod_funs(rp, &hfrag->off_heap, mod_start, mod_size));
hp = &hfrag->mem[0];
hp_end = &hfrag->mem[hfrag->used_size];
ASSERT(!any_heap_refs(hp, hp_end, literals, lit_bsize));
}
}
#endif
return am_false;
try_literal_gc:
need_gc |= ERTS_LITERAL_GC__;
try_gc:
need_gc |= ERTS_ORDINARY_GC__;
if ((done_gc & need_gc) == need_gc)
return am_true;
if (!(flags & ERTS_CPC_ALLOW_GC))
return am_aborted;
need_gc &= ~done_gc;
/*
* Try to get rid of literals by by garbage collecting.
* Clear both fvalue and ftrace.
*/
rp->freason = EXC_NULL;
rp->fvalue = NIL;
rp->ftrace = NIL;
if (need_gc & ERTS_ORDINARY_GC__) {
FLAGS(rp) |= F_NEED_FULLSWEEP;
*redsp += erts_garbage_collect_nobump(rp, 0, rp->arg_reg, rp->arity, fcalls);
done_gc |= ERTS_ORDINARY_GC__;
}
if (need_gc & ERTS_LITERAL_GC__) {
struct erl_off_heap_header* oh;
oh = modp->old.code_hdr->literals_off_heap;
*redsp += lit_bsize / 64; /* Need, better value... */
erts_garbage_collect_literals(rp, (Eterm*)literals, lit_bsize, oh);
done_gc |= ERTS_LITERAL_GC__;
}
need_gc = 0;
}
#undef ERTS_ORDINARY_GC__
#undef ERTS_LITERAL_GC__
}
static Eterm
check_process_code(Process* rp, Module* modp)
{
Eterm* start;
char* mod_start;
Uint mod_size;
Eterm* end;
Eterm* sp;
#ifndef HYBRID /* FIND ME! */
ErlFunThing* funp;
int done_gc = 0;
#endif
#define INSIDE(a) (start <= (a) && (a) < end)
if (modp == NULL) { /* Doesn't exist. */
return am_false;
} else if (modp->old_code == NULL) { /* No old code. */
return am_false;
}
/*
* Pick up limits for the module.
*/
start = modp->old_code;
end = (Eterm *)((char *)start + modp->old_code_length);
mod_start = (char *) start;
mod_size = modp->old_code_length;
/*
* Check if current instruction or continuation pointer points into module.
*/
if (INSIDE(rp->i) || INSIDE(rp->cp)) {
return am_true;
}
/*
* Check all continuation pointers stored on the stack.
*/
for (sp = rp->stop; sp < STACK_START(rp); sp++) {
if (is_CP(*sp) && INSIDE(cp_val(*sp))) {
return am_true;
}
}
/*
* Check all continuation pointers stored in stackdump
* and clear exception stackdump if there is a pointer
* to the module.
*/
if (rp->ftrace != NIL) {
struct StackTrace *s;
ASSERT(is_list(rp->ftrace));
s = (struct StackTrace *) big_val(CDR(list_val(rp->ftrace)));
if ((s->pc && INSIDE(s->pc)) ||
(s->current && INSIDE(s->current))) {
rp->freason = EXC_NULL;
rp->fvalue = NIL;
rp->ftrace = NIL;
} else {
int i;
for (i = 0; i < s->depth; i++) {
if (INSIDE(s->trace[i])) {
rp->freason = EXC_NULL;
rp->fvalue = NIL;
rp->ftrace = NIL;
break;
}
}
}
}
/*
* See if there are funs that refer to the old version of the module.
*/
#ifndef HYBRID /* FIND ME! */
rescan:
for (funp = MSO(rp).funs; funp; funp = funp->next) {
Eterm* fun_code;
fun_code = funp->fe->address;
if (INSIDE((Eterm *) funp->fe->address)) {
if (done_gc) {
return am_true;
} else {
/*
* Try to get rid of this fun by garbage collecting.
* Clear both fvalue and ftrace to make sure they
* don't hold any funs.
*/
rp->freason = EXC_NULL;
rp->fvalue = NIL;
rp->ftrace = NIL;
done_gc = 1;
FLAGS(rp) |= F_NEED_FULLSWEEP;
(void) erts_garbage_collect(rp, 0, rp->arg_reg, rp->arity);
goto rescan;
}
}
}
#endif
/*
* See if there are constants inside the module referenced by the process.
*/
done_gc = 0;
for (;;) {
ErlMessage* mp;
if (any_heap_ref_ptrs(&rp->fvalue, &rp->fvalue+1, mod_start, mod_size)) {
rp->freason = EXC_NULL;
rp->fvalue = NIL;
rp->ftrace = NIL;
}
if (any_heap_ref_ptrs(rp->stop, rp->hend, mod_start, mod_size)) {
goto need_gc;
}
if (any_heap_refs(rp->heap, rp->htop, mod_start, mod_size)) {
goto need_gc;
}
if (any_heap_refs(rp->old_heap, rp->old_htop, mod_start, mod_size)) {
goto need_gc;
}
if (rp->dictionary != NULL) {
Eterm* start = rp->dictionary->data;
Eterm* end = start + rp->dictionary->used;
if (any_heap_ref_ptrs(start, end, mod_start, mod_size)) {
goto need_gc;
}
}
for (mp = rp->msg.first; mp != NULL; mp = mp->next) {
if (any_heap_ref_ptrs(mp->m, mp->m+2, mod_start, mod_size)) {
goto need_gc;
}
}
break;
need_gc:
if (done_gc) {
return am_true;
} else {
Eterm* literals;
Uint lit_size;
/*
* Try to get rid of constants by by garbage collecting.
* Clear both fvalue and ftrace.
*/
rp->freason = EXC_NULL;
rp->fvalue = NIL;
rp->ftrace = NIL;
done_gc = 1;
FLAGS(rp) |= F_NEED_FULLSWEEP;
(void) erts_garbage_collect(rp, 0, rp->arg_reg, rp->arity);
literals = (Eterm *) modp->old_code[MI_LITERALS_START];
lit_size = (Eterm *) modp->old_code[MI_LITERALS_END] - literals;
erts_garbage_collect_literals(rp, literals, lit_size);
}
}
return am_false;
#undef INSIDE
}
static Eterm
check_process_code(Process* rp, Module* modp, int *redsp, int fcalls)
{
BeamInstr* start;
char* mod_start;
Uint mod_size;
Eterm* sp;
#ifdef HIPE
void *nat_start = NULL;
Uint nat_size = 0;
#endif
*redsp += 1;
/*
* Pick up limits for the module.
*/
start = (BeamInstr*) modp->old.code_hdr;
mod_start = (char *) start;
mod_size = modp->old.code_length;
/*
* Check if current instruction or continuation pointer points into module.
*/
if (ErtsInArea(rp->i, mod_start, mod_size)
|| ErtsInArea(rp->cp, mod_start, mod_size)) {
return am_true;
}
*redsp += (STACK_START(rp) - rp->stop) / 32;
/*
* Check all continuation pointers stored on the stack.
*/
for (sp = rp->stop; sp < STACK_START(rp); sp++) {
if (is_CP(*sp) && ErtsInArea(cp_val(*sp), mod_start, mod_size)) {
return am_true;
}
}
#ifdef HIPE
/*
* Check all continuation pointers stored on the native stack if the module
* has native code.
*/
if (modp->old.hipe_code) {
nat_start = modp->old.hipe_code->text_segment;
nat_size = modp->old.hipe_code->text_segment_size;
if (nat_size && nstack_any_cps_in_segment(rp, nat_start, nat_size)) {
return am_true;
}
}
#endif
/*
* Check all continuation pointers stored in stackdump
* and clear exception stackdump if there is a pointer
* to the module.
*/
if (rp->ftrace != NIL) {
struct StackTrace *s;
ASSERT(is_list(rp->ftrace));
s = (struct StackTrace *) big_val(CDR(list_val(rp->ftrace)));
if ((s->pc && ErtsInArea(s->pc, mod_start, mod_size)) ||
(s->current && ErtsInArea(s->current, mod_start, mod_size))) {
rp->freason = EXC_NULL;
rp->fvalue = NIL;
rp->ftrace = NIL;
} else {
int i;
char *area_start = mod_start;
Uint area_size = mod_size;
#ifdef HIPE
if (rp->freason & EXF_NATIVE) {
area_start = nat_start;
area_size = nat_size;
}
#endif
for (i = 0; i < s->depth; i++) {
if (ErtsInArea(s->trace[i], area_start, area_size)) {
rp->freason = EXC_NULL;
rp->fvalue = NIL;
rp->ftrace = NIL;
break;
}
}
}
}
return am_false;
}
static ERTS_INLINE Eterm
bld_unique_integer_term(Eterm **hpp, Uint *szp,
Uint64 val0, Uint64 val1,
int positive)
{
Uint hsz;
Uint64 unique_val[2];
unique_val[0] = ((Uint64) val0);
unique_val[0] |= ((Uint64) val1) << unique_data.r.o.left_shift;
unique_val[1] = ((Uint64) val1) >> unique_data.r.o.right_shift;
unique_val[1] &= unique_data.r.o.mask;
if (positive) {
unique_val[0]++;
if (unique_val[0] == 0)
unique_val[1]++;
}
else {
ASSERT(MIN_SMALL < 0);
if (unique_val[1] == 0
&& unique_val[0] < ((Uint64) -1*((Sint64) MIN_SMALL))) {
Sint64 s_unique_val = (Sint64) unique_val[0];
s_unique_val += MIN_SMALL;
ASSERT(MIN_SMALL <= s_unique_val && s_unique_val < 0);
if (szp)
*szp = 0;
if (!hpp)
return THE_NON_VALUE;
return make_small((Sint) s_unique_val);
}
if (unique_val[0] < ((Uint64) -1*((Sint64) MIN_SMALL))) {
ASSERT(unique_val[1] != 0);
unique_val[1] -= 1;
}
unique_val[0] += MIN_SMALL;
}
if (!unique_val[1]) {
if (unique_val[0] <= MAX_SMALL) {
if (szp)
*szp = 0;
if (!hpp)
return THE_NON_VALUE;
return make_small((Uint) unique_val[0]);
}
if (szp)
*szp = ERTS_UINT64_HEAP_SIZE(unique_val[0]);
if (!hpp)
return THE_NON_VALUE;
return erts_uint64_to_big(unique_val[0], hpp);
}
else {
Eterm tmp, *tmp_hp, res;
DeclareTmpHeapNoproc(local_heap, 2*ERTS_MAX_UNIQUE_INT_HEAP_SIZE);
UseTmpHeapNoproc(2*ERTS_MAX_UNIQUE_INT_HEAP_SIZE);
tmp_hp = local_heap;
tmp = erts_uint64_array_to_big(&tmp_hp, 0, 2, unique_val);
ASSERT(is_big(tmp));
hsz = big_arity(tmp) + 1;
ASSERT(hsz <= ERTS_MAX_UNIQUE_INT_HEAP_SIZE);
if (szp)
*szp = hsz;
if (!hpp)
res = THE_NON_VALUE;
else {
int hix;
Eterm *hp = *hpp;
tmp_hp = big_val(tmp);
for (hix = 0; hix < hsz; hix++)
hp[hix] = tmp_hp[hix];
*hpp = hp + hsz;
res = make_big(hp);
}
UnUseTmpHeapNoproc(2*ERTS_MAX_UNIQUE_INT_HEAP_SIZE);
return res;
}
}
