Beispiel #1
0
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;
}
Beispiel #2
0
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;
}
Beispiel #3
0
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;
	}
}
Beispiel #4
0
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;
}
Beispiel #5
0
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;
}
Beispiel #6
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;
}
Beispiel #7
0
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");
	}
}
Beispiel #8
0
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;
}
Beispiel #9
0
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;
}
Beispiel #10
0
proc_t *scheduler_lookup(term_t pid)
{
	assert(is_short_pid(pid));
	return hash_get(registry, &pid, sizeof(pid));
}
Beispiel #11
0
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);
}
Beispiel #12
0
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);
}