term_t cbif_unlink1(proc_t *proc, term_t *regs)
{
term_t PidOid = regs[0];
if (!is_short_pid(PidOid) && !is_short_oid(PidOid))
badarg(PidOid);
proc_t *peer_proc = 0;
outlet_t *peer_outlet = 0;
if (is_short_pid(PidOid))
peer_proc = scheduler_lookup(PidOid);
else
peer_outlet = outlet_lookup(PidOid);
inter_links_t *peer_links = 0;
if (peer_proc != 0)
peer_links = &peer_proc->links;
else if (peer_outlet != 0)
peer_links = &peer_outlet->links;
if (peer_links != 0)
{
if (are_inter_linked(&proc->links, PidOid))
{
inter_link_break(&proc->links, PidOid);
inter_link_break(peer_links, proc->pid);
}
}
return A_TRUE;
}
term_t cbif_monitor2(proc_t *proc, term_t *regs)
{
term_t Type = regs[0];
term_t Item = regs[1];
if (Type != A_PROCESS)
badarg(Type);
if (!is_short_pid(Item) && !is_atom(Item))
badarg(Item);
term_t ref = heap_make_ref(&proc->hp);
proc_t *target = (is_short_pid(Item))
?scheduler_lookup(Item)
:scheduler_process_by_name(Item);
if (target == 0)
{
// the process is gone already - send notification immediately
// {'DOWN',#Ref<0.0.0.38>,process,<0.34.0>,noproc}
term_t msg = heap_tuple5(&proc->hp, ADOWN__, ref, A_PROCESS, Item, A_NOPROC);
int x = scheduler_new_local_mail_N(proc, msg);
if (x < 0)
fail(A_NO_MEMORY);
}
else
{
uint64_t ref_id = local_ref_id(ref);
if (monitor(ref_id, proc->pid, target->pid) < 0)
fail(A_NO_MEMORY);
}
return ref;
}
term_t cbif_link1(proc_t *proc, term_t *regs)
{
term_t PidOid = regs[0];
if (!is_short_pid(PidOid) && !is_short_oid(PidOid))
badarg(PidOid);
if (PidOid == proc->pid)
return A_TRUE;
proc_t *peer_proc = 0;
outlet_t *peer_outlet = 0;
if (is_short_pid(PidOid))
peer_proc = scheduler_lookup(PidOid);
else
peer_outlet = outlet_lookup(PidOid);
inter_links_t *peer_links = 0;
if (peer_proc != 0)
peer_links = &peer_proc->links;
else if (peer_outlet != 0)
peer_links = &peer_outlet->links;
if (peer_proc == 0 && peer_outlet == 0)
{
if (proc->trap_exit == A_TRUE)
{
int x = scheduler_signal_exit_N(proc, proc->pid, A_NOPROC); // does not destroy the proc
if (x < 0)
fail(A_NOT_LINKED);
return A_TRUE;
}
else
fail(A_NOPROC);
}
else
{
if (!are_inter_linked(&proc->links, PidOid))
{
int x = inter_link_establish_N(&proc->links, PidOid);
if (x < 0)
fail(A_NOT_LINKED);
x = inter_link_establish_N(peer_links, proc->pid);
if (x < 0)
{
inter_link_break(&proc->links, PidOid);
fail(A_NOT_LINKED);
}
}
return A_TRUE;
}
}
term_t cbif_group_leader2(proc_t *proc, term_t *rs)
{
term_t Leader = rs[0];
term_t Pid = rs[1];
if (!is_short_pid(Leader) && !is_atom(Leader))
badarg(Leader);
if (!is_short_pid(Pid))
badarg(Pid);
proc_t *peer = scheduler_lookup(Pid);
if (peer == 0)
badarg(Pid);
peer->group_leader = Leader;
return A_TRUE;
}
int etimer_add(uint64_t ref_id, uint64_t timeout,
term_t dst, term_t msg, proc_t *sender, int enveloped)
{
assert(is_atom(dst) || is_short_pid(dst));
if (free_timers == 0)
{
memnode_t *node = nalloc_N(QUICK_SIZE -sizeof(memnode_t));
if (node == 0)
return -NO_MEMORY;
node->next = etimer_nodes;
etimer_nodes = node;
etimer_t *ptr = (etimer_t *)node->starts;
while (ptr +1 <= (etimer_t *)node->ends)
{
ptr->next = free_timers;
free_timers = ptr;
ptr++;
}
assert(free_timers != 0);
}
etimer_t *tm = free_timers;
free_timers = tm->next;
tm->ref_id = ref_id;
tm->timeout = timeout;
tm->dst = dst;
tm->msg = msg;
if (is_immed(msg))
tm->sender = 0;
else
{
sender->pending_timers++;
tm->sender = sender;
}
tm->enveloped = enveloped;
tm->fire = erlang_fire;
etimer_t **ref = &active_timers;
etimer_t *ptr = active_timers;
while (ptr != 0 && ptr->timeout < timeout)
{
ref = &ptr->next;
ptr = ptr->next;
}
tm->next = ptr;
*ref = tm;
return 0;
}
term_t cbif_is_process_alive1(proc_t *proc, term_t *rs)
{
term_t Pid = rs[0];
if (!is_short_pid(Pid))
badarg(Pid);
if (scheduler_lookup(Pid) != 0)
return A_TRUE;
return A_FALSE;
}
static int term_order(term_t t)
{
if (is_cons(t))
return TERM_ORDER_CONS;
if (is_tuple(t))
return TERM_ORDER_TUPLE;
if (is_nil(t))
return TERM_ORDER_NIL;
if (is_int(t))
return TERM_ORDER_NUMBER;
if (is_atom(t))
return TERM_ORDER_ATOM;
if (is_short_pid(t))
return TERM_ORDER_PID;
if (is_short_oid(t))
return TERM_ORDER_OID;
assert(is_boxed(t));
switch (boxed_tag(peel_boxed(t)))
{
case SUBTAG_POS_BIGNUM:
case SUBTAG_NEG_BIGNUM:
case SUBTAG_FLOAT:
return TERM_ORDER_NUMBER;
case SUBTAG_FUN:
return TERM_ORDER_FUN;
case SUBTAG_EXPORT:
return TERM_ORDER_EXPORT;
case SUBTAG_PID:
return TERM_ORDER_PID;
case SUBTAG_OID:
return TERM_ORDER_OID;
case SUBTAG_REF:
return TERM_ORDER_REF;
case SUBTAG_PROC_BIN:
case SUBTAG_HEAP_BIN:
case SUBTAG_MATCH_CTX:
case SUBTAG_SUB_BIN:
return TERM_ORDER_BINARY;
default:
fatal_error("subtag");
}
}
apr_status_t ol_listener_set_option(outlet_t *self, term_t opt, term_t value)
{
if (opt == A_ACCEPT)
{
ol_listener_data_t *data = self->data;
if (!is_short_pid(value))
return APR_BADARG;
data->is_accepting = 1;
data->reply_to_pid = value;
}
else
return APR_BADARG;
return APR_SUCCESS;
}
term_t cbif_process_flag3(proc_t *proc, term_t *regs)
{
term_t Pid = regs[0];
term_t Flag = regs[1];
term_t Value = regs[2];
if (!is_short_pid(Pid))
badarg(Pid);
proc_t *subj = scheduler_lookup(Pid);
if (subj == 0)
badarg(Pid);
if (!is_atom(Flag))
badarg(Flag);
term_t old_val = proc_set_flag(subj, Flag, Value);
if (old_val == noval)
badarg(Value);
return old_val;
}
proc_t *scheduler_lookup(term_t pid)
{
assert(is_short_pid(pid));
return hash_get(registry, &pid, sizeof(pid));
}
term_t cbif_process_info2(proc_t *proc, term_t *regs)
{
term_t Pid = regs[0];
term_t What = regs[1];
if (!is_short_pid(Pid))
badarg(Pid);
if (!is_atom(What))
badarg(What);
proc_t *probe = scheduler_lookup(Pid);
if (probe == 0)
return A_UNDEFINED;
term_t val;
if (What == A_BACKTRACE)
{
//TODO: current stack trace is not enough
val = A_UNDEFINED;
}
else if (What == A_BINARY)
{
//NB: BinInfo is documented to be a list, yet its contents is unspesfied
val = int_to_term(probe->hp.total_pb_size, &probe->hp);
}
else if (What == A_CATCHLEVEL)
{
assert(fits_int(probe->catch_level));
val = tag_int(probe->catch_level);
}
else if (What == A_CURRENT_FUNCTION)
{
// NB: probe->cap.ip is valid even if proc == probe
uint32_t *fi = backstep_to_func_info(probe->cap.ip);
val = heap_tuple3(&proc->hp, fi[1], fi[2], tag_int(fi[3]));
}
else if (What == A_CURRENT_LOCATION)
{
// NB: probe->cap.ip is valid even if proc == probe
uint32_t *fi = backstep_to_func_info(probe->cap.ip);
term_t loc = nil;
char fname[256];
uint32_t line = code_base_source_line(probe->cap.ip, fname, sizeof(fname));
if (line != 0)
{
term_t f = heap_strz(&proc->hp, fname);
term_t t1 = heap_tuple2(&proc->hp, A_FILE, f);
term_t t2 = heap_tuple2(&proc->hp, A_LINE, tag_int(line));
loc = heap_cons(&proc->hp, t2, nil);
loc = heap_cons(&proc->hp, t1, loc);
}
val = heap_tuple4(&proc->hp, fi[1], fi[2], tag_int(fi[3]), loc);
}
else if (What == A_CURRENT_STACKTRACE)
{
val = probe->stack_trace;
if (probe != proc)
{
int x = heap_copy_terms_N(&proc->hp, &val, 1);
if (x < 0)
fail(err_to_term(x));
}
}
else if (What == A_DICTIONARY)
{
val = probe->dictionary;
if (probe != proc)
{
int x = heap_copy_terms_N(&proc->hp, &val, 1);
if (x < 0)
fail(err_to_term(x));
}
}
else if (What == A_ERROR_HANDLER)
val = A_ERROR_HANDLER;
else if (What == A_GARBAGE_COLLECTION)
{
//TODO
val = A_UNDEFINED;
}
else if (What == A_GROUP_LEADER)
val = probe->group_leader;
else if (What == A_HEAP_SIZE)
val = int_to_term(probe->hp.total_size, &proc->hp);
else if (What == A_INITIAL_CALL)
{
val = (probe->init_call_mod == noval)
?A_UNDEFINED
:heap_tuple3(&proc->hp, probe->init_call_mod,
probe->init_call_func,
tag_int(probe->init_call_arity));
}
else if (What == A_LINKS)
{
term_t ids = nil;
plink_t *pl = probe->links.active;
while (pl != 0)
{
ids = heap_cons(&proc->hp, pl->id, ids);
pl = pl->next;
}
val = ids;
}
else if (What == A_LAST_CALLS)
{
//TODO
val = A_FALSE;
}
else if (What == A_MEMORY)
{
int pages = 0;
pages += probe->home_node->index;
pages += probe->stack_node->index;
memnode_t *node = probe->hp.nodes;
while (node != 0)
{
pages += node->index;
node = node->next;
}
node = probe->mailbox.nodes;
while (node != 0)
{
pages += node->index;
node = node->next;
}
node = probe->links.nodes;
while (node != 0)
{
pages += node->index;
node = node->next;
}
int bytes = pages * PAGE_SIZE;
val = int_to_term(bytes, &proc->hp);
}
else if (What == A_MESSAGE_BINARY)
{
//TODO
val = A_UNDEFINED;
}
else if (What == A_MESSAGE_QUEUE_LEN)
{
int len = msg_queue_len(&probe->mailbox);
assert(fits_int(len));
val = tag_int(len);
}
else if (What == A_MESSAGES)
{
int messages = nil;
message_t *msg = probe->mailbox.head;
while (msg != 0)
{
term_t marsh_body = msg->body;
if (probe != proc)
{
int x = heap_copy_terms_N(&proc->hp, &marsh_body, 1);
if (x < 0)
fail(err_to_term(x));
}
messages = heap_cons(&proc->hp, marsh_body, messages);
msg = msg->next;
}
val = list_rev(messages, &proc->hp);
}
else if (What == A_MIN_HEAP_SIZE)
val = tag_int(INIT_HEAP_SIZE);
else if (What == A_MIN_BIN_VHEAP_SIZE)
{
//TODO
val = A_UNDEFINED;
}
else if (What == A_MONITORED_BY)
val = list_monitored_by(probe->pid, &proc->hp);
else if (What == A_MONITORS)
val = list_monitors(probe->pid, &proc->hp);
else if (What == A_PRIORITY)
val = probe->priority;
else if (What == A_REDUCTIONS)
val = int_to_term(probe->total_reds, &proc->hp);
else if (What == A_REGISTERED_NAME)
{
val = probe->name;
if (val == noval)
return nil; // be backward compatible
}
else if (What == A_SEQUENTIAL_TRACE_TOKEN)
{
//TODO
val = A_UNDEFINED;
}
else if (What == A_STACK_SIZE)
{
int ss = proc_stack_bottom(probe) - proc_stack_top(probe);
assert(fits_int(ss));
val = tag_int(ss);
}
else if (What == A_STATUS)
{
if (probe->my_queue == MY_QUEUE_NORMAL ||
probe->my_queue == MY_QUEUE_HIGH ||
probe->my_queue == MY_QUEUE_LOW)
val = A_RUNNABLE;
else if (probe->my_queue == MY_QUEUE_INF_WAIT ||
probe->my_queue == MY_QUEUE_TIMED_WAIT)
val = A_WAITING;
else
{
assert(probe->my_queue == MY_QUEUE_NONE);
val = A_RUNNING;
}
}
else if (What == A_SUSPENDING)
{
//TODO
val = nil;
}
else if (What == A_TOTAL_HEAP_SIZE)
{
int ss = proc_stack_bottom(probe) - proc_stack_top(probe);
int ths = probe->hp.total_size + ss;
assert(fits_int(ths));
val = tag_int(ths);
}
else if (What == A_TRACE)
{
//TODO
val = A_UNDEFINED;
}
else if (What == A_TRAP_EXIT)
val = probe->trap_exit;
else
badarg(What);
return heap_tuple2(&proc->hp, What, val);
}
int is_term_smaller(term_t a, term_t b)
{
if (a == b)
return 0;
if (are_both_immed(a, b))
{
if (are_both_int(a, b))
return int_value(a) < int_value(b);
if (is_int(a)) // !is_int(b)
return 1;
if (is_nil(a)) // !is_nil(b)
return 0;
if (is_nil(b)) // !is_nil(a)
return 1;
if (is_atom(a))
{
if (is_int(b))
return 0;
else if (is_atom(b))
{
uint8_t *print1 = atoms_get(atom_index(a));
uint8_t *print2 = atoms_get(atom_index(b));
int short_len = (print1[0] < print2[0])
? print1[0]
: print2[0];
int d = memcmp(print1+1, print2+1, short_len);
if (d == 0)
return print1[0] < print2[0];
return d < 0;
}
else
return 1;
}
else if (is_short_oid(a))
{
if (is_int(b) || is_atom(b))
return 0;
else if (is_short_oid(b))
return short_oid_id(a) < short_oid_id(b);
else
return 1;
}
else if (is_short_pid(a))
{
if (is_int(b) || is_atom(b) || is_short_oid(b))
return 0;
else
{
assert(is_short_pid(b));
return short_pid_id(a) < short_pid_id(b);
}
}
}
//TODO: comparison of bignum and float: docs mention the
// number 9007199254740992.0 and a loss of transitivity
if (!is_immed(a) && !is_immed(b) &&
primary_tag(a) == primary_tag(b))
{
if (is_cons(a))
return is_term_smaller_1(a, b);
else if (is_tuple(a))
return is_term_smaller_2(a, b);
else
{
assert(is_boxed(a) && is_boxed(b));
uint32_t *adata = peel_boxed(a);
uint32_t *bdata = peel_boxed(b);
if (boxed_tag(adata) == boxed_tag(bdata) ||
(is_binary(adata) && is_binary(bdata)) ||
(is_bignum(adata) && is_bignum(bdata)))
{
switch(boxed_tag(adata))
{
case SUBTAG_POS_BIGNUM:
case SUBTAG_NEG_BIGNUM:
return bignum_compare((bignum_t *)adata,
(bignum_t *)bdata) < 0;
case SUBTAG_FUN:
return fun_compare((t_fun_t *)adata,
(t_fun_t *)bdata) < 0;
case SUBTAG_EXPORT:
return export_compare((t_export_t *)adata,
(t_export_t *)bdata) < 0;
case SUBTAG_PID:
return pid_compare((t_long_pid_t *)adata,
(t_long_pid_t *)bdata) < 0;
case SUBTAG_OID:
return oid_compare((t_long_oid_t *)adata,
(t_long_oid_t *)bdata) < 0;
case SUBTAG_REF:
return ref_compare((t_long_ref_t *)adata,
(t_long_ref_t *)bdata) < 0;
case SUBTAG_PROC_BIN:
case SUBTAG_HEAP_BIN:
case SUBTAG_MATCH_CTX:
case SUBTAG_SUB_BIN:
return is_term_smaller_3(adata, bdata);
default:
assert(boxed_tag(adata) == SUBTAG_FLOAT);
return float_value(adata) < float_value(bdata);
}
}
}
}
// Number comparison with (mandatory) coercion
//
int use_float = (is_boxed(a) && boxed_tag(peel_boxed(a)) == SUBTAG_FLOAT) ||
(is_boxed(b) && boxed_tag(peel_boxed(b)) == SUBTAG_FLOAT);
if (use_float)
{
if (is_int(a)) // b is always float
return (double)int_value(a) < float_value(peel_boxed(b));
else if (is_boxed(a))
{
uint32_t *adata = peel_boxed(a);
if (is_bignum(adata)) // b is always float
return bignum_to_double((bignum_t *)adata) < float_value(peel_boxed(b));
if (boxed_tag(adata) == SUBTAG_FLOAT)
{
if (is_int(b))
return float_value(adata) < (double)int_value(b);
if (is_boxed(b))
{
uint32_t *bdata = peel_boxed(b);
if (is_bignum(bdata))
return float_value(adata) < bignum_to_double((bignum_t *)bdata);
}
}
}
}
else // use integer
{
if (is_int(a))
{
if (is_boxed(b))
{
uint32_t *bdata = peel_boxed(b);
if (is_bignum(bdata))
{
bignum_t *bbn = (bignum_t *)bdata;
return !bignum_is_neg(bbn);
}
assert(boxed_tag(bdata) != SUBTAG_FLOAT);
}
}
else if (is_boxed(a))
{
uint32_t *adata = peel_boxed(a);
if (is_bignum(adata))
{
bignum_t *abn = (bignum_t *)adata;
if (is_int(b))
return bignum_is_neg(abn);
if (is_boxed(b))
{
uint32_t *bdata = peel_boxed(b);
if (is_bignum(bdata))
return bignum_compare(abn, (bignum_t *)bdata);
assert(boxed_tag(bdata) != SUBTAG_FLOAT);
}
}
assert(boxed_tag(adata) != SUBTAG_FLOAT);
}
}
// a and b are quaranteed to have different types
//
return term_order(a) < term_order(b);
}
