Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
5181 lines (4522 sloc) 131.161 kb
/*
* %CopyrightBegin%
*
* Copyright Ericsson AB 1996-2014. All Rights Reserved.
*
* The contents of this file are subject to the Erlang Public License,
* Version 1.1, (the "License"); you may not use this file except in
* compliance with the License. You should have received a copy of the
* Erlang Public License along with this software. If not, it can be
* retrieved online at http://www.erlang.org/.
*
* Software distributed under the License is distributed on an "AS IS"
* basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
* the License for the specific language governing rights and limitations
* under the License.
*
* %CopyrightEnd%
*/
#ifdef HAVE_CONFIG_H
# include "config.h"
#endif
#include <stddef.h> /* offsetof() */
#include "sys.h"
#include "erl_vm.h"
#include "erl_sys_driver.h"
#include "global.h"
#include "erl_process.h"
#include "error.h"
#define ERL_WANT_HIPE_BIF_WRAPPER__
#include "bif.h"
#undef ERL_WANT_HIPE_BIF_WRAPPER__
#include "big.h"
#include "dist.h"
#include "erl_version.h"
#include "erl_binary.h"
#include "beam_bp.h"
#include "erl_db_util.h"
#include "register.h"
#include "erl_thr_progress.h"
#define ERTS_PTAB_WANT_BIF_IMPL__
#include "erl_ptab.h"
#include "erl_bits.h"
#include "erl_bif_unique.h"
Export *erts_await_result;
static Export* flush_monitor_messages_trap = NULL;
static Export* set_cpu_topology_trap = NULL;
static Export* await_proc_exit_trap = NULL;
static Export* await_port_send_result_trap = NULL;
Export* erts_format_cpu_topology_trap = NULL;
static Export dsend_continue_trap_export;
Export *erts_convert_time_unit_trap = NULL;
static Export *await_sched_wall_time_mod_trap;
static erts_smp_atomic32_t sched_wall_time;
static erts_smp_mtx_t ports_snapshot_mtx;
erts_smp_atomic_t erts_dead_ports_ptr; /* To store dying ports during snapshot */
#define DECL_AM(S) Eterm AM_ ## S = am_atom_put(#S, sizeof(#S) - 1)
/*
* The BIF's now follow, see the Erlang Manual for a description of what
* each individual BIF does.
*/
BIF_RETTYPE spawn_3(BIF_ALIST_3)
{
ErlSpawnOpts so;
Eterm pid;
so.flags = 0;
pid = erl_create_process(BIF_P, BIF_ARG_1, BIF_ARG_2, BIF_ARG_3, &so);
if (is_non_value(pid)) {
BIF_ERROR(BIF_P, so.error_code);
} else {
if (ERTS_USE_MODIFIED_TIMING()) {
BIF_TRAP2(erts_delay_trap, BIF_P, pid, ERTS_MODIFIED_TIMING_DELAY);
}
BIF_RET(pid);
}
}
/**********************************************************************/
/* Utility to add a new link between processes p and another internal
* process (rpid). Process p must be the currently executing process.
*/
static int insert_internal_link(Process* p, Eterm rpid)
{
Process *rp;
ErtsProcLocks rp_locks = ERTS_PROC_LOCK_LINK;
ASSERT(is_internal_pid(rpid));
#ifdef ERTS_SMP
if (IS_TRACED(p)
&& (ERTS_TRACE_FLAGS(p) & (F_TRACE_SOL|F_TRACE_SOL1))) {
rp_locks = ERTS_PROC_LOCKS_ALL;
}
erts_smp_proc_lock(p, ERTS_PROC_LOCK_LINK);
#endif
/* get a pointer to the process struct of the linked process */
rp = erts_pid2proc_opt(p, ERTS_PROC_LOCK_MAIN|ERTS_PROC_LOCK_LINK,
rpid, rp_locks,
ERTS_P2P_FLG_ALLOW_OTHER_X);
if (!rp) {
erts_smp_proc_unlock(p, ERTS_PROC_LOCK_LINK);
return 0;
}
if (p != rp) {
erts_add_link(&ERTS_P_LINKS(p), LINK_PID, rp->common.id);
erts_add_link(&ERTS_P_LINKS(rp), LINK_PID, p->common.id);
ASSERT(is_nil(ERTS_TRACER_PROC(p))
|| is_internal_pid(ERTS_TRACER_PROC(p))
|| is_internal_port(ERTS_TRACER_PROC(p)));
if (IS_TRACED(p)) {
if (ERTS_TRACE_FLAGS(p) & (F_TRACE_SOL|F_TRACE_SOL1)) {
ERTS_TRACE_FLAGS(rp) |= (ERTS_TRACE_FLAGS(p) & TRACEE_FLAGS);
ERTS_TRACER_PROC(rp) = ERTS_TRACER_PROC(p); /* maybe steal */
if (ERTS_TRACE_FLAGS(p) & F_TRACE_SOL1) { /* maybe override */
ERTS_TRACE_FLAGS(rp) &= ~(F_TRACE_SOL1 | F_TRACE_SOL);
ERTS_TRACE_FLAGS(p) &= ~(F_TRACE_SOL1 | F_TRACE_SOL);
}
}
}
}
if (IS_TRACED_FL(rp, F_TRACE_PROCS))
trace_proc(p, rp, am_getting_linked, p->common.id);
if (p == rp)
erts_smp_proc_unlock(p, rp_locks & ~ERTS_PROC_LOCK_MAIN);
else {
erts_smp_proc_unlock(p, ERTS_PROC_LOCK_LINK);
erts_smp_proc_unlock(rp, rp_locks);
}
return 1;
}
/* create a link to the process */
BIF_RETTYPE link_1(BIF_ALIST_1)
{
DistEntry *dep;
if (IS_TRACED_FL(BIF_P, F_TRACE_PROCS)) {
trace_proc(BIF_P, BIF_P, am_link, BIF_ARG_1);
}
/* check that the pid or port which is our argument is OK */
if (is_internal_pid(BIF_ARG_1)) {
if (insert_internal_link(BIF_P, BIF_ARG_1)) {
BIF_RET(am_true);
}
else {
goto res_no_proc;
}
}
if (is_internal_port(BIF_ARG_1)) {
int send_link_signal = 0;
Port *prt = erts_port_lookup(BIF_ARG_1,
(erts_port_synchronous_ops
? ERTS_PORT_SFLGS_INVALID_DRIVER_LOOKUP
: ERTS_PORT_SFLGS_INVALID_LOOKUP));
if (!prt) {
goto res_no_proc;
}
erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_LINK);
if (erts_add_link(&ERTS_P_LINKS(BIF_P), LINK_PID, BIF_ARG_1) >= 0)
send_link_signal = 1;
/* else: already linked */
erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_LINK);
if (send_link_signal) {
Eterm ref;
Eterm *refp = erts_port_synchronous_ops ? &ref : NULL;
switch (erts_port_link(BIF_P, prt, BIF_P->common.id, refp)) {
case ERTS_PORT_OP_DROPPED:
case ERTS_PORT_OP_BADARG:
goto res_no_proc;
case ERTS_PORT_OP_SCHEDULED:
if (refp) {
ASSERT(is_internal_ref(ref));
BIF_TRAP3(await_port_send_result_trap, BIF_P, ref, am_true, am_true);
}
default:
break;
}
}
BIF_RET(am_true);
}
else if (is_external_port(BIF_ARG_1)
&& external_port_dist_entry(BIF_ARG_1) == erts_this_dist_entry) {
goto res_no_proc;
}
if (is_external_pid(BIF_ARG_1)) {
erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_LINK);
/* We may earn time by checking first that we're not linked already */
if (erts_lookup_link(ERTS_P_LINKS(BIF_P), BIF_ARG_1) != NULL) {
erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_LINK);
BIF_RET(am_true);
}
else {
ErtsLink *lnk;
int code;
ErtsDSigData dsd;
dep = external_pid_dist_entry(BIF_ARG_1);
if (dep == erts_this_dist_entry) {
erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_LINK);
goto res_no_proc;
}
code = erts_dsig_prepare(&dsd, dep, BIF_P, ERTS_DSP_RLOCK, 0);
switch (code) {
case ERTS_DSIG_PREP_NOT_ALIVE:
/* Let the dlink trap handle it */
case ERTS_DSIG_PREP_NOT_CONNECTED:
erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_LINK);
BIF_TRAP1(dlink_trap, BIF_P, BIF_ARG_1);
case ERTS_DSIG_PREP_CONNECTED:
/* We are connected. Setup link and send link signal */
erts_smp_de_links_lock(dep);
erts_add_link(&ERTS_P_LINKS(BIF_P), LINK_PID, BIF_ARG_1);
lnk = erts_add_or_lookup_link(&(dep->nlinks),
LINK_PID,
BIF_P->common.id);
ASSERT(lnk != NULL);
erts_add_link(&ERTS_LINK_ROOT(lnk), LINK_PID, BIF_ARG_1);
erts_smp_de_links_unlock(dep);
erts_smp_de_runlock(dep);
erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_LINK);
code = erts_dsig_send_link(&dsd, BIF_P->common.id, BIF_ARG_1);
if (code == ERTS_DSIG_SEND_YIELD)
ERTS_BIF_YIELD_RETURN(BIF_P, am_true);
BIF_RET(am_true);
default:
ASSERT(! "Invalid dsig prepare result");
BIF_ERROR(BIF_P, EXC_INTERNAL_ERROR);
}
}
}
BIF_ERROR(BIF_P, BADARG);
res_no_proc: {
erts_aint32_t state = erts_smp_atomic32_read_nob(&BIF_P->state);
if (state & ERTS_PSFLG_TRAP_EXIT) {
ErtsProcLocks locks = ERTS_PROC_LOCK_MAIN;
erts_deliver_exit_message(BIF_ARG_1, BIF_P, &locks, am_noproc, NIL);
erts_smp_proc_unlock(BIF_P, ~ERTS_PROC_LOCK_MAIN & locks);
BIF_RET(am_true);
}
else
BIF_ERROR(BIF_P, EXC_NOPROC);
}
}
#define ERTS_DEMONITOR_FALSE 2
#define ERTS_DEMONITOR_TRUE 1
#define ERTS_DEMONITOR_BADARG 0
#define ERTS_DEMONITOR_YIELD_TRUE -1
#define ERTS_DEMONITOR_INTERNAL_ERROR -2
static int
remote_demonitor(Process *c_p, DistEntry *dep, Eterm ref, Eterm to)
{
ErtsDSigData dsd;
ErtsMonitor *dmon;
ErtsMonitor *mon;
int code;
int res;
#ifndef ERTS_SMP
int stale_mon = 0;
#endif
ERTS_SMP_LC_ASSERT((ERTS_PROC_LOCK_MAIN|ERTS_PROC_LOCK_LINK)
== erts_proc_lc_my_proc_locks(c_p));
code = erts_dsig_prepare(&dsd, dep, c_p, ERTS_DSP_RLOCK, 0);
switch (code) {
case ERTS_DSIG_PREP_NOT_ALIVE:
case ERTS_DSIG_PREP_NOT_CONNECTED:
#ifndef ERTS_SMP
/* XXX Is this possible? Shouldn't this link
previously have been removed if the node
had previously been disconnected. */
ASSERT(0);
stale_mon = 1;
#endif
/*
* In the smp case this is possible if the node goes
* down just before the call to demonitor.
*/
if (dep) {
erts_smp_de_links_lock(dep);
dmon = erts_remove_monitor(&dep->monitors, ref);
erts_smp_de_links_unlock(dep);
if (dmon)
erts_destroy_monitor(dmon);
}
mon = erts_remove_monitor(&ERTS_P_MONITORS(c_p), ref);
erts_smp_proc_unlock(c_p, ERTS_PROC_LOCK_LINK);
res = ERTS_DEMONITOR_TRUE;
break;
case ERTS_DSIG_PREP_CONNECTED:
erts_smp_de_links_lock(dep);
mon = erts_remove_monitor(&ERTS_P_MONITORS(c_p), ref);
dmon = erts_remove_monitor(&dep->monitors, ref);
erts_smp_de_links_unlock(dep);
erts_smp_de_runlock(dep);
erts_smp_proc_unlock(c_p, ERTS_PROC_LOCK_LINK);
if (!dmon) {
#ifndef ERTS_SMP
/* XXX How is this possible? Shouldn't this link
previously have been removed when the distributed
end was removed. */
ASSERT(0);
stale_mon = 1;
#endif
/*
* This is possible when smp support is enabled.
* 'DOWN' message just arrived.
*/
res = ERTS_DEMONITOR_TRUE;
}
else {
/*
* Soft (no force) send, use ->data in dist slot
* monitor list since in case of monitor name
* the atom is stored there. Yield if necessary.
*/
code = erts_dsig_send_demonitor(&dsd,
c_p->common.id,
(mon->name != NIL
? mon->name
: mon->pid),
ref,
0);
res = (code == ERTS_DSIG_SEND_YIELD
? ERTS_DEMONITOR_YIELD_TRUE
: ERTS_DEMONITOR_TRUE);
erts_destroy_monitor(dmon);
}
break;
default:
ASSERT(! "Invalid dsig prepare result");
return ERTS_DEMONITOR_INTERNAL_ERROR;
}
#ifndef ERTS_SMP
if (stale_mon) {
erts_dsprintf_buf_t *dsbufp = erts_create_logger_dsbuf();
erts_dsprintf(dsbufp, "Stale process monitor %T to ", ref);
if (is_atom(to))
erts_dsprintf(dsbufp, "{%T, %T}", to, dep->sysname);
else
erts_dsprintf(dsbufp, "%T", to);
erts_dsprintf(dsbufp, " found\n");
erts_send_error_to_logger(c_p->group_leader, dsbufp);
}
#endif
/*
* We aren't allowed to destroy 'mon' until now, since 'to'
* may refer into 'mon' (external pid).
*/
ASSERT(mon); /* Since link lock wasn't released between
lookup and remove */
erts_destroy_monitor(mon);
ERTS_SMP_LC_ASSERT(ERTS_PROC_LOCK_MAIN == erts_proc_lc_my_proc_locks(c_p));
return res;
}
static int demonitor(Process *c_p, Eterm ref, Eterm *multip)
{
ErtsMonitor *mon = NULL; /* The monitor entry to delete */
Process *rp; /* Local target process */
Eterm to = NIL; /* Monitor link traget */
DistEntry *dep = NULL; /* Target's distribution entry */
int deref_de = 0;
int res;
int unlock_link = 1;
erts_smp_proc_lock(c_p, ERTS_PROC_LOCK_LINK);
if (is_not_internal_ref(ref)) {
res = ERTS_DEMONITOR_BADARG;
goto done; /* Cannot be this monitor's ref */
}
mon = erts_lookup_monitor(ERTS_P_MONITORS(c_p), ref);
if (!mon) {
res = ERTS_DEMONITOR_FALSE;
goto done;
}
switch (mon->type) {
case MON_TIME_OFFSET:
*multip = am_true;
erts_demonitor_time_offset(ref);
res = ERTS_DEMONITOR_TRUE;
break;
case MON_ORIGIN:
to = mon->pid;
*multip = am_false;
if (is_atom(to)) {
/* Monitoring a name at node to */
ASSERT(is_node_name_atom(to));
dep = erts_sysname_to_connected_dist_entry(to);
ASSERT(dep != erts_this_dist_entry);
if (dep)
deref_de = 1;
} else {
ASSERT(is_pid(to));
dep = pid_dist_entry(to);
}
if (dep != erts_this_dist_entry) {
res = remote_demonitor(c_p, dep, ref, to);
/* remote_demonitor() unlocks link lock on c_p */
unlock_link = 0;
}
else { /* Local monitor */
if (deref_de) {
deref_de = 0;
erts_deref_dist_entry(dep);
}
dep = NULL;
rp = erts_pid2proc_opt(c_p,
ERTS_PROC_LOCK_MAIN|ERTS_PROC_LOCK_LINK,
to,
ERTS_PROC_LOCK_LINK,
ERTS_P2P_FLG_ALLOW_OTHER_X);
mon = erts_remove_monitor(&ERTS_P_MONITORS(c_p), ref);
#ifndef ERTS_SMP
ASSERT(mon);
#else
if (!mon)
res = ERTS_DEMONITOR_FALSE;
else
#endif
{
res = ERTS_DEMONITOR_TRUE;
erts_destroy_monitor(mon);
}
if (rp) {
ErtsMonitor *rmon;
rmon = erts_remove_monitor(&ERTS_P_MONITORS(rp), ref);
if (rp != c_p)
erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_LINK);
if (rmon != NULL)
erts_destroy_monitor(rmon);
}
else {
ERTS_SMP_ASSERT_IS_NOT_EXITING(c_p);
}
}
break;
default:
res = ERTS_DEMONITOR_BADARG;
*multip = am_false;
break;
}
done:
if (unlock_link)
erts_smp_proc_unlock(c_p, ERTS_PROC_LOCK_LINK);
if (deref_de) {
ASSERT(dep);
erts_deref_dist_entry(dep);
}
ERTS_SMP_LC_ASSERT(ERTS_PROC_LOCK_MAIN == erts_proc_lc_my_proc_locks(c_p));
return res;
}
BIF_RETTYPE demonitor_1(BIF_ALIST_1)
{
Eterm multi;
switch (demonitor(BIF_P, BIF_ARG_1, &multi)) {
case ERTS_DEMONITOR_FALSE:
case ERTS_DEMONITOR_TRUE:
BIF_RET(am_true);
case ERTS_DEMONITOR_YIELD_TRUE:
ERTS_BIF_YIELD_RETURN(BIF_P, am_true);
case ERTS_DEMONITOR_BADARG:
BIF_ERROR(BIF_P, BADARG);
case ERTS_DEMONITOR_INTERNAL_ERROR:
default:
ASSERT(! "demonitor(): internal error");
BIF_ERROR(BIF_P, EXC_INTERNAL_ERROR);
}
}
BIF_RETTYPE demonitor_2(BIF_ALIST_2)
{
Eterm res = am_true;
Eterm multi = am_false;
int info = 0;
int flush = 0;
Eterm list = BIF_ARG_2;
while (is_list(list)) {
Eterm* consp = list_val(list);
switch (CAR(consp)) {
case am_flush:
flush = 1;
break;
case am_info:
info = 1;
break;
default:
goto badarg;
}
list = CDR(consp);
}
if (is_not_nil(list))
goto badarg;
switch (demonitor(BIF_P, BIF_ARG_1, &multi)) {
case ERTS_DEMONITOR_FALSE:
if (info)
res = am_false;
if (flush) {
flush_messages:
BIF_TRAP3(flush_monitor_messages_trap, BIF_P,
BIF_ARG_1, multi, res);
}
case ERTS_DEMONITOR_TRUE:
if (multi == am_true && flush)
goto flush_messages;
BIF_RET(res);
case ERTS_DEMONITOR_YIELD_TRUE:
ERTS_BIF_YIELD_RETURN(BIF_P, am_true);
case ERTS_DEMONITOR_BADARG:
badarg:
BIF_ERROR(BIF_P, BADARG);
case ERTS_DEMONITOR_INTERNAL_ERROR:
default:
ASSERT(! "demonitor(): internal error");
BIF_ERROR(BIF_P, EXC_INTERNAL_ERROR);
}
}
/* Type must be atomic object! */
void
erts_queue_monitor_message(Process *p,
ErtsProcLocks *p_locksp,
Eterm ref,
Eterm type,
Eterm item,
Eterm reason)
{
Eterm tup;
Eterm* hp;
Eterm reason_copy, ref_copy, item_copy;
Uint reason_size, ref_size, item_size, heap_size;
ErlOffHeap *ohp;
ErlHeapFragment *bp;
reason_size = IS_CONST(reason) ? 0 : size_object(reason);
item_size = IS_CONST(item) ? 0 : size_object(item);
ref_size = size_object(ref);
heap_size = 6+reason_size+ref_size+item_size;
hp = erts_alloc_message_heap(heap_size,
&bp,
&ohp,
p,
p_locksp);
reason_copy = (IS_CONST(reason)
? reason
: copy_struct(reason, reason_size, &hp, ohp));
item_copy = (IS_CONST(item)
? item
: copy_struct(item, item_size, &hp, ohp));
ref_copy = copy_struct(ref, ref_size, &hp, ohp);
tup = TUPLE5(hp, am_DOWN, ref_copy, type, item_copy, reason_copy);
erts_queue_message(p, p_locksp, bp, tup, NIL);
}
static BIF_RETTYPE
local_pid_monitor(Process *p, Eterm target, Eterm mon_ref, int bool)
{
BIF_RETTYPE ret;
Process *rp;
ErtsProcLocks p_locks = ERTS_PROC_LOCK_MAIN|ERTS_PROC_LOCK_LINK;
ERTS_BIF_PREP_RET(ret, mon_ref);
if (target == p->common.id) {
return ret;
}
erts_smp_proc_lock(p, ERTS_PROC_LOCK_LINK);
rp = erts_pid2proc_opt(p, p_locks,
target, ERTS_PROC_LOCK_LINK,
ERTS_P2P_FLG_ALLOW_OTHER_X);
if (!rp) {
erts_smp_proc_unlock(p, ERTS_PROC_LOCK_LINK);
p_locks &= ~ERTS_PROC_LOCK_LINK;
if (bool)
ret = am_false;
else
erts_queue_monitor_message(p, &p_locks,
mon_ref, am_process, target, am_noproc);
}
else {
ASSERT(rp != p);
if (bool)
ret = am_true;
erts_add_monitor(&ERTS_P_MONITORS(p), MON_ORIGIN, mon_ref, target, NIL);
erts_add_monitor(&ERTS_P_MONITORS(rp), MON_TARGET, mon_ref, p->common.id, NIL);
erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_LINK);
}
erts_smp_proc_unlock(p, p_locks & ~ERTS_PROC_LOCK_MAIN);
return ret;
}
static BIF_RETTYPE
local_name_monitor(Process *p, Eterm target_name)
{
BIF_RETTYPE ret;
Eterm mon_ref;
ErtsProcLocks p_locks = ERTS_PROC_LOCK_MAIN|ERTS_PROC_LOCK_LINK;
Process *rp;
mon_ref = erts_make_ref(p);
ERTS_BIF_PREP_RET(ret, mon_ref);
erts_smp_proc_lock(p, ERTS_PROC_LOCK_LINK);
rp = erts_whereis_process(p, p_locks, target_name, ERTS_PROC_LOCK_LINK,
ERTS_P2P_FLG_ALLOW_OTHER_X);
if (!rp) {
DeclareTmpHeap(lhp,3,p);
Eterm item;
UseTmpHeap(3,p);
erts_smp_proc_unlock(p, ERTS_PROC_LOCK_LINK);
p_locks &= ~ERTS_PROC_LOCK_LINK;
item = TUPLE2(lhp, target_name, erts_this_dist_entry->sysname);
erts_queue_monitor_message(p, &p_locks,
mon_ref, am_process, item, am_noproc);
UnUseTmpHeap(3,p);
}
else if (rp != p) {
erts_add_monitor(&ERTS_P_MONITORS(p), MON_ORIGIN, mon_ref, rp->common.id,
target_name);
erts_add_monitor(&ERTS_P_MONITORS(rp), MON_TARGET, mon_ref, p->common.id,
target_name);
erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_LINK);
}
erts_smp_proc_unlock(p, p_locks & ~ERTS_PROC_LOCK_MAIN);
return ret;
}
static BIF_RETTYPE
remote_monitor(Process *p, Eterm bifarg1, Eterm bifarg2,
DistEntry *dep, Eterm target, int byname)
{
ErtsDSigData dsd;
BIF_RETTYPE ret;
int code;
erts_smp_proc_lock(p, ERTS_PROC_LOCK_LINK);
code = erts_dsig_prepare(&dsd, dep, p, ERTS_DSP_RLOCK, 0);
switch (code) {
case ERTS_DSIG_PREP_NOT_ALIVE:
/* Let the dmonitor_p trap handle it */
case ERTS_DSIG_PREP_NOT_CONNECTED:
erts_smp_proc_unlock(p, ERTS_PROC_LOCK_LINK);
ERTS_BIF_PREP_TRAP2(ret, dmonitor_p_trap, p, bifarg1, bifarg2);
break;
case ERTS_DSIG_PREP_CONNECTED:
if (!(dep->flags & DFLAG_DIST_MONITOR)
|| (byname && !(dep->flags & DFLAG_DIST_MONITOR_NAME))) {
erts_smp_de_runlock(dep);
erts_smp_proc_unlock(p, ERTS_PROC_LOCK_LINK);
ERTS_BIF_PREP_ERROR(ret, p, BADARG);
}
else {
Eterm p_trgt, p_name, d_name, mon_ref;
mon_ref = erts_make_ref(p);
if (byname) {
p_trgt = dep->sysname;
p_name = target;
d_name = target;
}
else {
p_trgt = target;
p_name = NIL;
d_name = NIL;
}
erts_smp_de_links_lock(dep);
erts_add_monitor(&ERTS_P_MONITORS(p), MON_ORIGIN, mon_ref, p_trgt,
p_name);
erts_add_monitor(&(dep->monitors), MON_TARGET, mon_ref, p->common.id,
d_name);
erts_smp_de_links_unlock(dep);
erts_smp_de_runlock(dep);
erts_smp_proc_unlock(p, ERTS_PROC_LOCK_LINK);
code = erts_dsig_send_monitor(&dsd, p->common.id, target, mon_ref);
if (code == ERTS_DSIG_SEND_YIELD)
ERTS_BIF_PREP_YIELD_RETURN(ret, p, mon_ref);
else
ERTS_BIF_PREP_RET(ret, mon_ref);
}
break;
default:
ASSERT(! "Invalid dsig prepare result");
ERTS_BIF_PREP_ERROR(ret, p, EXC_INTERNAL_ERROR);
break;
}
return ret;
}
BIF_RETTYPE monitor_2(BIF_ALIST_2)
{
Eterm target = BIF_ARG_2;
BIF_RETTYPE ret;
DistEntry *dep = NULL;
int deref_de = 0;
/* Only process monitors are implemented */
switch (BIF_ARG_1) {
case am_time_offset: {
Eterm ref;
if (BIF_ARG_2 != am_clock_service)
goto error;
ref = erts_make_ref(BIF_P);
erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_LINK);
erts_add_monitor(&ERTS_P_MONITORS(BIF_P), MON_TIME_OFFSET,
ref, am_clock_service, NIL);
erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_LINK);
erts_monitor_time_offset(BIF_P->common.id, ref);
BIF_RET(ref);
}
case am_process:
break;
default:
goto error;
}
if (is_internal_pid(target)) {
local_pid:
ret = local_pid_monitor(BIF_P, target, erts_make_ref(BIF_P), 0);
} else if (is_external_pid(target)) {
dep = external_pid_dist_entry(target);
if (dep == erts_this_dist_entry)
goto local_pid;
ret = remote_monitor(BIF_P, BIF_ARG_1, BIF_ARG_2, dep, target, 0);
} else if (is_atom(target)) {
ret = local_name_monitor(BIF_P, target);
} else if (is_tuple(target)) {
Eterm *tp = tuple_val(target);
Eterm remote_node;
Eterm name;
if (arityval(*tp) != 2)
goto error;
remote_node = tp[2];
name = tp[1];
if (!is_atom(remote_node) || !is_atom(name)) {
goto error;
}
if (!erts_is_alive && remote_node != am_Noname) {
goto error; /* Remote monitor from (this) undistributed node */
}
dep = erts_sysname_to_connected_dist_entry(remote_node);
if (dep == erts_this_dist_entry) {
deref_de = 1;
ret = local_name_monitor(BIF_P, name);
} else {
if (dep)
deref_de = 1;
ret = remote_monitor(BIF_P, BIF_ARG_1, BIF_ARG_2, dep, name, 1);
}
} else {
error:
ERTS_BIF_PREP_ERROR(ret, BIF_P, BADARG);
}
if (deref_de) {
deref_de = 0;
erts_deref_dist_entry(dep);
}
return ret;
}
/**********************************************************************/
/* this is a combination of the spawn and link BIFs */
BIF_RETTYPE spawn_link_3(BIF_ALIST_3)
{
ErlSpawnOpts so;
Eterm pid;
so.flags = SPO_LINK;
pid = erl_create_process(BIF_P, BIF_ARG_1, BIF_ARG_2, BIF_ARG_3, &so);
if (is_non_value(pid)) {
BIF_ERROR(BIF_P, so.error_code);
} else {
if (ERTS_USE_MODIFIED_TIMING()) {
BIF_TRAP2(erts_delay_trap, BIF_P, pid, ERTS_MODIFIED_TIMING_DELAY);
}
BIF_RET(pid);
}
}
/**********************************************************************/
BIF_RETTYPE spawn_opt_1(BIF_ALIST_1)
{
ErlSpawnOpts so;
Eterm pid;
Eterm* tp;
Eterm ap;
Eterm arg;
Eterm res;
/*
* Check that the first argument is a tuple of four elements.
*/
if (is_not_tuple(BIF_ARG_1)) {
error:
BIF_ERROR(BIF_P, BADARG);
}
tp = tuple_val(BIF_ARG_1);
if (*tp != make_arityval(4))
goto error;
/*
* Store default values for options.
*/
so.flags = SPO_USE_ARGS;
so.min_heap_size = H_MIN_SIZE;
so.min_vheap_size = BIN_VH_MIN_SIZE;
so.priority = PRIORITY_NORMAL;
so.max_gen_gcs = (Uint16) erts_smp_atomic32_read_nob(&erts_max_gen_gcs);
so.scheduler = 0;
/*
* Walk through the option list.
*/
ap = tp[4];
while (is_list(ap)) {
arg = CAR(list_val(ap));
if (arg == am_link) {
so.flags |= SPO_LINK;
} else if (arg == am_monitor) {
so.flags |= SPO_MONITOR;
} else if (is_tuple(arg)) {
Eterm* tp2 = tuple_val(arg);
Eterm val;
if (*tp2 != make_arityval(2))
goto error;
arg = tp2[1];
val = tp2[2];
if (arg == am_priority) {
if (val == am_max)
so.priority = PRIORITY_MAX;
else if (val == am_high)
so.priority = PRIORITY_HIGH;
else if (val == am_normal)
so.priority = PRIORITY_NORMAL;
else if (val == am_low)
so.priority = PRIORITY_LOW;
else
goto error;
} else if (arg == am_min_heap_size && is_small(val)) {
Sint min_heap_size = signed_val(val);
if (min_heap_size < 0) {
goto error;
} else if (min_heap_size < H_MIN_SIZE) {
so.min_heap_size = H_MIN_SIZE;
} else {
so.min_heap_size = erts_next_heap_size(min_heap_size, 0);
}
} else if (arg == am_min_bin_vheap_size && is_small(val)) {
Sint min_vheap_size = signed_val(val);
if (min_vheap_size < 0) {
goto error;
} else if (min_vheap_size < BIN_VH_MIN_SIZE) {
so.min_vheap_size = BIN_VH_MIN_SIZE;
} else {
so.min_vheap_size = erts_next_heap_size(min_vheap_size, 0);
}
} else if (arg == am_fullsweep_after && is_small(val)) {
Sint max_gen_gcs = signed_val(val);
if (max_gen_gcs < 0) {
goto error;
} else {
so.max_gen_gcs = max_gen_gcs;
}
} else if (arg == am_scheduler && is_small(val)) {
Sint scheduler = signed_val(val);
if (scheduler < 0 || erts_no_schedulers < scheduler)
goto error;
so.scheduler = (int) scheduler;
} else {
goto error;
}
} else {
goto error;
}
ap = CDR(list_val(ap));
}
if (is_not_nil(ap)) {
goto error;
}
/*
* Spawn the process.
*/
pid = erl_create_process(BIF_P, tp[1], tp[2], tp[3], &so);
if (is_non_value(pid)) {
BIF_ERROR(BIF_P, so.error_code);
} else if (so.flags & SPO_MONITOR) {
Eterm* hp = HAlloc(BIF_P, 3);
res = TUPLE2(hp, pid, so.mref);
} else {
res = pid;
}
if (ERTS_USE_MODIFIED_TIMING()) {
BIF_TRAP2(erts_delay_trap, BIF_P, res, ERTS_MODIFIED_TIMING_DELAY);
}
else {
BIF_RET(res);
}
}
/**********************************************************************/
/* remove a link from a process */
BIF_RETTYPE unlink_1(BIF_ALIST_1)
{
Process *rp;
DistEntry *dep;
ErtsLink *l = NULL, *rl = NULL;
/*
* SMP specific note concerning incoming exit signals:
* We have to have at least the status lock during removal of
* the link half on current process, and check for and handle
* a present pending exit while the status lock is held. This
* in order to ensure that we wont be exited by a link after
* it has been removed.
*
* (We also have to have the link lock, of course, in order to
* be allowed to remove the link...)
*/
if (IS_TRACED_FL(BIF_P, F_TRACE_PROCS)) {
trace_proc(BIF_P, BIF_P, am_unlink, BIF_ARG_1);
}
if (is_internal_port(BIF_ARG_1)) {
erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_LINK|ERTS_PROC_LOCK_STATUS);
#ifdef ERTS_SMP
if (ERTS_PROC_PENDING_EXIT(BIF_P))
goto handle_pending_exit;
#endif
l = erts_remove_link(&ERTS_P_LINKS(BIF_P), BIF_ARG_1);
erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_LINK|ERTS_PROC_LOCK_STATUS);
if (l) {
Port *prt;
erts_destroy_link(l);
/* Send unlink signal */
prt = erts_port_lookup(BIF_ARG_1, ERTS_PORT_SFLGS_DEAD);
if (prt) {
ErtsPortOpResult res;
Eterm ref;
Eterm *refp = erts_port_synchronous_ops ? &ref : NULL;
#ifdef DEBUG
ref = NIL;
#endif
res = erts_port_unlink(BIF_P, prt, BIF_P->common.id, refp);
if (refp && res == ERTS_PORT_OP_SCHEDULED) {
ASSERT(is_internal_ref(ref));
BIF_TRAP3(await_port_send_result_trap, BIF_P, ref, am_true, am_true);
}
}
}
BIF_RET(am_true);
}
else if (is_external_port(BIF_ARG_1)
&& external_port_dist_entry(BIF_ARG_1) == erts_this_dist_entry) {
BIF_RET(am_true);
}
if (is_not_pid(BIF_ARG_1))
BIF_ERROR(BIF_P, BADARG);
if (is_external_pid(BIF_ARG_1)) {
ErtsDistLinkData dld;
int code;
ErtsDSigData dsd;
/* Blind removal, we might have trapped or anything, this leaves
us in a state where monitors might be inconsistent, but the dist
code should take care of it. */
erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_LINK|ERTS_PROC_LOCK_STATUS);
#ifdef ERTS_SMP
if (ERTS_PROC_PENDING_EXIT(BIF_P))
goto handle_pending_exit;
#endif
l = erts_remove_link(&ERTS_P_LINKS(BIF_P), BIF_ARG_1);
erts_smp_proc_unlock(BIF_P,
ERTS_PROC_LOCK_LINK|ERTS_PROC_LOCK_STATUS);
if (l)
erts_destroy_link(l);
dep = external_pid_dist_entry(BIF_ARG_1);
if (dep == erts_this_dist_entry) {
BIF_RET(am_true);
}
code = erts_dsig_prepare(&dsd, dep, BIF_P, ERTS_DSP_NO_LOCK, 0);
switch (code) {
case ERTS_DSIG_PREP_NOT_ALIVE:
case ERTS_DSIG_PREP_NOT_CONNECTED:
#if 1
BIF_RET(am_true);
#else
/*
* This is how we used to do it, but the link is obviously not
* active, so I see no point in setting up a connection.
* /Rickard
*/
BIF_TRAP1(dunlink_trap, BIF_P, BIF_ARG_1);
#endif
case ERTS_DSIG_PREP_CONNECTED:
erts_remove_dist_link(&dld, BIF_P->common.id, BIF_ARG_1, dep);
code = erts_dsig_send_unlink(&dsd, BIF_P->common.id, BIF_ARG_1);
erts_destroy_dist_link(&dld);
if (code == ERTS_DSIG_SEND_YIELD)
ERTS_BIF_YIELD_RETURN(BIF_P, am_true);
BIF_RET(am_true);
default:
ASSERT(! "Invalid dsig prepare result");
BIF_ERROR(BIF_P, EXC_INTERNAL_ERROR);
}
}
/* Internal pid... */
erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_LINK|ERTS_PROC_LOCK_STATUS);
/* get process struct */
rp = erts_pid2proc_opt(BIF_P, (ERTS_PROC_LOCK_MAIN
| ERTS_PROC_LOCK_LINK
| ERTS_PROC_LOCK_STATUS),
BIF_ARG_1, ERTS_PROC_LOCK_LINK,
ERTS_P2P_FLG_ALLOW_OTHER_X);
#ifdef ERTS_SMP
if (ERTS_PROC_PENDING_EXIT(BIF_P)) {
if (rp && rp != BIF_P)
erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_LINK);
goto handle_pending_exit;
}
#endif
/* unlink and ignore errors */
l = erts_remove_link(&ERTS_P_LINKS(BIF_P), BIF_ARG_1);
if (l != NULL)
erts_destroy_link(l);
if (!rp) {
ERTS_SMP_ASSERT_IS_NOT_EXITING(BIF_P);
}
else {
rl = erts_remove_link(&ERTS_P_LINKS(rp), BIF_P->common.id);
if (rl != NULL)
erts_destroy_link(rl);
if (IS_TRACED_FL(rp, F_TRACE_PROCS) && rl != NULL) {
trace_proc(BIF_P, rp, am_getting_unlinked, BIF_P->common.id);
}
if (rp != BIF_P)
erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_LINK);
}
erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_LINK|ERTS_PROC_LOCK_STATUS);
BIF_RET(am_true);
#ifdef ERTS_SMP
handle_pending_exit:
erts_handle_pending_exit(BIF_P, (ERTS_PROC_LOCK_MAIN
| ERTS_PROC_LOCK_LINK
| ERTS_PROC_LOCK_STATUS));
ASSERT(ERTS_PROC_IS_EXITING(BIF_P));
erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_LINK|ERTS_PROC_LOCK_STATUS);
ERTS_BIF_EXITED(BIF_P);
#endif
}
BIF_RETTYPE hibernate_3(BIF_ALIST_3)
{
/*
* hibernate/3 is usually translated to an instruction; therefore
* this function is only called from HiPE or when the call could not
* be translated.
*/
Eterm reg[3];
if (erts_hibernate(BIF_P, BIF_ARG_1, BIF_ARG_2, BIF_ARG_3, reg)) {
/*
* If hibernate succeeded, TRAP. The process will be wait in a
* hibernated state if its state is inactive (!ERTS_PSFLG_ACTIVE);
* otherwise, continue executing (if any message was in the queue).
*/
BIF_TRAP_CODE_PTR_(BIF_P, BIF_P->i);
}
return THE_NON_VALUE;
}
/**********************************************************************/
BIF_RETTYPE get_stacktrace_0(BIF_ALIST_0)
{
Eterm t = build_stacktrace(BIF_P, BIF_P->ftrace);
BIF_RET(t);
}
/**********************************************************************/
/*
* This is like exit/1, except that errors are logged if they terminate
* the process, and the final error value will be {Term,StackTrace}.
*/
BIF_RETTYPE error_1(BIF_ALIST_1)
{
BIF_P->fvalue = BIF_ARG_1;
BIF_ERROR(BIF_P, EXC_ERROR);
}
/**********************************************************************/
/*
* This is like error/1, except that the given 'args' will be included
* in the stacktrace.
*/
BIF_RETTYPE error_2(BIF_ALIST_2)
{
Eterm* hp = HAlloc(BIF_P, 3);
BIF_P->fvalue = TUPLE2(hp, BIF_ARG_1, BIF_ARG_2);
BIF_ERROR(BIF_P, EXC_ERROR_2);
}
/**********************************************************************/
/*
* This is like exactly like error/1. The only difference is
* that Dialyzer thinks that it it will return an arbitrary term.
* It is useful in stub functions for NIFs.
*/
BIF_RETTYPE nif_error_1(BIF_ALIST_1)
{
BIF_P->fvalue = BIF_ARG_1;
BIF_ERROR(BIF_P, EXC_ERROR);
}
/**********************************************************************/
/*
* This is like exactly like error/2. The only difference is
* that Dialyzer thinks that it it will return an arbitrary term.
* It is useful in stub functions for NIFs.
*/
BIF_RETTYPE nif_error_2(BIF_ALIST_2)
{
Eterm* hp = HAlloc(BIF_P, 3);
BIF_P->fvalue = TUPLE2(hp, BIF_ARG_1, BIF_ARG_2);
BIF_ERROR(BIF_P, EXC_ERROR_2);
}
/**********************************************************************/
/* this is like throw/1 except that we set freason to EXC_EXIT */
BIF_RETTYPE exit_1(BIF_ALIST_1)
{
BIF_P->fvalue = BIF_ARG_1; /* exit value */
BIF_ERROR(BIF_P, EXC_EXIT);
}
/**********************************************************************/
/* raise an exception of given class, value and stacktrace.
*
* If there is an error in the argument format,
* return the atom 'badarg' instead.
*/
BIF_RETTYPE raise_3(BIF_ALIST_3)
{
Process *c_p = BIF_P;
Eterm class = BIF_ARG_1;
Eterm value = BIF_ARG_2;
Eterm stacktrace = BIF_ARG_3;
Eterm reason;
Eterm l, *hp, *hp_end, *tp;
int depth, cnt;
size_t sz;
int must_copy = 0;
struct StackTrace *s;
if (class == am_error) {
c_p->fvalue = value;
reason = EXC_ERROR;
} else if (class == am_exit) {
c_p->fvalue = value;
reason = EXC_EXIT;
} else if (class == am_throw) {
c_p->fvalue = value;
reason = EXC_THROWN;
} else goto error;
reason &= ~EXF_SAVETRACE;
/* Check syntax of stacktrace, and count depth.
* Accept anything that can be returned from erlang:get_stacktrace/0,
* as well as a 2-tuple with a fun as first element that the
* error_handler may need to give us. Also allow old-style
* MFA three-tuples.
*/
for (l = stacktrace, depth = 0;
is_list(l);
l = CDR(list_val(l)), depth++) {
Eterm t = CAR(list_val(l));
Eterm location = NIL;
if (is_not_tuple(t)) goto error;
tp = tuple_val(t);
switch (arityval(tp[0])) {
case 2:
/* {Fun,Args} */
if (is_fun(tp[1])) {
must_copy = 1;
} else {
goto error;
}
break;
case 3:
/*
* One of:
* {Fun,Args,Location}
* {M,F,A}
*/
if (is_fun(tp[1])) {
location = tp[3];
} else if (is_atom(tp[1]) && is_atom(tp[2])) {
must_copy = 1;
} else {
goto error;
}
break;
case 4:
if (!(is_atom(tp[1]) && is_atom(tp[2]))) {
goto error;
}
location = tp[4];
break;
default:
goto error;
}
if (is_not_list(location) && is_not_nil(location)) {
goto error;
}
}
if (is_not_nil(l)) goto error;
/* Create stacktrace and store */
if (erts_backtrace_depth < depth) {
depth = erts_backtrace_depth;
must_copy = 1;
}
if (must_copy) {
cnt = depth;
c_p->ftrace = NIL;
} else {
/* No need to copy the stacktrace */
cnt = 0;
c_p->ftrace = stacktrace;
}
tp = &c_p->ftrace;
sz = (offsetof(struct StackTrace, trace) + sizeof(Eterm) - 1)
/ sizeof(Eterm);
hp = HAlloc(c_p, sz + (2+6)*(cnt + 1));
hp_end = hp + sz + (2+6)*(cnt + 1);
s = (struct StackTrace *) hp;
s->header = make_neg_bignum_header(sz - 1);
s->freason = reason;
s->pc = NULL;
s->current = NULL;
s->depth = 0;
hp += sz;
if (must_copy) {
int cnt;
/* Copy list up to depth */
for (cnt = 0, l = stacktrace;
cnt < depth;
cnt++, l = CDR(list_val(l))) {
Eterm t;
Eterm *tpp;
int arity;
ASSERT(*tp == NIL);
t = CAR(list_val(l));
tpp = tuple_val(t);
arity = arityval(tpp[0]);
if (arity == 2) {
t = TUPLE3(hp, tpp[1], tpp[2], NIL);
hp += 4;
} else if (arity == 3 && is_atom(tpp[1])) {
t = TUPLE4(hp, tpp[1], tpp[2], tpp[3], NIL);
hp += 5;
}
*tp = CONS(hp, t, *tp);
tp = &CDR(list_val(*tp));
hp += 2;
}
}
c_p->ftrace = CONS(hp, c_p->ftrace, make_big((Eterm *) s));
hp += 2;
ASSERT(hp <= hp_end);
HRelease(c_p, hp_end, hp);
BIF_ERROR(c_p, reason);
error:
return am_badarg;
}
/**********************************************************************/
/* send an exit message to another process (if trapping exits) or
exit the other process */
BIF_RETTYPE exit_2(BIF_ALIST_2)
{
Process *rp;
/*
* If the first argument is not a pid, or a local port it is an error.
*/
if (is_internal_port(BIF_ARG_1)) {
Eterm ref, *refp;
Uint32 invalid_flags;
Port *prt;
if (erts_port_synchronous_ops) {
refp = &ref;
invalid_flags = ERTS_PORT_SFLGS_INVALID_DRIVER_LOOKUP;
}
else {
refp = NULL;
invalid_flags = ERTS_PORT_SFLGS_INVALID_LOOKUP;
}
prt = erts_port_lookup(BIF_ARG_1, invalid_flags);
if (prt) {
ErtsPortOpResult res;
#ifdef DEBUG
ref = NIL;
#endif
res = erts_port_exit(BIF_P, 0, prt, BIF_P->common.id, BIF_ARG_2, refp);
ERTS_BIF_CHK_EXITED(BIF_P);
if (refp && res == ERTS_PORT_OP_SCHEDULED) {
ASSERT(is_internal_ref(ref));
BIF_TRAP3(await_port_send_result_trap, BIF_P, ref, am_true, am_true);
}
}
BIF_RET(am_true);
}
else if(is_external_port(BIF_ARG_1)
&& external_port_dist_entry(BIF_ARG_1) == erts_this_dist_entry)
BIF_RET(am_true);
/*
* If it is a remote pid, send a signal to the remote node.
*/
if (is_external_pid(BIF_ARG_1)) {
int code;
ErtsDSigData dsd;
DistEntry *dep;
dep = external_pid_dist_entry(BIF_ARG_1);
if(dep == erts_this_dist_entry)
BIF_RET(am_true);
code = erts_dsig_prepare(&dsd, dep, BIF_P, ERTS_DSP_NO_LOCK, 0);
switch (code) {
case ERTS_DSIG_PREP_NOT_ALIVE:
case ERTS_DSIG_PREP_NOT_CONNECTED:
BIF_TRAP2(dexit_trap, BIF_P, BIF_ARG_1, BIF_ARG_2);
case ERTS_DSIG_PREP_CONNECTED:
code = erts_dsig_send_exit2(&dsd, BIF_P->common.id, BIF_ARG_1, BIF_ARG_2);
if (code == ERTS_DSIG_SEND_YIELD)
ERTS_BIF_YIELD_RETURN(BIF_P, am_true);
BIF_RET(am_true);
default:
ASSERT(! "Invalid dsig prepare result");
BIF_ERROR(BIF_P, EXC_INTERNAL_ERROR);
}
}
else if (is_not_internal_pid(BIF_ARG_1)) {
BIF_ERROR(BIF_P, BADARG);
}
else {
/*
* The pid is internal. Verify that it refers to an existing process.
*/
ErtsProcLocks rp_locks;
if (BIF_ARG_1 == BIF_P->common.id) {
rp_locks = ERTS_PROC_LOCKS_ALL;
rp = BIF_P;
erts_smp_proc_lock(rp, ERTS_PROC_LOCKS_ALL_MINOR);
}
else {
rp_locks = ERTS_PROC_LOCKS_XSIG_SEND;
rp = erts_pid2proc(BIF_P, ERTS_PROC_LOCK_MAIN,
BIF_ARG_1, rp_locks);
if (!rp) {
BIF_RET(am_true);
}
}
/*
* Send an exit signal.
*/
erts_send_exit_signal(BIF_P,
BIF_P->common.id,
rp,
&rp_locks,
BIF_ARG_2,
NIL,
NULL,
BIF_P == rp ? ERTS_XSIG_FLG_NO_IGN_NORMAL : 0);
#ifdef ERTS_SMP
if (rp == BIF_P)
rp_locks &= ~ERTS_PROC_LOCK_MAIN;
if (rp_locks)
erts_smp_proc_unlock(rp, rp_locks);
#endif
/*
* We may have exited ourselves and may have to take action.
*/
ERTS_BIF_CHK_EXITED(BIF_P);
BIF_RET(am_true);
}
}
/**********************************************************************/
/* this sets some process info- trapping exits or the error handler */
/* Handle flags common to both process_flag_2 and process_flag_3. */
static BIF_RETTYPE process_flag_aux(Process *BIF_P,
Process *rp,
Eterm flag,
Eterm val)
{
Eterm old_value = NIL; /* shut up warning about use before set */
Sint i;
if (flag == am_save_calls) {
struct saved_calls *scb;
if (!is_small(val))
goto error;
i = signed_val(val);
if (i < 0 || i > 10000)
goto error;
if (i == 0)
scb = NULL;
else {
Uint sz = sizeof(*scb) + (i-1) * sizeof(scb->ct[0]);
scb = erts_alloc(ERTS_ALC_T_CALLS_BUF, sz);
scb->len = i;
scb->cur = 0;
scb->n = 0;
}
scb = ERTS_PROC_SET_SAVED_CALLS_BUF(rp, ERTS_PROC_LOCK_MAIN, scb);
if (!scb)
old_value = make_small(0);
else {
old_value = make_small(scb->len);
erts_free(ERTS_ALC_T_CALLS_BUF, (void *) scb);
}
/* Make sure the process in question is rescheduled
immediately, if it's us, so the call saving takes effect. */
if (rp == BIF_P)
BIF_RET2(old_value, CONTEXT_REDS);
else
BIF_RET(old_value);
}
error:
BIF_ERROR(BIF_P, BADARG);
}
BIF_RETTYPE process_flag_2(BIF_ALIST_2)
{
Eterm old_value;
if (BIF_ARG_1 == am_error_handler) {
if (is_not_atom(BIF_ARG_2)) {
goto error;
}
old_value = erts_proc_set_error_handler(BIF_P,
ERTS_PROC_LOCK_MAIN,
BIF_ARG_2);
BIF_RET(old_value);
}
else if (BIF_ARG_1 == am_priority) {
old_value = erts_set_process_priority(BIF_P, BIF_ARG_2);
if (old_value == THE_NON_VALUE)
goto error;
BIF_RET(old_value);
}
else if (BIF_ARG_1 == am_trap_exit) {
erts_aint32_t state;
Uint trap_exit;
if (BIF_ARG_2 == am_true) {
trap_exit = 1;
} else if (BIF_ARG_2 == am_false) {
trap_exit = 0;
} else {
goto error;
}
/*
* NOTE: It is important that we check for pending exit signals
* and handle them before returning if trap_exit is set to
* true. For more info, see implementation of
* erts_send_exit_signal().
*/
if (trap_exit)
state = erts_smp_atomic32_read_bor_mb(&BIF_P->state,
ERTS_PSFLG_TRAP_EXIT);
else
state = erts_smp_atomic32_read_band_mb(&BIF_P->state,
~ERTS_PSFLG_TRAP_EXIT);
#ifdef ERTS_SMP
if (ERTS_PROC_PENDING_EXIT(BIF_P)) {
erts_handle_pending_exit(BIF_P, ERTS_PROC_LOCK_MAIN);
ERTS_BIF_EXITED(BIF_P);
}
#endif
old_value = (state & ERTS_PSFLG_TRAP_EXIT) ? am_true : am_false;
BIF_RET(old_value);
}
else if (BIF_ARG_1 == am_scheduler) {
ErtsRunQueue *old, *new, *curr;
Sint sched;
erts_aint32_t state;
if (!is_small(BIF_ARG_2))
goto error;
sched = signed_val(BIF_ARG_2);
if (sched < 0 || erts_no_schedulers < sched)
goto error;
if (sched == 0) {
new = NULL;
state = erts_smp_atomic32_read_band_mb(&BIF_P->state,
~ERTS_PSFLG_BOUND);
}
else {
new = erts_schedid2runq(sched);
#ifdef ERTS_SMP
erts_atomic_set_nob(&BIF_P->run_queue, (erts_aint_t) new);
#endif
state = erts_smp_atomic32_read_bor_mb(&BIF_P->state,
ERTS_PSFLG_BOUND);
}
curr = ERTS_GET_SCHEDULER_DATA_FROM_PROC(BIF_P)->run_queue;
old = (ERTS_PSFLG_BOUND & state) ? curr : NULL;
ASSERT(!old || old == curr);
old_value = old ? make_small(old->ix+1) : make_small(0);
if (new && new != curr)
ERTS_BIF_YIELD_RETURN_X(BIF_P, old_value, am_scheduler);
else
BIF_RET(old_value);
}
else if (BIF_ARG_1 == am_min_heap_size) {
Sint i;
if (!is_small(BIF_ARG_2)) {
goto error;
}
i = signed_val(BIF_ARG_2);
if (i < 0) {
goto error;
}
old_value = make_small(BIF_P->min_heap_size);
if (i < H_MIN_SIZE) {
BIF_P->min_heap_size = H_MIN_SIZE;
} else {
BIF_P->min_heap_size = erts_next_heap_size(i, 0);
}
BIF_RET(old_value);
}
else if (BIF_ARG_1 == am_min_bin_vheap_size) {
Sint i;
if (!is_small(BIF_ARG_2)) {
goto error;
}
i = signed_val(BIF_ARG_2);
if (i < 0) {
goto error;
}
old_value = make_small(BIF_P->min_vheap_size);
if (i < BIN_VH_MIN_SIZE) {
BIF_P->min_vheap_size = BIN_VH_MIN_SIZE;
} else {
BIF_P->min_vheap_size = erts_next_heap_size(i, 0);
}
BIF_RET(old_value);
}
else if (BIF_ARG_1 == am_sensitive) {
Uint is_sensitive;
if (BIF_ARG_2 == am_true) {
is_sensitive = 1;
} else if (BIF_ARG_2 == am_false) {
is_sensitive = 0;
} else {
goto error;
}
erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCKS_ALL_MINOR);
old_value = (ERTS_TRACE_FLAGS(BIF_P) & F_SENSITIVE
? am_true
: am_false);
if (is_sensitive) {
ERTS_TRACE_FLAGS(BIF_P) |= F_SENSITIVE;
} else {
ERTS_TRACE_FLAGS(BIF_P) &= ~F_SENSITIVE;
}
erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCKS_ALL_MINOR);
BIF_RET(old_value);
}
else if (BIF_ARG_1 == am_monitor_nodes) {
/*
* This argument is intentionally *not* documented. It is intended
* to be used by net_kernel:monitor_nodes/1.
*/
old_value = erts_monitor_nodes(BIF_P, BIF_ARG_2, NIL);
if (old_value == THE_NON_VALUE)
goto error;
BIF_RET(old_value);
}
else if (is_tuple(BIF_ARG_1)) {
/*
* This argument is intentionally *not* documented. It is intended
* to be used by net_kernel:monitor_nodes/2.
*/
Eterm *tp = tuple_val(BIF_ARG_1);
if (arityval(tp[0]) == 2) {
if (tp[1] == am_monitor_nodes) {
old_value = erts_monitor_nodes(BIF_P, BIF_ARG_2, tp[2]);
if (old_value == THE_NON_VALUE)
goto error;
BIF_RET(old_value);
}
}
/* Fall through and try process_flag_aux() ... */
}
BIF_RET(process_flag_aux(BIF_P, BIF_P, BIF_ARG_1, BIF_ARG_2));
error:
BIF_ERROR(BIF_P, BADARG);
}
BIF_RETTYPE process_flag_3(BIF_ALIST_3)
{
Process *rp;
Eterm res;
if ((rp = erts_pid2proc(BIF_P, ERTS_PROC_LOCK_MAIN,
BIF_ARG_1, ERTS_PROC_LOCK_MAIN)) == NULL) {
BIF_ERROR(BIF_P, BADARG);
}
res = process_flag_aux(BIF_P, rp, BIF_ARG_2, BIF_ARG_3);
if (rp != BIF_P)
erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_MAIN);
return res;
}
/**********************************************************************/
/* register(atom, Process|Port) registers a global process or port
(for this node) */
BIF_RETTYPE register_2(BIF_ALIST_2) /* (Atom, Pid|Port) */
{
if (erts_register_name(BIF_P, BIF_ARG_1, BIF_ARG_2))
BIF_RET(am_true);
else {
BIF_ERROR(BIF_P, BADARG);
}
}
/**********************************************************************/
/* removes the registration of a process or port */
BIF_RETTYPE unregister_1(BIF_ALIST_1)
{
int res;
if (is_not_atom(BIF_ARG_1)) {
BIF_ERROR(BIF_P, BADARG);
}
res = erts_unregister_name(BIF_P, ERTS_PROC_LOCK_MAIN, NULL, BIF_ARG_1);
if (res == 0) {
BIF_ERROR(BIF_P, BADARG);
}
BIF_RET(am_true);
}
/**********************************************************************/
/* find out the pid of a registered process */
/* this is a rather unsafe BIF as it allows users to do nasty things. */
BIF_RETTYPE whereis_1(BIF_ALIST_1)
{
Eterm res;
if (is_not_atom(BIF_ARG_1)) {
BIF_ERROR(BIF_P, BADARG);
}
res = erts_whereis_name_to_id(BIF_P, BIF_ARG_1);
BIF_RET(res);
}
/**********************************************************************/
/*
* erlang:'!'/2
*/
HIPE_WRAPPER_BIF_DISABLE_GC(ebif_bang, 2)
BIF_RETTYPE
ebif_bang_2(BIF_ALIST_2)
{
return erl_send(BIF_P, BIF_ARG_1, BIF_ARG_2);
}
/*
* Send a message to Process, Port or Registered Process.
* Returns non-negative reduction bump or negative result code.
*/
#define SEND_TRAP (-1)
#define SEND_YIELD (-2)
#define SEND_YIELD_RETURN (-3)
#define SEND_BADARG (-4)
#define SEND_USER_ERROR (-5)
#define SEND_INTERNAL_ERROR (-6)
#define SEND_AWAIT_RESULT (-7)
#define SEND_YIELD_CONTINUE (-8)
Sint do_send(Process *p, Eterm to, Eterm msg, Eterm *refp, ErtsSendContext*);
static Sint remote_send(Process *p, DistEntry *dep,
Eterm to, Eterm full_to, Eterm msg,
ErtsSendContext* ctx)
{
Sint res;
int code;
ASSERT(is_atom(to) || is_external_pid(to));
code = erts_dsig_prepare(&ctx->dsd, dep, p, ERTS_DSP_NO_LOCK, !ctx->suspend);
switch (code) {
case ERTS_DSIG_PREP_NOT_ALIVE:
case ERTS_DSIG_PREP_NOT_CONNECTED:
res = SEND_TRAP;
break;
case ERTS_DSIG_PREP_WOULD_SUSPEND:
ASSERT(!ctx->suspend);
res = SEND_YIELD;
break;
case ERTS_DSIG_PREP_CONNECTED: {
if (is_atom(to))
code = erts_dsig_send_reg_msg(to, msg, ctx);
else
code = erts_dsig_send_msg(to, msg, ctx);
/*
* Note that reductions have been bumped on calling
* process by erts_dsig_send_reg_msg() or
* erts_dsig_send_msg().
*/
if (code == ERTS_DSIG_SEND_YIELD)
res = SEND_YIELD_RETURN;
else if (code == ERTS_DSIG_SEND_CONTINUE)
res = SEND_YIELD_CONTINUE;
else
res = 0;
break;
}
default:
ASSERT(! "Invalid dsig prepare result");
res = SEND_INTERNAL_ERROR;
}
if (res >= 0) {
if (IS_TRACED(p))
trace_send(p, full_to, msg);
if (ERTS_PROC_GET_SAVED_CALLS_BUF(p))
save_calls(p, &exp_send);
}
return res;
}
Sint
do_send(Process *p, Eterm to, Eterm msg, Eterm *refp, ErtsSendContext* ctx)
{
Eterm portid;
Port *pt;
Process* rp;
DistEntry *dep;
Eterm* tp;
if (is_internal_pid(to)) {
if (IS_TRACED(p))
trace_send(p, to, msg);
if (ERTS_PROC_GET_SAVED_CALLS_BUF(p))
save_calls(p, &exp_send);
rp = erts_proc_lookup_raw(to);
if (!rp)
return 0;
} else if (is_external_pid(to)) {
dep = external_pid_dist_entry(to);
if(dep == erts_this_dist_entry) {
#if DEBUG
erts_dsprintf_buf_t *dsbufp = erts_create_logger_dsbuf();
erts_dsprintf(dsbufp,
"Discarding message %T from %T to %T in an old "
"incarnation (%d) of this node (%d)\n",
msg,
p->common.id,
to,
external_pid_creation(to),
erts_this_node->creation);
erts_send_error_to_logger(p->group_leader, dsbufp);
#endif
return 0;
}
return remote_send(p, dep, to, to, msg, ctx);
} else if (is_atom(to)) {
Eterm id = erts_whereis_name_to_id(p, to);
rp = erts_proc_lookup(id);
if (rp) {
if (IS_TRACED(p))
trace_send(p, to, msg);
if (ERTS_PROC_GET_SAVED_CALLS_BUF(p))
save_calls(p, &exp_send);
goto send_message;
}
pt = erts_port_lookup(id,
(erts_port_synchronous_ops
? ERTS_PORT_SFLGS_INVALID_DRIVER_LOOKUP
: ERTS_PORT_SFLGS_INVALID_LOOKUP));
if (pt) {
portid = id;
goto port_common;
}
if (IS_TRACED(p))
trace_send(p, to, msg);
if (ERTS_PROC_GET_SAVED_CALLS_BUF(p))
save_calls(p, &exp_send);
return SEND_BADARG;
} else if (is_external_port(to)
&& (external_port_dist_entry(to)
== erts_this_dist_entry)) {
#if DEBUG
erts_dsprintf_buf_t *dsbufp = erts_create_logger_dsbuf();
erts_dsprintf(dsbufp,
"Discarding message %T from %T to %T in an old "
"incarnation (%d) of this node (%d)\n",
msg,
p->common.id,
to,
external_port_creation(to),
erts_this_node->creation);
erts_send_error_to_logger(p->group_leader, dsbufp);
#endif
return 0;
} else if (is_internal_port(to)) {
int ret_val;
portid = to;
pt = erts_port_lookup(portid,
(erts_port_synchronous_ops
? ERTS_PORT_SFLGS_INVALID_DRIVER_LOOKUP
: ERTS_PORT_SFLGS_INVALID_LOOKUP));
port_common:
ret_val = 0;
if (pt) {
int ps_flags = ctx->suspend ? 0 : ERTS_PORT_SIG_FLG_NOSUSPEND;
*refp = NIL;
switch (erts_port_command(p, ps_flags, pt, msg, refp)) {
case ERTS_PORT_OP_CALLER_EXIT:
/* We are exiting... */
return SEND_USER_ERROR;
case ERTS_PORT_OP_BUSY:
/* Nothing has been sent */
if (ctx->suspend)
erts_suspend(p, ERTS_PROC_LOCK_MAIN, pt);
return SEND_YIELD;
case ERTS_PORT_OP_BUSY_SCHEDULED:
/* Message was sent */
if (ctx->suspend) {
erts_suspend(p, ERTS_PROC_LOCK_MAIN, pt);
ret_val = SEND_YIELD_RETURN;
break;
}
/* Fall through */
case ERTS_PORT_OP_SCHEDULED:
if (is_not_nil(*refp)) {
ASSERT(is_internal_ref(*refp));
ret_val = SEND_AWAIT_RESULT;
}
break;
case ERTS_PORT_OP_DROPPED:
case ERTS_PORT_OP_BADARG:
case ERTS_PORT_OP_DONE:
break;
default:
ERTS_INTERNAL_ERROR("Unexpected erts_port_command() result");
break;
}
}
if (IS_TRACED(p)) /* trace once only !! */
trace_send(p, portid, msg);
if (ERTS_PROC_GET_SAVED_CALLS_BUF(p))
save_calls(p, &exp_send);
if (SEQ_TRACE_TOKEN(p) != NIL
#ifdef USE_VM_PROBES
&& SEQ_TRACE_TOKEN(p) != am_have_dt_utag
#endif
) {
seq_trace_update_send(p);
seq_trace_output(SEQ_TRACE_TOKEN(p), msg,
SEQ_TRACE_SEND, portid, p);
}
if (ERTS_PROC_IS_EXITING(p)) {
KILL_CATCHES(p); /* Must exit */
return SEND_USER_ERROR;
}
return ret_val;
} else if (is_tuple(to)) { /* Remote send */
int ret;
tp = tuple_val(to);
if (*tp != make_arityval(2))
return SEND_BADARG;
if (is_not_atom(tp[1]) || is_not_atom(tp[2]))
return SEND_BADARG;
/* sysname_to_connected_dist_entry will return NULL if there
is no dist_entry or the dist_entry has no port,
but remote_send() will handle that. */
dep = erts_sysname_to_connected_dist_entry(tp[2]);
if (dep == erts_this_dist_entry) {
Eterm id;
erts_deref_dist_entry(dep);
if (IS_TRACED(p))
trace_send(p, to, msg);
if (ERTS_PROC_GET_SAVED_CALLS_BUF(p))
save_calls(p, &exp_send);
id = erts_whereis_name_to_id(p, tp[1]);
rp = erts_proc_lookup_raw(id);
if (rp)
goto send_message;
pt = erts_port_lookup(id,
(erts_port_synchronous_ops
? ERTS_PORT_SFLGS_INVALID_DRIVER_LOOKUP
: ERTS_PORT_SFLGS_INVALID_LOOKUP));
if (pt) {
portid = id;
goto port_common;
}
return 0;
}
ret = remote_send(p, dep, tp[1], to, msg, ctx);
if (ret != SEND_YIELD_CONTINUE) {
if (dep) {
erts_deref_dist_entry(dep);
}
} else {
ctx->dep_to_deref = dep;
}
return ret;
} else {
if (IS_TRACED(p)) /* XXX Is this really neccessary ??? */
trace_send(p, to, msg);
if (ERTS_PROC_GET_SAVED_CALLS_BUF(p))
save_calls(p, &exp_send);
return SEND_BADARG;
}
send_message: {
ErtsProcLocks rp_locks = 0;
Sint res;
#ifdef ERTS_SMP
if (p == rp)
rp_locks |= ERTS_PROC_LOCK_MAIN;
#endif
/* send to local process */
res = erts_send_message(p, rp, &rp_locks, msg, 0);
if (erts_use_sender_punish)
res *= 4;
else
res = 0;
erts_smp_proc_unlock(rp,
p == rp
? (rp_locks & ~ERTS_PROC_LOCK_MAIN)
: rp_locks);
return res;
}
}
HIPE_WRAPPER_BIF_DISABLE_GC(send, 3)
BIF_RETTYPE send_3(BIF_ALIST_3)
{
BIF_RETTYPE retval;
Eterm ref;
Process *p = BIF_P;
Eterm to = BIF_ARG_1;
Eterm msg = BIF_ARG_2;
Eterm opts = BIF_ARG_3;
int connect = !0;
Eterm l = opts;
Sint result;
DeclareTypedTmpHeap(ErtsSendContext, ctx, BIF_P);
UseTmpHeap(sizeof(ErtsSendContext)/sizeof(Eterm), BIF_P);
ctx->suspend = !0;
ctx->dep_to_deref = NULL;
ctx->return_term = am_ok;
ctx->dss.reds = (Sint) (ERTS_BIF_REDS_LEFT(p) * TERM_TO_BINARY_LOOP_FACTOR);
ctx->dss.phase = ERTS_DSIG_SEND_PHASE_INIT;
while (is_list(l)) {
if (CAR(list_val(l)) == am_noconnect) {
connect = 0;
} else if (CAR(list_val(l)) == am_nosuspend) {
ctx->suspend = 0;
} else {
ERTS_BIF_PREP_ERROR(retval, p, BADARG);
goto done;
}
l = CDR(list_val(l));
}
if(!is_nil(l)) {
ERTS_BIF_PREP_ERROR(retval, p, BADARG);
goto done;
}
#ifdef DEBUG
ref = NIL;
#endif
result = do_send(p, to, msg, &ref, ctx);
if (result > 0) {
ERTS_VBUMP_REDS(p, result);
if (ERTS_IS_PROC_OUT_OF_REDS(p))
goto yield_return;
ERTS_BIF_PREP_RET(retval, am_ok);
goto done;
}
switch (result) {
case 0:
/* May need to yield even though we do not bump reds here... */
if (ERTS_IS_PROC_OUT_OF_REDS(p))
goto yield_return;
ERTS_BIF_PREP_RET(retval, am_ok);
break;
case SEND_TRAP:
if (connect) {
ERTS_BIF_PREP_TRAP3(retval, dsend3_trap, p, to, msg, opts);
} else {
ERTS_BIF_PREP_RET(retval, am_noconnect);
}
break;
case SEND_YIELD:
if (ctx->suspend) {
ERTS_BIF_PREP_YIELD3(retval,
bif_export[BIF_send_3], p, to, msg, opts);
} else {
ERTS_BIF_PREP_RET(retval, am_nosuspend);
}
break;
case SEND_YIELD_RETURN:
if (!ctx->suspend) {
ERTS_BIF_PREP_RET(retval, am_nosuspend);
break;
}
yield_return:
ERTS_BIF_PREP_YIELD_RETURN(retval, p, am_ok);
break;
case SEND_AWAIT_RESULT:
ASSERT(is_internal_ref(ref));
ERTS_BIF_PREP_TRAP3(retval, await_port_send_result_trap, p, ref, am_nosuspend, am_ok);
break;
case SEND_BADARG:
ERTS_BIF_PREP_ERROR(retval, p, BADARG);
break;
case SEND_USER_ERROR:
ERTS_BIF_PREP_ERROR(retval, p, EXC_ERROR);
break;
case SEND_INTERNAL_ERROR:
ERTS_BIF_PREP_ERROR(retval, p, EXC_INTERNAL_ERROR);
break;
case SEND_YIELD_CONTINUE:
BUMP_ALL_REDS(p);
erts_set_gc_state(p, 0);
ERTS_BIF_PREP_TRAP1(retval, &dsend_continue_trap_export, p,
erts_dsend_export_trap_context(p, ctx));
break;
default:
erl_exit(ERTS_ABORT_EXIT, "send_3 invalid result %d\n", (int)result);
break;
}
done:
UnUseTmpHeap(sizeof(ErtsSendContext)/sizeof(Eterm), BIF_P);
return retval;
}
HIPE_WRAPPER_BIF_DISABLE_GC(send, 2)
BIF_RETTYPE send_2(BIF_ALIST_2)
{
return erl_send(BIF_P, BIF_ARG_1, BIF_ARG_2);
}
static BIF_RETTYPE dsend_continue_trap_1(BIF_ALIST_1)
{
Binary* bin = ((ProcBin*) binary_val(BIF_ARG_1))->val;
ErtsSendContext* ctx = (ErtsSendContext*) ERTS_MAGIC_BIN_DATA(bin);
Sint initial_reds = (Sint) (ERTS_BIF_REDS_LEFT(BIF_P) * TERM_TO_BINARY_LOOP_FACTOR);
int result;
ASSERT(ERTS_MAGIC_BIN_DESTRUCTOR(bin) == erts_dsend_context_dtor);
ctx->dss.reds = initial_reds;
result = erts_dsig_send(&ctx->dsd, &ctx->dss);
switch (result) {
case ERTS_DSIG_SEND_OK:
erts_set_gc_state(BIF_P, 1);
BIF_RET(ctx->return_term);
break;
case ERTS_DSIG_SEND_YIELD: /*SEND_YIELD_RETURN*/
erts_set_gc_state(BIF_P, 1);
if (!ctx->suspend)
BIF_RET(am_nosuspend);
ERTS_BIF_YIELD_RETURN(BIF_P, ctx->return_term);
case ERTS_DSIG_SEND_CONTINUE: { /*SEND_YIELD_CONTINUE*/
BUMP_ALL_REDS(BIF_P);
BIF_TRAP1(&dsend_continue_trap_export, BIF_P, BIF_ARG_1);
}
default:
erl_exit(ERTS_ABORT_EXIT, "dsend_continue_trap invalid result %d\n", (int)result);
break;
}
ASSERT(! "Can not arrive here");
BIF_ERROR(BIF_P, BADARG);
}
Eterm erl_send(Process *p, Eterm to, Eterm msg)
{
Eterm retval;
Eterm ref;
Sint result;
DeclareTypedTmpHeap(ErtsSendContext, ctx, p);
UseTmpHeap(sizeof(ErtsSendContext)/sizeof(Eterm), p);
#ifdef DEBUG
ref = NIL;
#endif
ctx->suspend = !0;
ctx->dep_to_deref = NULL;
ctx->return_term = msg;
ctx->dss.reds = (Sint) (ERTS_BIF_REDS_LEFT(p) * TERM_TO_BINARY_LOOP_FACTOR);
ctx->dss.phase = ERTS_DSIG_SEND_PHASE_INIT;
result = do_send(p, to, msg, &ref, ctx);
if (result > 0) {
ERTS_VBUMP_REDS(p, result);
if (ERTS_IS_PROC_OUT_OF_REDS(p))
goto yield_return;
ERTS_BIF_PREP_RET(retval, msg);
goto done;
}
switch (result) {
case 0:
/* May need to yield even though we do not bump reds here... */
if (ERTS_IS_PROC_OUT_OF_REDS(p))
goto yield_return;
ERTS_BIF_PREP_RET(retval, msg);
break;
case SEND_TRAP:
ERTS_BIF_PREP_TRAP2(retval, dsend2_trap, p, to, msg);
break;
case SEND_YIELD:
ERTS_BIF_PREP_YIELD2(retval, bif_export[BIF_send_2], p, to, msg);
break;
case SEND_YIELD_RETURN:
yield_return:
ERTS_BIF_PREP_YIELD_RETURN(retval, p, msg);
break;
case SEND_AWAIT_RESULT:
ASSERT(is_internal_ref(ref));
ERTS_BIF_PREP_TRAP3(retval,
await_port_send_result_trap, p, ref, msg, msg);
break;
case SEND_BADARG:
ERTS_BIF_PREP_ERROR(retval, p, BADARG);
break;
case SEND_USER_ERROR:
ERTS_BIF_PREP_ERROR(retval, p, EXC_ERROR);
break;
case SEND_INTERNAL_ERROR:
ERTS_BIF_PREP_ERROR(retval, p, EXC_INTERNAL_ERROR);
break;
case SEND_YIELD_CONTINUE:
BUMP_ALL_REDS(p);
erts_set_gc_state(p, 0);
ERTS_BIF_PREP_TRAP1(retval, &dsend_continue_trap_export, p,
erts_dsend_export_trap_context(p, ctx));
break;
default:
erl_exit(ERTS_ABORT_EXIT, "invalid send result %d\n", (int)result);
break;
}
done:
UnUseTmpHeap(sizeof(ErtsSendContext)/sizeof(Eterm), p);
return retval;
}
/**********************************************************************/
/*
* apply/3 is implemented as an instruction and as erlang code in the
* erlang module.
*
* There is only one reason that apply/3 is included in the BIF table:
* The error handling code in the beam emulator passes the pointer to
* this function to the error handling code if the apply instruction
* fails. The error handling use the function pointer to lookup
* erlang:apply/3 in the BIF table.
*
* This function will never be called. (It could be if init did something
* like this: apply(erlang, apply, [M, F, A]). Not recommended.)
*/
BIF_RETTYPE apply_3(BIF_ALIST_3)
{
BIF_ERROR(BIF_P, BADARG);
}
/**********************************************************************/
/* integer to float */
/**********************************************************************/
/* returns the head of a list - this function is unecessary
and is only here to keep Robert happy (Even more, since it's OP as well) */
BIF_RETTYPE hd_1(BIF_ALIST_1)
{
if (is_not_list(BIF_ARG_1)) {
BIF_ERROR(BIF_P, BADARG);
}
BIF_RET(CAR(list_val(BIF_ARG_1)));
}
/**********************************************************************/
/* returns the tails of a list - same comment as above */
BIF_RETTYPE tl_1(BIF_ALIST_1)
{
if (is_not_list(BIF_ARG_1)) {
BIF_ERROR(BIF_P, BADARG);
}
BIF_RET(CDR(list_val(BIF_ARG_1)));
}
/**********************************************************************/
/* return the size of an I/O list */
static Eterm
accumulate(Eterm acc, Uint size)
{
if (is_non_value(acc)) {
/*
* There is no pre-existing accumulator. Allocate a
* bignum buffer with one extra word to be used if
* the bignum grows in the future.
*/
Eterm* hp = (Eterm *) erts_alloc(ERTS_ALC_T_TEMP_TERM,
(BIG_UINT_HEAP_SIZE+1) *
sizeof(Eterm));
return uint_to_big(size, hp);
} else {
Eterm* big;
int need_heap;
/*
* Add 'size' to 'acc' in place. There is always one
* extra word allocated in case the bignum grows by one word.
*/
big = big_val(acc);
need_heap = BIG_NEED_SIZE(BIG_SIZE(big));
acc = big_plus_small(acc, size, big);
if (BIG_NEED_SIZE(big_size(acc)) > need_heap) {
/*
* The extra word has been consumed. Grow the
* allocation by one word.
*/
big = (Eterm *) erts_realloc(ERTS_ALC_T_TEMP_TERM,
big_val(acc),
(need_heap+1) * sizeof(Eterm));
acc = make_big(big);
}
return acc;
}
}
static Eterm
consolidate(Process* p, Eterm acc, Uint size)
{
Eterm* hp;
if (is_non_value(acc)) {
return erts_make_integer(size, p);
} else {
Eterm* big;
Uint sz;
Eterm res;
acc = accumulate(acc, size);
big = big_val(acc);
sz = BIG_NEED_SIZE(BIG_SIZE(big));
hp = HAlloc(p, sz);
res = make_big(hp);
while (sz--) {
*hp++ = *big++;
}
erts_free(ERTS_ALC_T_TEMP_TERM, (void *) big_val(acc));
return res;
}
}
BIF_RETTYPE iolist_size_1(BIF_ALIST_1)
{
Eterm obj, hd;
Eterm* objp;
Uint size = 0;
Uint cur_size;
Uint new_size;
Eterm acc = THE_NON_VALUE;
DECLARE_ESTACK(s);
obj = BIF_ARG_1;
goto L_again;
while (!ESTACK_ISEMPTY(s)) {
obj = ESTACK_POP(s);
L_again:
if (is_list(obj)) {
L_iter_list:
objp = list_val(obj);
hd = CAR(objp);
obj = CDR(objp);
/* Head */
if (is_byte(hd)) {
size++;
if (size == 0) {
acc = accumulate(acc, (Uint) -1);
size = 1;
}
} else if (is_binary(hd) && binary_bitsize(hd) == 0) {
cur_size = binary_size(hd);
if ((new_size = size + cur_size) >= size) {
size = new_size;
} else {
acc = accumulate(acc, size);
size = cur_size;
}
} else if (is_list(hd)) {
ESTACK_PUSH(s, obj);
obj = hd;
goto L_iter_list;
} else if (is_not_nil(hd)) {
goto L_type_error;
}
/* Tail */
if (is_list(obj)) {
goto L_iter_list;
} else if (is_binary(obj) && binary_bitsize(obj) == 0) {
cur_size = binary_size(obj);
if ((new_size = size + cur_size) >= size) {
size = new_size;
} else {
acc = accumulate(acc, size);
size = cur_size;
}
} else if (is_not_nil(obj)) {
goto L_type_error;
}
} else if (is_binary(obj) && binary_bitsize(obj) == 0) {
cur_size = binary_size(obj);
if ((new_size = size + cur_size) >= size) {
size = new_size;
} else {
acc = accumulate(acc, size);
size = cur_size;
}
} else if (is_not_nil(obj)) {
goto L_type_error;
}
}
DESTROY_ESTACK(s);
BIF_RET(consolidate(BIF_P, acc, size));
L_type_error:
DESTROY_ESTACK(s);
BIF_ERROR(BIF_P, BADARG);
}
/**********************************************************************/
/* return the N'th element of a tuple */
BIF_RETTYPE element_2(BIF_ALIST_2)
{
if (is_not_small(BIF_ARG_1)) {
BIF_ERROR(BIF_P, BADARG);
}
if (is_tuple(BIF_ARG_2)) {
Eterm* tuple_ptr = tuple_val(BIF_ARG_2);
Sint ix = signed_val(BIF_ARG_1);
if ((ix >= 1) && (ix <= arityval(*tuple_ptr)))
BIF_RET(tuple_ptr[ix]);
}
BIF_ERROR(BIF_P, BADARG);
}
/**********************************************************************/
/* return the arity of a tuple */
BIF_RETTYPE tuple_size_1(BIF_ALIST_1)
{
if (is_tuple(BIF_ARG_1)) {
return make_small(arityval(*tuple_val(BIF_ARG_1)));
}
BIF_ERROR(BIF_P, BADARG);
}
/**********************************************************************/
/* set the n'th element in a tuple */
BIF_RETTYPE setelement_3(BIF_ALIST_3)
{
Eterm* ptr;
Eterm* hp;
Eterm* resp;
Uint ix;
Uint size;
if (is_not_small(BIF_ARG_1) || is_not_tuple(BIF_ARG_2)) {
error:
BIF_ERROR(BIF_P, BADARG);
}
ptr = tuple_val(BIF_ARG_2);
ix = signed_val(BIF_ARG_1);
size = arityval(*ptr) + 1; /* include arity */
if ((ix < 1) || (ix >= size)) {
goto error;
}
hp = HAlloc(BIF_P, size);
/* copy the tuple */
resp = hp;
sys_memcpy(hp, ptr, sizeof(Eterm)*size);
resp[ix] = BIF_ARG_3;
BIF_RET(make_tuple(resp));
}
/**********************************************************************/
BIF_RETTYPE make_tuple_2(BIF_ALIST_2)
{
Sint n;
Eterm* hp;
Eterm res;
if (is_not_small(BIF_ARG_1) || (n = signed_val(BIF_ARG_1)) < 0 || n > ERTS_MAX_TUPLE_SIZE) {
BIF_ERROR(BIF_P, BADARG);
}
hp = HAlloc(BIF_P, n+1);
res = make_tuple(hp);
*hp++ = make_arityval(n);
while (n--) {
*hp++ = BIF_ARG_2;
}
BIF_RET(res);
}
BIF_RETTYPE make_tuple_3(BIF_ALIST_3)
{
Sint n;
Uint limit;
Eterm* hp;
Eterm res;
Eterm list = BIF_ARG_3;
Eterm* tup;
if (is_not_small(BIF_ARG_1) || (n = signed_val(BIF_ARG_1)) < 0 || n > ERTS_MAX_TUPLE_SIZE) {
error:
BIF_ERROR(BIF_P, BADARG);
}
limit = (Uint) n;
hp = HAlloc(BIF_P, n+1);
res = make_tuple(hp);
*hp++ = make_arityval(n);
tup = hp;
while (n--) {
*hp++ = BIF_ARG_2;
}
while(is_list(list)) {
Eterm* cons;
Eterm hd;
Eterm* tp;
Eterm index;
Uint index_val;
cons = list_val(list);
hd = CAR(cons);
list = CDR(cons);
if (is_not_tuple_arity(hd, 2)) {
goto error;
}
tp = tuple_val(hd);
if (is_not_small(index = tp[1])) {
goto error;
}
if ((index_val = unsigned_val(index) - 1) < limit) {
tup[index_val] = tp[2];
} else {
goto error;
}
}
if (is_not_nil(list)) {
goto error;
}
BIF_RET(res);
}
/**********************************************************************/
BIF_RETTYPE append_element_2(BIF_ALIST_2)
{
Eterm* ptr;
Eterm* hp;
Uint arity;
Eterm res;
if (is_not_tuple(BIF_ARG_1)) {
error:
BIF_ERROR(BIF_P, BADARG);
}
ptr = tuple_val(BIF_ARG_1);
arity = arityval(*ptr);
if (arity + 1 > ERTS_MAX_TUPLE_SIZE)
goto error;
hp = HAlloc(BIF_P, arity + 2);
res = make_tuple(hp);
*hp = make_arityval(arity+1);
while (arity--) {
*++hp = *++ptr;
}
*++hp = BIF_ARG_2;
BIF_RET(res);
}
BIF_RETTYPE insert_element_3(BIF_ALIST_3)
{
Eterm* ptr;
Eterm* hp;
Uint arity;
Eterm res;
Sint ix, c1, c2;
if (is_not_tuple(BIF_ARG_2) || is_not_small(BIF_ARG_1)) {
BIF_ERROR(BIF_P, BADARG);
}
ptr = tuple_val(BIF_ARG_2);
arity = arityval(*ptr);
ix = signed_val(BIF_ARG_1);
if ((ix < 1) || (ix > (arity + 1))) {
BIF_ERROR(BIF_P, BADARG);
}
hp = HAlloc(BIF_P, arity + 1 + 1);
res = make_tuple(hp);
*hp = make_arityval(arity + 1);
c1 = ix - 1;
c2 = arity - ix + 1;
while (c1--) { *++hp = *++ptr; }
*++hp = BIF_ARG_3;
while (c2--) { *++hp = *++ptr; }
BIF_RET(res);
}
BIF_RETTYPE delete_element_2(BIF_ALIST_3)
{
Eterm* ptr;
Eterm* hp;
Uint arity;
Eterm res;
Sint ix, c1, c2;
if (is_not_tuple(BIF_ARG_2) || is_not_small(BIF_ARG_1)) {
BIF_ERROR(BIF_P, BADARG);
}
ptr = tuple_val(BIF_ARG_2);
arity = arityval(*ptr);
ix = signed_val(BIF_ARG_1);
if ((ix < 1) || (ix > arity) || (arity == 0)) {
BIF_ERROR(BIF_P, BADARG);
}
hp = HAlloc(BIF_P, arity + 1 - 1);
res = make_tuple(hp);
*hp = make_arityval(arity - 1);
c1 = ix - 1;
c2 = arity - ix;
while (c1--) { *++hp = *++ptr; }
++ptr;
while (c2--) { *++hp = *++ptr; }
BIF_RET(res);
}
/**********************************************************************/
/* convert an atom to a list of ascii integer */
BIF_RETTYPE atom_to_list_1(BIF_ALIST_1)
{
Atom* ap;
Uint num_chars, num_built, num_eaten;
byte* err_pos;
Eterm res;
#ifdef DEBUG
int ares;
#endif
if (is_not_atom(BIF_ARG_1))
BIF_ERROR(BIF_P, BADARG);
/* read data from atom table */
ap = atom_tab(atom_val(BIF_ARG_1));
if (ap->len == 0)
BIF_RET(NIL); /* the empty atom */
#ifdef DEBUG
ares =
#endif
erts_analyze_utf8(ap->name, ap->len, &err_pos, &num_chars, NULL);
ASSERT(ares == ERTS_UTF8_OK);
res = erts_utf8_to_list(BIF_P, num_chars, ap->name, ap->len, ap->len,
&num_built, &num_eaten, NIL);
ASSERT(num_built == num_chars);
ASSERT(num_eaten == ap->len);
BIF_RET(res);
}
/**********************************************************************/
/* convert a list of ascii integers to an atom */
BIF_RETTYPE list_to_atom_1(BIF_ALIST_1)
{
Eterm res;
char *buf = (char *) erts_alloc(ERTS_ALC_T_TMP, MAX_ATOM_CHARACTERS);
int i = intlist_to_buf(BIF_ARG_1, buf, MAX_ATOM_CHARACTERS);
if (i < 0) {
erts_free(ERTS_ALC_T_TMP, (void *) buf);
i = erts_list_length(BIF_ARG_1);
if (i > MAX_ATOM_CHARACTERS) {
BIF_ERROR(BIF_P, SYSTEM_LIMIT);
}
BIF_ERROR(BIF_P, BADARG);
}
res = erts_atom_put((byte *) buf, i, ERTS_ATOM_ENC_LATIN1, 1);
ASSERT(is_atom(res));
erts_free(ERTS_ALC_T_TMP, (void *) buf);
BIF_RET(res);
}
/* conditionally convert a list of ascii integers to an atom */
BIF_RETTYPE list_to_existing_atom_1(BIF_ALIST_1)
{
int i;
char *buf = (char *) erts_alloc(ERTS_ALC_T_TMP, MAX_ATOM_CHARACTERS);
if ((i = intlist_to_buf(BIF_ARG_1, buf, MAX_ATOM_CHARACTERS)) < 0) {
error:
erts_free(ERTS_ALC_T_TMP, (void *) buf);
BIF_ERROR(BIF_P, BADARG);
} else {
Eterm a;
if (erts_atom_get(buf, i, &a, ERTS_ATOM_ENC_LATIN1)) {
erts_free(ERTS_ALC_T_TMP, (void *) buf);
BIF_RET(a);
} else {
goto error;
}
}
}
/**********************************************************************/
/* convert an integer to a list of ascii integers */
BIF_RETTYPE integer_to_list_1(BIF_ALIST_1)
{
Eterm* hp;
Uint need;
if (is_not_integer(BIF_ARG_1)) {
BIF_ERROR(BIF_P, BADARG);
}
if (is_small(BIF_ARG_1)) {
char *c;
int n;
struct Sint_buf ibuf;
c = Sint_to_buf(signed_val(BIF_ARG_1), &ibuf);
n = sys_strlen(c);
need = 2*n;
hp = HAlloc(BIF_P, need);
BIF_RET(buf_to_intlist(&hp, c, n, NIL));
}
else {
int n = big_decimal_estimate(BIF_ARG_1);
Eterm res;
Eterm* hp_end;
need = 2*n;
hp = HAlloc(BIF_P, need);
hp_end = hp + need;
res = erts_big_to_list(BIF_ARG_1, &hp);
HRelease(BIF_P,hp_end,hp);
BIF_RET(res);
}
}
/**********************************************************************/
/* convert a list of ascii ascii integer value to an integer */
#define LTI_BAD_STRUCTURE 0
#define LTI_NO_INTEGER 1
#define LTI_SOME_INTEGER 2
#define LTI_ALL_INTEGER 3
static int do_list_to_integer(Process *p, Eterm orig_list,
Eterm *integer, Eterm *rest)
{
Sint i = 0;
Uint ui = 0;
int skip = 0;
int neg = 0;
Sint n = 0;
int m;
int lg2;
Eterm res;
Eterm* hp;
Eterm *hp_end;
Eterm lst = orig_list;
Eterm tail = lst;
int error_res = LTI_BAD_STRUCTURE;
if (is_nil(lst)) {
error_res = LTI_NO_INTEGER;
error:
*rest = tail;
*integer = make_small(0);
return error_res;
}
if (is_not_list(lst))
goto error;
/* if first char is a '-' then it is a negative integer */
if (CAR(list_val(lst)) == make_small('-')) {
neg = 1;
skip = 1;
lst = CDR(list_val(lst));
if (is_not_list(lst)) {
tail = lst;
error_res = LTI_NO_INTEGER;
goto error;
}
} else if (CAR(list_val(lst)) == make_small('+')) {
/* ignore plus */
skip = 1;
lst = CDR(list_val(lst));
if (is_not_list(lst)) {
tail = lst;
error_res = LTI_NO_INTEGER;
goto error;
}
}
/* Calculate size and do type check */
while(1) {
if (is_not_small(CAR(list_val(lst)))) {
break;
}
if (unsigned_val(CAR(list_val(lst))) < '0' ||
unsigned_val(CAR(list_val(lst))) > '9') {
break;
}
ui = ui * 10;
ui = ui + unsigned_val(CAR(list_val(lst))) - '0';
n++;
lst = CDR(list_val(lst));
if (is_nil(lst)) {
break;
}
if (is_not_list(lst)) {
break;
}
}
tail = lst;
if (!n) {
error_res = LTI_NO_INTEGER;
goto error;
}
/* If n <= 8 then we know it's a small int
** since 2^27 = 134217728. If n > 8 then we must
** construct a bignum and let that routine do the checking
*/
if (n <= SMALL_DIGITS) { /* It must be small */
if (neg) i = -(Sint)ui;
else i = (Sint)ui;
res = make_small(i);
} else {
/* Convert from log10 to log2 by multiplying with 1/log10(2)=3.3219
which we round up to (3 + 1/3) */
lg2 = (n+1)*3 + (n+1)/3 + 1;
m = (lg2+D_EXP-1)/D_EXP; /* number of digits */
m = BIG_NEED_SIZE(m); /* number of words + thing */
hp = HAlloc(p, m);
hp_end = hp + m;
lst = orig_list;
if (skip)
lst = CDR(list_val(lst));
/* load first digits (at least one digit) */
if ((i = (n % D_DECIMAL_EXP)) == 0)
i = D_DECIMAL_EXP;
n -= i;
m = 0;
while(i--) {
m = 10*m + (unsigned_val(CAR(list_val(lst))) - '0');
lst = CDR(list_val(lst));
}
res = small_to_big(m, hp); /* load first digits */
while(n) {
i = D_DECIMAL_EXP;
n -= D_DECIMAL_EXP;
m = 0;
while(i--) {
m = 10*m + (unsigned_val(CAR(list_val(lst))) - '0');
lst = CDR(list_val(lst));
}
if (is_small(res))
res = small_to_big(signed_val(res), hp);
res = big_times_small(res, D_DECIMAL_BASE, hp);
if (is_small(res))
res = small_to_big(signed_val(res), hp);
res = big_plus_small(res, m, hp);
}
if (neg) {
if (is_small(res))
res = make_small(-signed_val(res));
else {
Uint *big = big_val(res); /* point to thing */
*big = bignum_header_neg(*big);
}
}
if (is_not_small(res)) {
res = big_plus_small(res, 0, hp); /* includes conversion to small */
if (is_not_small(res)) {
hp += (big_arity(res)+1);
}
}
HRelease(p,hp_end,hp);
}
*integer = res;
*rest = tail;
if (tail != NIL) {
return LTI_SOME_INTEGER;
}
return LTI_ALL_INTEGER;
}
BIF_RETTYPE string_to_integer_1(BIF_ALIST_1)
{
Eterm res;
Eterm tail;
Eterm *hp;
/* must be a list */
switch (do_list_to_integer(BIF_P,BIF_ARG_1,&res,&tail)) {
/* HAlloc after do_list_to_integer as it
might HAlloc itself (bignum) */
case LTI_BAD_STRUCTURE:
hp = HAlloc(BIF_P,3);
BIF_RET(TUPLE2(hp, am_error, am_not_a_list));
case LTI_NO_INTEGER:
hp = HAlloc(BIF_P,3);
BIF_RET(TUPLE2(hp, am_error, am_no_integer));
default:
hp = HAlloc(BIF_P,3);
BIF_RET(TUPLE2(hp, res, tail));
}
}
BIF_RETTYPE list_to_integer_1(BIF_ALIST_1)
{
/* Using do_list_to_integer is about twice as fast as using
erts_chars_to_integer because we do not have to copy the
entire list */
Eterm res;
Eterm dummy;
/* must be a list */
if (do_list_to_integer(BIF_P,BIF_ARG_1,&res,&dummy) != LTI_ALL_INTEGER) {
BIF_ERROR(BIF_P,BADARG);
}
BIF_RET(res);
}
BIF_RETTYPE list_to_integer_2(BIF_ALIST_2)
{
/* Bif implementation is about 50% faster than pure erlang,
and since we have erts_chars_to_integer now it is simpler
as well. This could be optmized further if we did not have to
copy the list to buf. */
int i;
Eterm res;
char *buf = NULL;
int base;
i = erts_list_length(BIF_ARG_1);
if (i < 0)
BIF_ERROR(BIF_P, BADARG);
base = signed_val(BIF_ARG_2);
if (base < 2 || base > 36)
BIF_ERROR(BIF_P, BADARG);
/* Take fast path if base it 10 */
if (base == 10)
return list_to_integer_1(BIF_P,&BIF_ARG_1);
buf = (char *) erts_alloc(ERTS_ALC_T_TMP, i + 1);
if (intlist_to_buf(BIF_ARG_1, buf, i) < 0)
goto list_to_integer_1_error;
buf[i] = '\0'; /* null terminal */
if ((res = erts_chars_to_integer(BIF_P,buf,i,base)) == THE_NON_VALUE)
goto list_to_integer_1_error;
erts_free(ERTS_ALC_T_TMP, (void *) buf);
BIF_RET(res);
list_to_integer_1_error:
erts_free(ERTS_ALC_T_TMP, (void *) buf);
BIF_ERROR(BIF_P, BADARG);
}
/**********************************************************************/
static int do_float_to_charbuf(Process *p, Eterm efloat, Eterm list,
char *fbuf, int sizeof_fbuf) {
const static int arity_two = make_arityval(2);
int decimals = SYS_DEFAULT_FLOAT_DECIMALS;
int compact = 0;
enum fmt_type_ {
FMT_LEGACY,
FMT_FIXED,
FMT_SCIENTIFIC
} fmt_type = FMT_LEGACY;
Eterm arg;
FloatDef f;
/* check the arguments */
if (is_not_float(efloat))
goto badarg;
for(; is_list(list); list = CDR(list_val(list))) {
arg = CAR(list_val(list));
if (arg == am_compact) {
compact = 1;
continue;
} else if (is_tuple(arg)) {
Eterm* tp = tuple_val(arg);
if (*tp == arity_two && is_small(tp[2])) {
decimals = signed_val(tp[2]);
switch (tp[1]) {
case am_decimals:
fmt_type = FMT_FIXED;
continue;
case am_scientific:
fmt_type = FMT_SCIENTIFIC;
continue;
}
}
}
goto badarg;
}
if (is_not_nil(list)) {
goto badarg;
}
GET_DOUBLE(efloat, f);
if (fmt_type == FMT_FIXED) {
return sys_double_to_chars_fast(f.fd, fbuf, sizeof_fbuf,
decimals, compact);
} else {
return sys_double_to_chars_ext(f.fd, fbuf, sizeof_fbuf, decimals);
}
badarg:
return -1;
}
/* convert a float to a list of ascii characters */
static BIF_RETTYPE do_float_to_list(Process *BIF_P, Eterm arg, Eterm opts) {
int used;
Eterm* hp;
char fbuf[256];
if ((used = do_float_to_charbuf(BIF_P,arg,opts,fbuf,sizeof(fbuf))) <= 0) {
BIF_ERROR(BIF_P, BADARG);
}
hp = HAlloc(BIF_P, (Uint)used*2);
BIF_RET(buf_to_intlist(&hp, fbuf, (Uint)used, NIL));
}
BIF_RETTYPE float_to_list_1(BIF_ALIST_1)
{
return do_float_to_list(BIF_P,BIF_ARG_1,NIL);
}
BIF_RETTYPE float_to_list_2(BIF_ALIST_2)
{
return do_float_to_list(BIF_P,BIF_ARG_1,BIF_ARG_2);
}
/* convert a float to a binary of ascii characters */
static BIF_RETTYPE do_float_to_binary(Process *BIF_P, Eterm arg, Eterm opts) {
int used;
char fbuf[256];
if ((used = do_float_to_charbuf(BIF_P,arg,opts,fbuf,sizeof(fbuf))) <= 0) {
BIF_ERROR(BIF_P, BADARG);
}
BIF_RET(new_binary(BIF_P, (byte*)fbuf, (Uint)used));
}
BIF_RETTYPE float_to_binary_1(BIF_ALIST_1)
{
return do_float_to_binary(BIF_P,BIF_ARG_1,NIL);
}
BIF_RETTYPE float_to_binary_2(BIF_ALIST_2)
{
return do_float_to_binary(BIF_P,BIF_ARG_1,BIF_ARG_2);
}
/**********************************************************************/
/* convert a list of ascii integer values e's +'s and -'s to a float */
#define SIGN 0
#define INT 1
#define FRAC 2
#define EXP_SIGN 3
#define EXP0 4
#define EXP1 5
#define END 6
#define IS_DOT(x) (unsigned_val((x)) == '.' || unsigned_val((x)) == ',')
#define IS_E(x) (unsigned_val((x)) == 'e' || unsigned_val((x)) == 'E')
#define IS_DIGIT(x) (unsigned_val((x)) >= '0' && unsigned_val((x)) <= '9')
#define SAVE_E(xi,xim,xl,xlm) ((xim)=(xi), (xlm)=(xl))
#define LOAD_E(xi,xim,xl,xlm) ((xi)=(xim), (xl)=(xlm))
#define STRING_TO_FLOAT_BUF_INC_SZ (128)
BIF_RETTYPE string_to_float_1(BIF_ALIST_1)
{
Eterm orig = BIF_ARG_1;
Eterm list = orig;
Eterm list_mem = list;
int i = 0;
int i_mem = 0;
Eterm* hp;
Eterm error_res = NIL;
int part = SIGN; /* expect a + or - (or a digit) first */
FloatDef f;
Eterm tup;
byte *buf = NULL;
Uint bufsz = STRING_TO_FLOAT_BUF_INC_SZ;
/* check it's a valid list to start with */
if (is_nil(list)) {
error_res = am_no_float;
error:
if (buf)
erts_free(ERTS_ALC_T_TMP, (void *) buf);
hp = HAlloc(BIF_P, 3);
BIF_RET(TUPLE2(hp, am_error, error_res));
}
if (is_not_list(list)) {
error_res = am_not_a_list;
goto error;
}
buf = (byte *) erts_alloc(ERTS_ALC_T_TMP, bufsz);
/*
The float might start with a SIGN (+ | -). It must contain an integer
part, INT, followed by a delimiter (. | ,) and a fractional, FRAC,
part. The float might also contain an exponent. If e or E indicates
this we will look for a possible EXP_SIGN (+ | -) followed by the
exponential number, EXP. (EXP0 is the first digit and EXP1 the rest).
When we encounter an expected e or E, we can't tell if it's part of
the float or the rest of the string. We save the current position
with SAVE_E. If we later find out it was not part of the float, we
restore the position (end of the float) with LOAD_E.
*/
while(1) {
if (is_not_small(CAR(list_val(list))))
goto back_to_e;
if (CAR(list_val(list)) == make_small('-')) {
switch (part) {
case SIGN: /* expect integer part next */
part = INT;
break;
case EXP_SIGN: /* expect first digit in exp */
part = EXP0;
break;
case EXP0: /* example: "2.3e--" */
LOAD_E(i, i_mem, list, list_mem);
default: /* unexpected - done */
part = END;
}
} else if (CAR(list_val(list)) == make_small('+')) {
switch (part) {
case SIGN: /* expect integer part next */
part = INT;
goto skip;
case EXP_SIGN: /* expect first digit in exp */
part = EXP0;
break;
case EXP0: /* example: "2.3e++" */
LOAD_E(i, i_mem, list, list_mem);
default: /* unexpected - done */
part = END;
}
} else if (IS_DOT(CAR(list_val(list)))) { /* . or , */
switch (part) {
case INT: /* expect fractional part next */
part = FRAC;
break;
case EXP_SIGN: /* example: "2.3e." */
LOAD_E(i, i_mem, list, list_mem);
case EXP0: /* example: "2.3e+." */
LOAD_E(i, i_mem, list, list_mem);
default: /* unexpected - done */
part = END;
}
} else if (IS_E(CAR(list_val(list)))) { /* e or E */
switch (part) {
case FRAC: /* expect a + or - (or a digit) next */
/*
remember the position of e in case we find out later
that it was not part of the float, e.g. "2.3eh?"
*/
SAVE_E(i, i_mem, list, list_mem);
part = EXP_SIGN;
break;
case EXP0: /* example: "2.3e+e" */
case EXP_SIGN: /* example: "2.3ee" */
LOAD_E(i, i_mem, list, list_mem);
case INT: /* would like this to be ok, example "2e2",
but it's not compatible with list_to_float */
default: /* unexpected - done */
part = END;
}
} else if (IS_DIGIT(CAR(list_val(list)))) { /* digit */
switch (part) {
case SIGN: /* got initial digit in integer part */
part = INT; /* expect more digits to follow */
break;
case EXP_SIGN: /* expect exponential part */
case EXP0: /* expect rest of exponential */
part = EXP1;
break;
}
} else /* character not part of float - done */
goto back_to_e;
if (part == END) {
if (i < 3) { /* we require a fractional part */
error_res = am_no_float;
goto error;
}
break;
}
buf[i++] = unsigned_val(CAR(list_val(list)));
if (i == bufsz - 1)
buf = (byte *) erts_realloc(ERTS_ALC_T_TMP,
(void *) buf,
bufsz += STRING_TO_FLOAT_BUF_INC_SZ);
skip:
list = CDR(list_val(list)); /* next element */
if (is_nil(list))
goto back_to_e;
if (is_not_list(list)) {
back_to_e:
if (part == EXP_SIGN || part == EXP0) {
LOAD_E(i, i_mem, list, list_mem);
}
break;
}
}
if (i == 0) { /* no float first in list */
error_res = am_no_float;
goto error;
}
buf[i] = '\0'; /* null terminal */
ASSERT(bufsz >= i + 1);
if (sys_chars_to_double((char*) buf, &f.fd) != 0) {
error_res = am_no_float;
goto error;
}
hp = HAlloc(BIF_P, FLOAT_SIZE_OBJECT + 3);
tup = TUPLE2(hp+FLOAT_SIZE_OBJECT, make_float(hp), list);
PUT_DOUBLE(f, hp);
erts_free(ERTS_ALC_T_TMP, (void *) buf);
BIF_RET(tup);
}
static BIF_RETTYPE do_charbuf_to_float(Process *BIF_P,char *buf) {
FloatDef f;
Eterm res;
Eterm* hp;
if (sys_chars_to_double(buf, &f.fd) != 0)
BIF_ERROR(BIF_P, BADARG);
hp = HAlloc(BIF_P, FLOAT_SIZE_OBJECT);
res = make_float(hp);
PUT_DOUBLE(f, hp);
BIF_RET(res);
}
BIF_RETTYPE list_to_float_1(BIF_ALIST_1)
{
int i;
Eterm res;
char *buf = NULL;
i = erts_list_length(BIF_ARG_1);
if (i < 0)
BIF_ERROR(BIF_P, BADARG);
buf = (char *) erts_alloc(ERTS_ALC_T_TMP, i + 1);
if (intlist_to_buf(BIF_ARG_1, buf, i) < 0)
goto list_to_float_1_error;
buf[i] = '\0'; /* null terminal */
if ((res = do_charbuf_to_float(BIF_P,buf)) == THE_NON_VALUE)
goto list_to_float_1_error;
erts_free(ERTS_ALC_T_TMP, (void *) buf);
BIF_RET(res);
list_to_float_1_error:
erts_free(ERTS_ALC_T_TMP, (void *) buf);
BIF_ERROR(BIF_P, BADARG);
}
BIF_RETTYPE binary_to_float_1(BIF_ALIST_1)
{
Eterm res;
Eterm binary = BIF_ARG_1;
Sint size;
byte* bytes, *buf;
Eterm* real_bin;
Uint offs = 0;
Uint bit_offs = 0;
if (is_not_binary(binary) || (size = binary_size(binary)) == 0)
BIF_ERROR(BIF_P, BADARG);
/*
* Unfortunately we have to copy the binary because we have to insert
* the '\0' at the end of the binary for strtod to work
* (there is no nstrtod :( )
*/
buf = erts_alloc(ERTS_ALC_T_TMP, size + 1);
real_bin = binary_val(binary);
if (*real_bin == HEADER_SUB_BIN) {
ErlSubBin* sb = (ErlSubBin *) real_bin;
if (sb->bitsize) {
goto binary_to_float_1_error;
}
offs = sb->offs;
bit_offs = sb->bitoffs;
real_bin = binary_val(sb->orig);
}
if (*real_bin == HEADER_PROC_BIN) {
bytes = ((ProcBin *) real_bin)->bytes + offs;
} else {
bytes = (byte *)(&(((ErlHeapBin *) real_bin)->data)) + offs;
}
if (bit_offs)
erts_copy_bits(bytes, bit_offs, 1, buf, 0, 1, size*8);
else
memcpy(buf, bytes, size);
buf[size] = '\0';
if ((res = do_charbuf_to_float(BIF_P,(char*)buf)) == THE_NON_VALUE)
goto binary_to_float_1_error;
erts_free(ERTS_ALC_T_TMP, (void *) buf);
BIF_RET(res);
binary_to_float_1_error:
erts_free(ERTS_ALC_T_TMP, (void *) buf);
BIF_ERROR(BIF_P, BADARG);
}
/**********************************************************************/
/* convert a tuple to a list */
BIF_RETTYPE tuple_to_list_1(BIF_ALIST_1)
{
Uint n;
Eterm *tupleptr;
Eterm list = NIL;
Eterm* hp;
if (is_not_tuple(BIF_ARG_1)) {
BIF_ERROR(BIF_P, BADARG);
}
tupleptr = tuple_val(BIF_ARG_1);
n = arityval(*tupleptr);
hp = HAlloc(BIF_P, 2 * n);
tupleptr++;
while(n--) {
list = CONS(hp, tupleptr[n], list);
hp += 2;
}
BIF_RET(list);
}
/**********************************************************************/
/* convert a list to a tuple */
BIF_RETTYPE list_to_tuple_1(BIF_ALIST_1)
{
Eterm list = BIF_ARG_1;
Eterm* cons;
Eterm res;
Eterm* hp;
int len;
if ((len = erts_list_length(list)) < 0 || len > ERTS_MAX_TUPLE_SIZE) {
BIF_ERROR(BIF_P, BADARG);
}
hp = HAlloc(BIF_P, len+1);
res = make_tuple(hp);
*hp++ = make_arityval(len);
while(is_list(list)) {
cons = list_val(list);
*hp++ = CAR(cons);
list = CDR(cons);
}
BIF_RET(res);
}
/**********************************************************************/
/* return the pid of our own process, in most cases this has been replaced by
a machine instruction */
BIF_RETTYPE self_0(BIF_ALIST_0)
{
BIF_RET(BIF_P->common.id);
}
/**********************************************************************/
/* return the time of day */
BIF_RETTYPE time_0(BIF_ALIST_0)
{
int hour, minute, second;
Eterm* hp;
get_time(&hour, &minute, &second);
hp = HAlloc(BIF_P, 4); /* {hour, minute, second} + arity */
BIF_RET(TUPLE3(hp, make_small(hour), make_small(minute),
make_small(second)));
}
/**********************************************************************/
/* return the date */
BIF_RETTYPE date_0(BIF_ALIST_0)
{
int year, month, day;
Eterm* hp;
get_date(&year, &month, &day);
hp = HAlloc(BIF_P, 4); /* {year, month, day} + arity */
BIF_RET(TUPLE3(hp, make_small(year), make_small(month), make_small(day)));
}
/**********************************************************************/
/* return the universal time */
BIF_RETTYPE universaltime_0(BIF_ALIST_0)
{
int year, month, day;
int hour, minute, second;
Eterm res1, res2;
Eterm* hp;
/* read the clock */
get_universaltime(&year, &month, &day, &hour, &minute, &second);
hp = HAlloc(BIF_P, 4+4+3);
/* and return the tuple */
res1 = TUPLE3(hp,make_small(year),make_small(month),make_small(day));
hp += 4;
res2 = TUPLE3(hp,make_small(hour),make_small(minute),make_small(second));
hp += 4;
BIF_RET(TUPLE2(hp, res1, res2));
}
/**********************************************************************/
/* return the universal time */
BIF_RETTYPE localtime_0(BIF_ALIST_0)
{
int year, month, day;
int hour, minute, second;
Eterm res1, res2;
Eterm* hp;
/* read the clock */
get_localtime(&year, &month, &day, &hour, &minute, &second);
hp = HAlloc(BIF_P, 4+4+3);
/* and return the tuple */
res1 = TUPLE3(hp,make_small(year),make_small(month),make_small(day));
hp += 4;
res2 = TUPLE3(hp,make_small(hour),make_small(minute),make_small(second));
hp += 4;
BIF_RET(TUPLE2(hp, res1, res2));
}
/**********************************************************************/
/* type check and extract components from a tuple on form: {{Y,M,D},{H,M,S}} */
static int
time_to_parts(Eterm date, Sint* year, Sint* month, Sint* day,
Sint* hour, Sint* minute, Sint* second)
{
Eterm* t1;
Eterm* t2;
if (is_not_tuple(date)) {
return 0;
}
t1 = tuple_val(date);
if (arityval(t1[0]) !=2 ||
is_not_tuple(t1[1]) || is_not_tuple(t1[2]))
return 0;
t2 = tuple_val(t1[1]);
t1 = tuple_val(t1[2]);
if (arityval(t2[0]) != 3 ||
is_not_small(t2[1]) || is_not_small(t2[2]) || is_not_small(t2[3]))
return 0;
*year = signed_val(t2[1]);
*month = signed_val(t2[2]);
*day = signed_val(t2[3]);
if (arityval(t1[0]) != 3 ||
is_not_small(t1[1]) || is_not_small(t1[2]) || is_not_small(t1[3]))
return 0;
*hour = signed_val(t1[1]);
*minute = signed_val(t1[2]);
*second = signed_val(t1[3]);
return 1;
}
/* return the universal time */
BIF_RETTYPE
localtime_to_universaltime_2(BIF_ALIST_2)
{
Process *p = BIF_P;
Eterm localtime = BIF_ARG_1;
Eterm dst = BIF_ARG_2;
Sint year, month, day;
Sint hour, minute, second;
int isdst;
Eterm res1, res2;
Eterm* hp;
if (dst == am_true) isdst = 1;
else if (dst == am_false) isdst = 0;
else if (dst == am_undefined) isdst = -1;
else goto error;
if (!time_to_parts(localtime, &year, &month, &day,
&hour, &minute, &second)) goto error;
if (!local_to_univ(&year, &month, &day,
&hour, &minute, &second, isdst)) goto error;
hp = HAlloc(p, 4+4+3);
res1 = TUPLE3(hp,make_small(year),make_small(month),
make_small(day));
hp += 4;
res2 = TUPLE3(hp,make_small(hour),make_small(minute),
make_small(second));
hp += 4;
BIF_RET(TUPLE2(hp, res1, res2));
error:
BIF_ERROR(p, BADARG);
}
/**********************************************************************/
/* return the universal time */
BIF_RETTYPE universaltime_to_localtime_1(BIF_ALIST_1)
{
Sint year, month, day;
Sint hour, minute, second;
Eterm res1, res2;
Eterm* hp;
if (!time_to_parts(BIF_ARG_1, &year, &month, &day,
&hour, &minute, &second))
BIF_ERROR(BIF_P, BADARG);
if (!univ_to_local(&year, &month, &day,
&hour, &minute, &second))
BIF_ERROR(BIF_P, BADARG);
hp = HAlloc(BIF_P, 4+4+3);
res1 = TUPLE3(hp,make_small(year),make_small(month),
make_small(day));
hp += 4;
res2 = TUPLE3(hp,make_small(hour),make_small(minute),
make_small(second));
hp += 4;
BIF_RET(TUPLE2(hp, res1, res2));
}
/* convert calendar:universaltime_to_seconds/1 */
BIF_RETTYPE universaltime_to_posixtime_1(BIF_ALIST_1)
{
Sint year, month, day;
Sint hour, minute, second;
Sint64 seconds = 0;
Eterm *hp;
Uint hsz = 0;
if (!time_to_parts(BIF_ARG_1, &year, &month, &day,
&hour, &minute, &second))
BIF_ERROR(BIF_P, BADARG);
if (!univ_to_seconds(year, month, day, hour, minute, second, &seconds)) {
BIF_ERROR(BIF_P, BADARG);
}
erts_bld_sint64(NULL, &hsz, seconds);
hp = HAlloc(BIF_P, hsz);
BIF_RET(erts_bld_sint64(&hp, NULL, seconds));
}
/* convert calendar:seconds_to_universaltime/1 */
BIF_RETTYPE posixtime_to_universaltime_1(BIF_ALIST_1)
{
Sint year, month, day;
Sint hour, minute, second;
Eterm res1, res2;
Eterm* hp;
Sint64 time = 0;
if (!term_to_Sint64(BIF_ARG_1, &time)) {
BIF_ERROR(BIF_P, BADARG);
}
if (!seconds_to_univ(time, &year, &month, &day,
&hour, &minute, &second)) {
BIF_ERROR(BIF_P, BADARG);
}
hp = HAlloc(BIF_P, 4+4+3);
res1 = TUPLE3(hp,make_small(year),make_small(month),
make_small(day));
hp += 4;
res2 = TUPLE3(hp,make_small(hour),make_small(minute),
make_small(second));
hp += 4;
BIF_RET(TUPLE2(hp, res1, res2));
}
/**********************************************************************/
/* return a timestamp */
BIF_RETTYPE now_0(BIF_ALIST_0)
{
Uint megasec, sec, microsec;
Eterm* hp;
get_now(&megasec, &sec, &microsec);
hp = HAlloc(BIF_P, 4);
BIF_RET(TUPLE3(hp, make_small(megasec), make_small(sec),
make_small(microsec)));
}
/**********************************************************************/
BIF_RETTYPE garbage_collect_0(BIF_ALIST_0)
{
int reds;
FLAGS(BIF_P) |= F_NEED_FULLSWEEP;
reds = erts_garbage_collect(BIF_P, 0, NULL, 0);
BIF_RET2(am_true, reds);
}
/**********************************************************************/
/*
* The erlang:processes/0 BIF.
*/
BIF_RETTYPE processes_0(BIF_ALIST_0)
{
return erts_ptab_list(BIF_P, &erts_proc);
}
/**********************************************************************/
/*
* The erlang:ports/0 BIF.
*/
BIF_RETTYPE ports_0(BIF_ALIST_0)
{
return erts_ptab_list(BIF_P, &erts_port);
}
/**********************************************************************/
BIF_RETTYPE throw_1(BIF_ALIST_1)
{
BIF_P->fvalue = BIF_ARG_1;
BIF_ERROR(BIF_P, EXC_THROWN);
}
/**********************************************************************/
/*
* Non-standard, undocumented, dirty BIF, meant for debugging.
*
*/
BIF_RETTYPE display_1(BIF_ALIST_1)
{
erts_printf("%.*T\n", INT_MAX, BIF_ARG_1);
BIF_RET(am_true);
}
/*
* erts_debug:display/1 is for debugging erlang:display/1
*/
BIF_RETTYPE erts_debug_display_1(BIF_ALIST_1)
{
int pres;
Eterm res;
Eterm *hp;
erts_dsprintf_buf_t *dsbufp = erts_create_tmp_dsbuf(64);
pres = erts_dsprintf(dsbufp, "%.*T\n", INT_MAX, BIF_ARG_1);
if (pres < 0)
erl_exit(1, "Failed to convert term to string: %d (%s)\n",
-pres, erl_errno_id(-pres));
hp = HAlloc(BIF_P, 2*dsbufp->str_len); /* we need length * 2 heap words */
res = buf_to_intlist(&hp, dsbufp->str, dsbufp->str_len, NIL);
erts_printf("%s", dsbufp->str);
erts_destroy_tmp_dsbuf(dsbufp);
BIF_RET(res);
}
BIF_RETTYPE display_string_1(BIF_ALIST_1)
{
Process* p = BIF_P;
Eterm string = BIF_ARG_1;
int len = is_string(string);
char *str;
if (len <= 0) {
BIF_ERROR(p, BADARG);
}
str = (char *) erts_alloc(ERTS_ALC_T_TMP, sizeof(char)*(len + 1));
if (intlist_to_buf(string, str, len) != len)
erl_exit(1, "%s:%d: Internal error\n", __FILE__, __LINE__);
str[len] = '\0';
erts_fprintf(stderr, "%s", str);
erts_free(ERTS_ALC_T_TMP, (void *) str);
BIF_RET(am_true);
}
BIF_RETTYPE display_nl_0(BIF_ALIST_0)
{
erts_fprintf(stderr, "\n");
BIF_RET(am_true);
}
/**********************************************************************/
/* stop the system */
/* ARGSUSED */
BIF_RETTYPE halt_0(BIF_ALIST_0)
{
VERBOSE(DEBUG_SYSTEM,("System halted by BIF halt()\n"));
erl_halt(0);
ERTS_BIF_YIELD1(bif_export[BIF_halt_1], BIF_P, am_undefined);
}
/**********************************************************************/
#define HALT_MSG_SIZE 200
static char halt_msg[HALT_MSG_SIZE];
/* stop the system with exit code */
/* ARGSUSED */
BIF_RETTYPE halt_1(BIF_ALIST_1)
{
Sint code;
if (is_small(BIF_ARG_1) && (code = signed_val(BIF_ARG_1)) >= 0) {
VERBOSE(DEBUG_SYSTEM,("System halted by BIF halt(%T)\n", BIF_ARG_1));
erl_halt((int)(- code));
ERTS_BIF_YIELD1(bif_export[BIF_halt_1], BIF_P, am_undefined);
}
else if (ERTS_IS_ATOM_STR("abort", BIF_ARG_1)) {
VERBOSE(DEBUG_SYSTEM,("System halted by BIF halt(%T)\n", BIF_ARG_1));
erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN);
erl_exit(ERTS_ABORT_EXIT, "");
}
else if (is_string(BIF_ARG_1) || BIF_ARG_1 == NIL) {
int i;
if ((i = intlist_to_buf(BIF_ARG_1, halt_msg, HALT_MSG_SIZE-1)) < 0) {
goto error;
}
halt_msg[i] = '\0';
VERBOSE(DEBUG_SYSTEM,("System halted by BIF halt(%T)\n", BIF_ARG_1));
erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN);
erl_exit(ERTS_DUMP_EXIT, "%s\n", halt_msg);
}
else
goto error;
return NIL; /* Pedantic (lint does not know about erl_exit) */
error:
BIF_ERROR(BIF_P, BADARG);
}
/**********************************************************************/
/* stop the system with exit code and flags */
/* ARGSUSED */
BIF_RETTYPE halt_2(BIF_ALIST_2)
{
Sint code;
Eterm optlist = BIF_ARG_2;
int flush = 1;
for (optlist = BIF_ARG_2;
is_list(optlist);
optlist = CDR(list_val(optlist))) {
Eterm *tp, opt = CAR(list_val(optlist));
if (is_not_tuple(opt))
goto error;
tp = tuple_val(opt);
if (tp[0] != make_arityval(2))
goto error;
if (tp[1] == am_flush) {
if (tp[2] == am_true)
flush = 1;
else if (tp[2] == am_false)
flush = 0;
else
goto error;
}
else
goto error;
}
if (is_not_nil(optlist))
goto error;
if (is_small(BIF_ARG_1) && (code = signed_val(BIF_ARG_1)) >= 0) {
VERBOSE(DEBUG_SYSTEM,
("System halted by BIF halt(%T, %T)\n", BIF_ARG_1, BIF_ARG_2));
if (flush) {
erl_halt((int)(- code));
ERTS_BIF_YIELD1(bif_export[BIF_halt_1], BIF_P, am_undefined);
}
else {
erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN);
erl_exit((int)(- code), "");
}
}
else if (ERTS_IS_ATOM_STR("abort", BIF_ARG_1)) {
VERBOSE(DEBUG_SYSTEM,
("System halted by BIF halt(%T, %T)\n", BIF_ARG_1, BIF_ARG_2));
erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN);
erl_exit(ERTS_ABORT_EXIT, "");
}
else if (is_string(BIF_ARG_1) || BIF_ARG_1 == NIL) {
int i;
if ((i = intlist_to_buf(BIF_ARG_1, halt_msg, HALT_MSG_SIZE-1)) < 0) {
goto error;
}
halt_msg[i] = '\0';
VERBOSE(DEBUG_SYSTEM,
("System halted by BIF halt(%T, %T)\n", BIF_ARG_1, BIF_ARG_2));
erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN);
erl_exit(ERTS_DUMP_EXIT, "%s\n", halt_msg);
}
else
goto error;
return NIL; /* Pedantic (lint does not know about erl_exit) */
error:
BIF_ERROR(BIF_P, BADARG);
}
/**********************************************************************/
BIF_RETTYPE function_exported_3(BIF_ALIST_3)
{
int arity;
if (is_not_atom(BIF_ARG_1) ||
is_not_atom(BIF_ARG_2) ||
is_not_small(BIF_ARG_3)) {
BIF_ERROR(BIF_P, BADARG);
}
arity = signed_val(BIF_ARG_3);
if (erts_find_function(BIF_ARG_1, BIF_ARG_2, arity,
erts_active_code_ix()) != NULL ||
erts_is_builtin(BIF_ARG_1, BIF_ARG_2, arity)) {
BIF_RET(am_true);
}
BIF_RET(am_false);
}
/**********************************************************************/
BIF_RETTYPE is_builtin_3(BIF_ALIST_3)
{
Process* p = BIF_P;
Eterm Mod = BIF_ARG_1;
Eterm Name = BIF_ARG_2;
Eterm Arity = BIF_ARG_3;
if (is_not_atom(Mod) || is_not_atom(Name) || is_not_small(Arity)) {
BIF_ERROR(p, BADARG);
}
BIF_RET(erts_is_builtin(Mod, Name, signed_val(Arity)) ?
am_true : am_false);
}
/**********************************************************************/
/* NOTE: Cannot be used in all *_to_list() bifs. erts_dsprintf() prints
* some terms on other formats than what is desired as results
* from *_to_list() bifs.
*/
static Eterm
term2list_dsprintf(Process *p, Eterm term)
{
int pres;
Eterm res;
Eterm *hp;
erts_dsprintf_buf_t *dsbufp = erts_create_tmp_dsbuf(64);
pres = erts_dsprintf(dsbufp, "%T", term);
if (pres < 0)
erl_exit(1, "Failed to convert term to list: %d (%s)\n",
-pres, erl_errno_id(-pres));
hp = HAlloc(p, 2*dsbufp->str_len); /* we need length * 2 heap words */
res = buf_to_intlist(&hp, dsbufp->str, dsbufp->str_len, NIL);
erts_destroy_tmp_dsbuf(dsbufp);
return res;
}
BIF_RETTYPE ref_to_list_1(BIF_ALIST_1)
{
if (is_not_ref(BIF_ARG_1))
BIF_ERROR(BIF_P, BADARG);
BIF_RET(term2list_dsprintf(BIF_P, BIF_ARG_1));
}
BIF_RETTYPE make_fun_3(BIF_ALIST_3)
{
Eterm* hp;
Sint arity;
if (is_not_atom(BIF_ARG_1) || is_not_atom(BIF_ARG_2) || is_not_small(BIF_ARG_3)) {
error:
BIF_ERROR(BIF_P, BADARG);
}
arity = signed_val(BIF_ARG_3);
if (arity < 0) {
goto error;
}
#if HALFWORD_HEAP
hp = HAlloc(BIF_P, 3);
hp[0] = HEADER_EXPORT;
/* Yes, May be misaligned, but X86_64 will fix it... */
*((Export **) (hp+1)) = erts_export_get_or_make_stub(BIF_ARG_1, BIF_ARG_2, (Uint) arity);
#else
hp = HAlloc(BIF_P, 2);
hp[0] = HEADER_EXPORT;
hp[1] = (Eterm) erts_export_get_or_make_stub(BIF_ARG_1, BIF_ARG_2, (Uint) arity);
#endif
BIF_RET(make_export(hp));
}
BIF_RETTYPE fun_to_list_1(BIF_ALIST_1)
{
Process* p = BIF_P;
Eterm fun = BIF_ARG_1;
if (is_not_any_fun(fun))
BIF_ERROR(p, BADARG);
BIF_RET(term2list_dsprintf(p, fun));
}
/**********************************************************************/
/* convert a pid to an erlang list (for the linked cons cells) of the form
<node.number.serial> to a PID
*/
BIF_RETTYPE pid_to_list_1(BIF_ALIST_1)
{
if (is_not_pid(BIF_ARG_1))
BIF_ERROR(BIF_P, BADARG);
BIF_RET(term2list_dsprintf(BIF_P, BIF_ARG_1));
}
BIF_RETTYPE port_to_list_1(BIF_ALIST_1)
{
if (is_not_port(BIF_ARG_1))
BIF_ERROR(BIF_P, BADARG);
BIF_RET(term2list_dsprintf(BIF_P, BIF_ARG_1));
}
/**********************************************************************/
/* convert a list of ascii characeters of the form
<node.number.serial> to a PID
*/
BIF_RETTYPE list_to_pid_1(BIF_ALIST_1)
{
Uint a = 0, b = 0, c = 0;
char* cp;
int i;
DistEntry *dep = NULL;
char *buf = (char *) erts_alloc(ERTS_ALC_T_TMP, 65);
/*
* Max 'Uint64' has 20 decimal digits. If X, Y, Z in <X.Y.Z>
* are 'Uint64's. Max chars are 1 + 20 + 1 + 20 + 1 + 20 + 1 = 64,
* i.e, if the input list is longer than 64 it does not represent
* a pid.
*/
/* walk down the list and create a C string */
if ((i = intlist_to_buf(BIF_ARG_1, buf, 64)) < 0)
goto bad;
buf[i] = '\0'; /* null terminal */
cp = buf;
if (*cp++ != '<') goto bad;
if (*cp < '0' || *cp > '9') goto bad;
while(*cp >= '0' && *cp <= '9') { a = 10*a + (*cp - '0'); cp++; }
if (*cp++ != '.') goto bad;
if (*cp < '0' || *cp > '9') goto bad;
while(*cp >= '0' && *cp <= '9') { b = 10*b + (*cp - '0'); cp++; }
if (*cp++ != '.') goto bad;
if (*cp < '0' || *cp > '9') goto bad;
while(*cp >= '0' && *cp <= '9') { c = 10*c + (*cp - '0'); cp++; }
if (*cp++ != '>') goto bad;
if (*cp != '\0') goto bad;
erts_free(ERTS_ALC_T_TMP, (void *) buf);
buf = NULL;