diff options
Diffstat (limited to 'erts/emulator/beam/bif.c')
| -rw-r--r-- | erts/emulator/beam/bif.c | 4201 |
1 files changed, 4201 insertions, 0 deletions
diff --git a/erts/emulator/beam/bif.c b/erts/emulator/beam/bif.c new file mode 100644 index 0000000000..74b231d56d --- /dev/null +++ b/erts/emulator/beam/bif.c @@ -0,0 +1,4201 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. 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" +#include "bif.h" +#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" + +static Export* flush_monitor_message_trap = NULL; +static Export* set_cpu_topology_trap = NULL; +static Export* await_proc_exit_trap = NULL; +Export* erts_format_cpu_topology_trap = NULL; + +#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) && (p->trace_flags & (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(&(p->nlinks), LINK_PID, rp->id); + erts_add_link(&(rp->nlinks), LINK_PID, p->id); + + ASSERT(is_nil(p->tracer_proc) + || is_internal_pid(p->tracer_proc) + || is_internal_port(p->tracer_proc)); + + if (IS_TRACED(p)) { + if (p->trace_flags & (F_TRACE_SOL|F_TRACE_SOL1)) { + rp->trace_flags |= (p->trace_flags & TRACEE_FLAGS); + rp->tracer_proc = p->tracer_proc; /* maybe steal */ + + if (p->trace_flags & F_TRACE_SOL1) { /* maybe override */ + rp->trace_flags &= ~(F_TRACE_SOL1 | F_TRACE_SOL); + p->trace_flags &= ~(F_TRACE_SOL1 | F_TRACE_SOL); + } + } + } + } + if (IS_TRACED_FL(rp, F_TRACE_PROCS)) + trace_proc(p, rp, am_getting_linked, p->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 (internal_pid_index(BIF_ARG_1) >= erts_max_processes) { + BIF_ERROR(BIF_P, BADARG); + } + + 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)) { + Port *pt = erts_id2port(BIF_ARG_1, BIF_P, ERTS_PROC_LOCK_MAIN); + if (!pt) { + goto res_no_proc; + } + + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_LINK); + + if (erts_add_link(&(BIF_P->nlinks), LINK_PID, BIF_ARG_1) >= 0) + erts_add_link(&(pt->nlinks), LINK_PID, BIF_P->id); + /* else: already linked */ + + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_LINK); + erts_smp_port_unlock(pt); + 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(BIF_P->nlinks, 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(&(BIF_P->nlinks), LINK_PID, BIF_ARG_1); + lnk = erts_add_or_lookup_link(&(dep->nlinks), + LINK_PID, + BIF_P->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->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: + if (BIF_P->flags & F_TRAPEXIT) { + 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(&c_p->monitors, 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(&c_p->monitors, 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->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"); + res = ERTS_DEMONITOR_INTERNAL_ERROR; + break; + } + +#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) +{ + ErtsMonitor *mon = NULL; /* The monitor entry to delete */ + Process *rp; /* Local target process */ + Eterm to = NIL; /* Monitor link traget */ + Eterm ref_p; /* Pid of this end */ + 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 */ + } + ref_p = c_p->id; + + mon = erts_lookup_monitor(c_p->monitors, ref); + if (!mon) { + res = ERTS_DEMONITOR_FALSE; + goto done; + } + + if (mon->type != MON_ORIGIN) { + res = ERTS_DEMONITOR_BADARG; + goto done; + } + to = mon->pid; + + 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(&c_p->monitors, 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(&(rp->monitors), 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); + } + + } + + 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) +{ + switch (demonitor(BIF_P, BIF_ARG_1)) { + 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; + 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)) { + case ERTS_DEMONITOR_FALSE: + if (info) + res = am_false; + if (flush) + BIF_TRAP2(flush_monitor_message_trap, BIF_P, BIF_ARG_1, res); + case ERTS_DEMONITOR_TRUE: + 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) +{ + BIF_RETTYPE ret; + Eterm mon_ref; + Process *rp; + ErtsProcLocks p_locks = ERTS_PROC_LOCK_MAIN|ERTS_PROC_LOCK_LINK; + + mon_ref = erts_make_ref(p); + ERTS_BIF_PREP_RET(ret, mon_ref); + if (target == p->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; + erts_queue_monitor_message(p, &p_locks, + mon_ref, am_process, target, am_noproc); + } + else { + ASSERT(rp != p); + + erts_add_monitor(&(p->monitors), MON_ORIGIN, mon_ref, target, NIL); + erts_add_monitor(&(rp->monitors), MON_TARGET, mon_ref, p->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) { + Eterm lhp[3]; + Eterm item; + 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); + } + else if (rp != p) { + erts_add_monitor(&(p->monitors), MON_ORIGIN, mon_ref, rp->id, + target_name); + erts_add_monitor(&(rp->monitors), MON_TARGET, mon_ref, p->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(&(p->monitors), MON_ORIGIN, mon_ref, p_trgt, + p_name); + erts_add_monitor(&(dep->monitors), MON_TARGET, mon_ref, p->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->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 */ + if (BIF_ARG_1 != am_process) { + goto error; + } + + if (is_internal_pid(target)) { + local_pid: + ret = local_pid_monitor(BIF_P, target); + } 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.priority = PRIORITY_NORMAL; + so.max_gen_gcs = (Uint16) erts_smp_atomic_read(&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_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 (erts_common_run_queue && erts_no_schedulers > 1) + goto error; + 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)) { + Port *pt = erts_id2port_sflgs(BIF_ARG_1, + BIF_P, + ERTS_PROC_LOCK_MAIN, + ERTS_PORT_SFLGS_DEAD); + + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_LINK|ERTS_PROC_LOCK_STATUS); +#ifdef ERTS_SMP + if (ERTS_PROC_PENDING_EXIT(BIF_P)) { + if (pt) + erts_smp_port_unlock(pt); + goto handle_pending_exit; + } +#endif + + l = erts_remove_link(&BIF_P->nlinks, BIF_ARG_1); + + ASSERT(pt || !l); + + if (pt) { + rl = erts_remove_link(&pt->nlinks, BIF_P->id); + erts_smp_port_unlock(pt); + if (rl) + erts_destroy_link(rl); + } + + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_LINK|ERTS_PROC_LOCK_STATUS); + + if (l) + erts_destroy_link(l); + + 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(&BIF_P->nlinks,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->id, BIF_ARG_1, dep); + code = erts_dsig_send_unlink(&dsd, BIF_P->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... */ + + /* process ok ? */ + if (internal_pid_index(BIF_ARG_1) >= erts_max_processes) + BIF_ERROR(BIF_P, BADARG); + + 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(&BIF_P->nlinks,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(&(rp->nlinks),BIF_P->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->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 implemented as an instruction; therefore + * this function will never be called. + */ + BIF_ERROR(BIF_P, BADARG); +} + +/**********************************************************************/ + +BIF_RETTYPE get_stacktrace_0(Process* p) +{ + Eterm t = build_stacktrace(p, 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(Process* p, Eterm term) +{ + p->fvalue = term; + BIF_ERROR(p, EXC_ERROR); +} + +/**********************************************************************/ +/* + * This is like error/1, except that the given 'args' will be included + * in the stacktrace. + */ + +BIF_RETTYPE error_2(Process* p, Eterm value, Eterm args) +{ + Eterm* hp = HAlloc(p, 3); + + p->fvalue = TUPLE2(hp, value, args); + BIF_ERROR(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. + */ +Eterm +raise_3(Process *c_p, Eterm class, Eterm value, Eterm stacktrace) { + Eterm reason; + Eterm l, *hp, *hp_end, *tp; + int depth, cnt; + size_t sz; + 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. + */ + for (l = stacktrace, depth = 0; + is_list(l); + l = CDR(list_val(l)), depth++) { + Eterm t = CAR(list_val(l)); + int arity; + if (is_not_tuple(t)) goto error; + tp = tuple_val(t); + arity = arityval(tp[0]); + if ((arity == 3) && is_atom(tp[1]) && is_atom(tp[2])) continue; + if ((arity == 2) && is_fun(tp[1])) continue; + goto error; + } + if (is_not_nil(l)) goto error; + + /* Create stacktrace and store */ + if (depth <= erts_backtrace_depth) { + cnt = 0; + c_p->ftrace = stacktrace; + } else { + cnt = depth = erts_backtrace_depth; + c_p->ftrace = NIL; + } + tp = &c_p->ftrace; + sz = (offsetof(struct StackTrace, trace) + sizeof(Eterm) - 1) + / sizeof(Eterm); + hp = HAlloc(c_p, sz + 2*(cnt + 1)); + hp_end = hp + sz + 2*(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 (cnt > 0) { + /* Copy list up to depth */ + for (cnt = 0, l = stacktrace; + cnt < depth; + cnt++, l = CDR(list_val(l))) { + ASSERT(*tp == NIL); + *tp = CONS(hp, CAR(list_val(l)), *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); + + 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)) { + Port *prt; + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN); + prt = erts_id2port(BIF_ARG_1, NULL, 0); + if (prt) { + erts_do_exit_port(prt, BIF_P->id, BIF_ARG_2); + erts_port_release(prt); + } + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_MAIN); + ERTS_BIF_CHK_EXITED(BIF_P); + 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->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 (internal_pid_index(BIF_ARG_1) >= erts_max_processes) + BIF_ERROR(BIF_P, BADARG); + if (BIF_ARG_1 == BIF_P->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_opt(BIF_P, ERTS_PROC_LOCK_MAIN, + BIF_ARG_1, rp_locks, + ERTS_P2P_FLG_SMP_INC_REFC); + if (!rp) { + BIF_RET(am_true); + } + } + + /* + * Send an exit signal. + */ + erts_send_exit_signal(BIF_P, + BIF_P->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; + else + erts_smp_proc_dec_refc(rp); + 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) { + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_STATUS); + old_value = erts_set_process_priority(BIF_P, BIF_ARG_2); + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_STATUS); + if (old_value == THE_NON_VALUE) + goto error; + BIF_RET(old_value); + } + else if (BIF_ARG_1 == am_trap_exit) { + 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 flag trap_exit is set to true. + * For more info, see implementation of erts_send_exit_signal(). + */ + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_STATUS); + ERTS_SMP_BIF_CHK_PENDING_EXIT(BIF_P, + ERTS_PROC_LOCK_MAIN|ERTS_PROC_LOCK_STATUS); + old_value = ERTS_PROC_IS_TRAPPING_EXITS(BIF_P) ? am_true : am_false; + if (trap_exit) { + ERTS_PROC_SET_TRAP_EXIT(BIF_P); + } else { + ERTS_PROC_UNSET_TRAP_EXIT(BIF_P); + } + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_STATUS); + BIF_RET(old_value); + } + else if (BIF_ARG_1 == am_scheduler) { + int yield; + ErtsRunQueue *old; + ErtsRunQueue *new; + Sint sched; + if (erts_common_run_queue && erts_no_schedulers > 1) + goto error; + if (!is_small(BIF_ARG_2)) + goto error; + sched = signed_val(BIF_ARG_2); + if (sched < 0 || erts_no_schedulers < sched) + goto error; + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_STATUS); + old = BIF_P->bound_runq; +#ifdef ERTS_SMP + ASSERT(!old || old == BIF_P->run_queue); +#endif + new = !sched ? NULL : erts_schedid2runq(sched); +#ifndef ERTS_SMP + yield = 0; +#else + if (new == old) + yield = 0; + else { + ErtsRunQueue *curr = BIF_P->run_queue; + if (!new) + erts_smp_runq_lock(curr); + else + erts_smp_runqs_lock(curr, new); + yield = new && BIF_P->run_queue != new; +#endif + BIF_P->bound_runq = new; +#ifdef ERTS_SMP + if (new) + BIF_P->run_queue = new; + if (!new) + erts_smp_runq_unlock(curr); + else + erts_smp_runqs_unlock(curr, new); + } +#endif + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_STATUS); + old_value = old ? make_small(old->ix+1) : make_small(0); + if (yield) + 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_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 = BIF_P->trace_flags & F_SENSITIVE ? am_true : am_false; + if (is_sensitive) { + BIF_P->trace_flags |= F_SENSITIVE; + } else { + BIF_P->trace_flags &= ~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 + */ + +Eterm +ebif_bang_2(Process* p, Eterm To, Eterm Message) +{ + return send_2(p, To, Message); +} + + +/* + * 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) + +Sint do_send(Process *p, Eterm to, Eterm msg, int suspend); + +static Sint remote_send(Process *p, DistEntry *dep, + Eterm to, Eterm full_to, Eterm msg, int suspend) +{ + Sint res; + int code; + ErtsDSigData dsd; + + ASSERT(is_atom(to) || is_external_pid(to)); + + code = erts_dsig_prepare(&dsd, dep, p, ERTS_DSP_NO_LOCK, !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(!suspend); + res = SEND_YIELD; + break; + case ERTS_DSIG_PREP_CONNECTED: { + + if (is_atom(to)) + code = erts_dsig_send_reg_msg(&dsd, to, msg); + else + code = erts_dsig_send_msg(&dsd, to, msg); + /* + * 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 + 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, int suspend) { + 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); + + if (internal_pid_index(to) >= erts_max_processes) + return SEND_BADARG; + + rp = erts_pid2proc_opt(p, ERTS_PROC_LOCK_MAIN, + to, 0, ERTS_P2P_FLG_SMP_INC_REFC); + + if (!rp) { + ERTS_SMP_ASSERT_IS_NOT_EXITING(p); + return 0; + } + } else if (is_external_pid(to)) { + dep = external_pid_dist_entry(to); + if(dep == erts_this_dist_entry) { + 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->id, + to, + external_pid_creation(to), + erts_this_node->creation); + erts_send_error_to_logger(p->group_leader, dsbufp); + return 0; + } + return remote_send(p, dep, to, to, msg, suspend); + } else if (is_atom(to)) { + + /* Need to virtual schedule out sending process + * because of lock wait. This is only necessary + * for internal port calling but the lock is bundled + * with name lookup. + */ + + if (IS_TRACED_FL(p, F_TRACE_SCHED_PROCS)) { + trace_virtual_sched(p, am_out); + } + if (erts_system_profile_flags.runnable_procs && erts_system_profile_flags.exclusive) { + profile_runnable_proc(p, am_inactive); + } + erts_whereis_name(p, ERTS_PROC_LOCK_MAIN, + to, + &rp, 0, ERTS_P2P_FLG_SMP_INC_REFC, + &pt); + + if (pt) { + portid = pt->id; + goto port_common; + } + + /* Not a port virtually schedule the process back in */ + if (IS_TRACED_FL(p, F_TRACE_SCHED_PROCS)) { + trace_virtual_sched(p, am_in); + } + if (erts_system_profile_flags.runnable_procs && erts_system_profile_flags.exclusive) { + profile_runnable_proc(p, am_active); + } + + if (IS_TRACED(p)) + trace_send(p, to, msg); + if (ERTS_PROC_GET_SAVED_CALLS_BUF(p)) + save_calls(p, &exp_send); + + if (!rp) { + return SEND_BADARG; + } + } else if (is_external_port(to) + && (external_port_dist_entry(to) + == erts_this_dist_entry)) { + 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->id, + to, + external_port_creation(to), + erts_this_node->creation); + erts_send_error_to_logger(p->group_leader, dsbufp); + return 0; + } else if (is_internal_port(to)) { + portid = to; + /* schedule out calling process, waiting for lock*/ + if (IS_TRACED_FL(p, F_TRACE_SCHED_PROCS)) { + trace_virtual_sched(p, am_out); + } + if (erts_system_profile_flags.runnable_procs && erts_system_profile_flags.exclusive) { + profile_runnable_proc(p, am_inactive); + } + pt = erts_id2port(to, p, ERTS_PROC_LOCK_MAIN); + port_common: + ERTS_SMP_LC_ASSERT(!pt || erts_lc_is_port_locked(pt)); + + /* We have waited for locks, trace schedule ports */ + if (pt && IS_TRACED_FL(pt, F_TRACE_SCHED_PORTS)) { + trace_sched_ports_where(pt, am_in, am_command); + } + if (pt && erts_system_profile_flags.runnable_ports && !erts_port_is_scheduled(pt)) { + profile_runnable_port(pt, am_active); + } + + /* XXX let port_command handle the busy stuff !!! */ + if (pt && (pt->status & ERTS_PORT_SFLG_PORT_BUSY)) { + if (suspend) { + erts_suspend(p, ERTS_PROC_LOCK_MAIN, pt); + if (erts_system_monitor_flags.busy_port) { + monitor_generic(p, am_busy_port, portid); + } + } + /* Virtually schedule out the port before releasing */ + if (IS_TRACED_FL(pt, F_TRACE_SCHED_PORTS)) { + trace_sched_ports_where(pt, am_out, am_command); + } + if (erts_system_profile_flags.runnable_ports && !erts_port_is_scheduled(pt)) { + profile_runnable_port(pt, am_inactive); + } + erts_port_release(pt); + return SEND_YIELD; + } + + 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) { + seq_trace_update_send(p); + seq_trace_output(SEQ_TRACE_TOKEN(p), msg, + SEQ_TRACE_SEND, portid, p); + } + + /* XXX NO GC in port command */ + erts_port_command(p, p->id, pt, msg); + if (pt) { + /* Virtually schedule out the port before releasing */ + if (IS_TRACED_FL(pt, F_TRACE_SCHED_PORTS)) { + trace_sched_ports_where(pt, am_out, am_command); + } + if (erts_system_profile_flags.runnable_ports && !erts_port_is_scheduled(pt)) { + profile_runnable_port(pt, am_inactive); + } + erts_port_release(pt); + } + /* Virtually schedule in process */ + if (IS_TRACED_FL(p, F_TRACE_SCHED_PROCS)) { + trace_virtual_sched(p, am_in); + } + if (erts_system_profile_flags.runnable_procs && erts_system_profile_flags.exclusive) { + profile_runnable_proc(p, am_active); + } + if (ERTS_PROC_IS_EXITING(p)) { + KILL_CATCHES(p); /* Must exit */ + return SEND_USER_ERROR; + } + return 0; + } 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) { + 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); + + /* Need to virtual schedule out sending process + * because of lock wait. This is only necessary + * for internal port calling but the lock is bundled. + */ + + if (IS_TRACED_FL(p, F_TRACE_SCHED_PROCS)) { + trace_virtual_sched(p, am_out); + } + if (erts_system_profile_flags.runnable_procs && erts_system_profile_flags.exclusive) { + profile_runnable_proc(p, am_inactive); + } + + erts_whereis_name(p, ERTS_PROC_LOCK_MAIN, + tp[1], + &rp, 0, ERTS_P2P_FLG_SMP_INC_REFC, + &pt); + if (pt) { + portid = pt->id; + goto port_common; + } + /* Port lookup failed, virtually schedule the process + * back in. + */ + + if (IS_TRACED_FL(p, F_TRACE_SCHED_PROCS)) { + trace_virtual_sched(p, am_in); + } + if (erts_system_profile_flags.runnable_procs && erts_system_profile_flags.exclusive) { + profile_runnable_proc(p, am_active); + } + + if (!rp) { + return 0; + } + goto send_message; + } + + ret = remote_send(p, dep, tp[1], to, msg, suspend); + if (dep) + erts_deref_dist_entry(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 */ + erts_send_message(p, rp, &rp_locks, msg, 0); + if (!erts_use_sender_punish) + res = 0; + else { +#ifdef ERTS_SMP + res = rp->msg_inq.len*4; + if (ERTS_PROC_LOCK_MAIN & rp_locks) + res += rp->msg.len*4; +#else + res = rp->msg.len*4; +#endif + } + erts_smp_proc_unlock(rp, + p == rp + ? (rp_locks & ~ERTS_PROC_LOCK_MAIN) + : rp_locks); + erts_smp_proc_dec_refc(rp); + return res; + } +} + + +Eterm +send_3(Process *p, Eterm to, Eterm msg, Eterm opts) { + int connect = !0; + int suspend = !0; + Eterm l = opts; + Sint result; + + while (is_list(l)) { + if (CAR(list_val(l)) == am_noconnect) { + connect = 0; + } else if (CAR(list_val(l)) == am_nosuspend) { + suspend = 0; + } else { + BIF_ERROR(p, BADARG); + } + l = CDR(list_val(l)); + } + if(!is_nil(l)) { + BIF_ERROR(p, BADARG); + } + + result = do_send(p, to, msg, suspend); + if (result > 0) { + ERTS_VBUMP_REDS(p, result); + BIF_RET(am_ok); + } else switch (result) { + case 0: + BIF_RET(am_ok); + break; + case SEND_TRAP: + if (connect) { + BIF_TRAP3(dsend3_trap, p, to, msg, opts); + } else { + BIF_RET(am_noconnect); + } + break; + case SEND_YIELD: + if (suspend) { + ERTS_BIF_YIELD3(bif_export[BIF_send_3], p, to, msg, opts); + } else { + BIF_RET(am_nosuspend); + } + break; + case SEND_YIELD_RETURN: + if (suspend) + ERTS_BIF_YIELD_RETURN(p, am_ok); + else + BIF_RET(am_nosuspend); + case SEND_BADARG: + BIF_ERROR(p, BADARG); + break; + case SEND_USER_ERROR: + BIF_ERROR(p, EXC_ERROR); + break; + case SEND_INTERNAL_ERROR: + BIF_ERROR(p, EXC_INTERNAL_ERROR); + break; + default: + ASSERT(! "Illegal send result"); + break; + } + ASSERT(! "Can not arrive here"); + BIF_ERROR(p, BADARG); +} + +Eterm +send_2(Process *p, Eterm to, Eterm msg) { + Sint result = do_send(p, to, msg, !0); + + if (result > 0) { + ERTS_VBUMP_REDS(p, result); + BIF_RET(msg); + } else switch (result) { + case 0: + BIF_RET(msg); + break; + case SEND_TRAP: + BIF_TRAP2(dsend2_trap, p, to, msg); + break; + case SEND_YIELD: + ERTS_BIF_YIELD2(bif_export[BIF_send_2], p, to, msg); + break; + case SEND_YIELD_RETURN: + ERTS_BIF_YIELD_RETURN(p, msg); + case SEND_BADARG: + BIF_ERROR(p, BADARG); + break; + case SEND_USER_ERROR: + BIF_ERROR(p, EXC_ERROR); + break; + case SEND_INTERNAL_ERROR: + BIF_ERROR(p, EXC_INTERNAL_ERROR); + break; + default: + ASSERT(! "Illegal send result"); + break; + } + ASSERT(! "Can not arrive here"); + BIF_ERROR(p, BADARG); +} + +/**********************************************************************/ +/* + * 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 */ + +BIF_RETTYPE iolist_size_1(BIF_ALIST_1) +{ + Sint size = io_list_len(BIF_ARG_1); + + if (size == -1) { + BIF_ERROR(BIF_P, BADARG); + } else if (IS_USMALL(0, (Uint) size)) { + BIF_RET(make_small(size)); + } else { + Eterm* hp = HAlloc(BIF_P, BIG_UINT_HEAP_SIZE); + BIF_RET(uint_to_big(size, hp)); + } +} + + +/**********************************************************************/ + +/* 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; + while (size--) { /* XXX use memcpy? */ + *hp++ = *ptr++; + } + 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) { + 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) { + 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)) { + BIF_ERROR(BIF_P, BADARG); + } + ptr = tuple_val(BIF_ARG_1); + arity = arityval(*ptr); + 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); +} + +/**********************************************************************/ + +/* convert an atom to a list of ascii integer */ + +BIF_RETTYPE atom_to_list_1(BIF_ALIST_1) +{ + Uint need; + Eterm* hp; + Atom* ap; + + 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 */ + need = ap->len*2; + hp = HAlloc(BIF_P, need); + BIF_RET(buf_to_intlist(&hp,(char*)ap->name,ap->len, NIL)); +} + +/**********************************************************************/ + +/* 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_LENGTH); + int i = intlist_to_buf(BIF_ARG_1, buf, MAX_ATOM_LENGTH); + + if (i < 0) { + erts_free(ERTS_ALC_T_TMP, (void *) buf); + i = list_length(BIF_ARG_1); + if (i > MAX_ATOM_LENGTH) { + BIF_ERROR(BIF_P, SYSTEM_LIMIT); + } + BIF_ERROR(BIF_P, BADARG); + } + res = am_atom_put(buf, i); + 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_LENGTH); + + if ((i = intlist_to_buf(BIF_ARG_1, buf, MAX_ATOM_LENGTH)) < 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_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; + int skip = 0; + int neg = 0; + int 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; + } + i = i * 10; + i = i + 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 = -i; + res = make_small(i); + } else { + lg2 = (n+1)*230/69+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 (is_big(res)) /* check if small */ + res = big_plus_small(res, 0, hp); /* includes conversion to small */ + + 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_big(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) +{ + 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); + } + +/**********************************************************************/ + +/* convert a float to a list of ascii characters */ + +BIF_RETTYPE float_to_list_1(BIF_ALIST_1) +{ + int i; + Uint need; + Eterm* hp; + FloatDef f; + char fbuf[30]; + + /* check the arguments */ + if (is_not_float(BIF_ARG_1)) + BIF_ERROR(BIF_P, BADARG); + GET_DOUBLE(BIF_ARG_1, f); + if ((i = sys_double_to_chars(f.fd, fbuf)) <= 0) + BIF_ERROR(BIF_P, EXC_INTERNAL_ERROR); + need = i*2; + hp = HAlloc(BIF_P, need); + BIF_RET(buf_to_intlist(&hp, fbuf, i, NIL)); + } + +/**********************************************************************/ + +/* 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); +} + + +BIF_RETTYPE list_to_float_1(BIF_ALIST_1) +{ + int i; + FloatDef f; + Eterm res; + Eterm* hp; + char *buf = NULL; + + i = list_length(BIF_ARG_1); + if (i < 0) { + badarg: + if (buf) + erts_free(ERTS_ALC_T_TMP, (void *) buf); + 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 badarg; + buf[i] = '\0'; /* null terminal */ + + if (sys_chars_to_double(buf, &f.fd) != 0) + goto badarg; + hp = HAlloc(BIF_P, FLOAT_SIZE_OBJECT); + res = make_float(hp); + PUT_DOUBLE(f, hp); + erts_free(ERTS_ALC_T_TMP, (void *) buf); + BIF_RET(res); +} + +/**********************************************************************/ + +/* 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 = list_length(list)) < 0) { + 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->id); +} + +/**********************************************************************/ + +/* + New representation of refs in R9, see erl_term.h + + In the first data word, only the usual 18 bits are used. Ordinarily, + in "long refs" all words are used (in other words, practically never + wrap around), but for compatibility with older nodes, "short refs" + exist. Short refs come into being by being converted from the old + external format for refs (tag REFERENCE_EXT). Short refs are + converted back to the old external format. + + When converting a long ref to the external format in the case of + preparing for sending to an older node, the ref is truncated by only + using the first word (with 18 significant bits), and using the old tag + REFERENCE_EXT. + + When comparing refs or different size, only the parts up to the length + of the shorter operand are used. This has the desirable effect that a + long ref sent to an old node and back will be treated as equal to + the original, although some of the bits have been lost. + + The hash value for a ref always considers only the first word, since + in the above scenario, the original and the copy should have the same + hash value. +*/ + +static Uint32 reference0; /* Initialized in erts_init_bif */ +static Uint32 reference1; +static Uint32 reference2; +static erts_smp_spinlock_t make_ref_lock; +static erts_smp_mtx_t ports_snapshot_mtx; +erts_smp_atomic_t erts_dead_ports_ptr; /* To store dying ports during snapshot */ + +Eterm erts_make_ref_in_buffer(Eterm buffer[REF_THING_SIZE]) +{ + Eterm* hp = buffer; + Uint32 ref0, ref1, ref2; + + erts_smp_spin_lock(&make_ref_lock); + + reference0++; + if (reference0 >= MAX_REFERENCE) { + reference0 = 0; + reference1++; + if (reference1 == 0) { + reference2++; + } + } + + ref0 = reference0; + ref1 = reference1; + ref2 = reference2; + + erts_smp_spin_unlock(&make_ref_lock); + + write_ref_thing(hp, ref0, ref1, ref2); + return make_internal_ref(hp); +} + +Eterm erts_make_ref(Process *p) +{ + Eterm* hp; + + ERTS_SMP_LC_ASSERT(ERTS_PROC_LOCK_MAIN & erts_proc_lc_my_proc_locks(p)); + + hp = HAlloc(p, REF_THING_SIZE); + return erts_make_ref_in_buffer(hp); +} + +BIF_RETTYPE make_ref_0(BIF_ALIST_0) +{ + return erts_make_ref(BIF_P); +} + +/**********************************************************************/ + +/* 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(Process *p, Eterm localtime, Eterm dst) +{ + 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)); +} + +/**********************************************************************/ + + + /* return a timestamp */ +BIF_RETTYPE now_0(BIF_ALIST_0) +{ + Uint megasec, sec, microsec; + Eterm* hp; + + get_now(&megasec, &sec, µsec); + hp = HAlloc(BIF_P, 4); + BIF_RET(TUPLE3(hp, make_small(megasec), make_small(sec), + make_small(microsec))); +} + +/**********************************************************************/ + +BIF_RETTYPE garbage_collect_1(BIF_ALIST_1) +{ + int reds; + Process *rp; + + if (is_not_pid(BIF_ARG_1)) { + BIF_ERROR(BIF_P, BADARG); + } + + rp = erts_pid2proc_not_running(BIF_P, ERTS_PROC_LOCK_MAIN, + BIF_ARG_1, ERTS_PROC_LOCK_MAIN); + if (!rp) + BIF_RET(am_false); + if (rp == ERTS_PROC_LOCK_BUSY) + ERTS_BIF_YIELD1(bif_export[BIF_garbage_collect_1], BIF_P, BIF_ARG_1); + + /* The GC cost is taken for the process executing this BIF. */ + + FLAGS(rp) |= F_NEED_FULLSWEEP; + reds = erts_garbage_collect(rp, 0, rp->arg_reg, rp->arity); + + if (BIF_P != rp) + erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_MAIN); + + BIF_RET2(am_true, reds); +} + +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); +} + +/**********************************************************************/ +/* Perform garbage collection of the message area */ + +BIF_RETTYPE garbage_collect_message_area_0(BIF_ALIST_0) +{ +#if defined(HYBRID) && !defined(INCREMENTAL) + int reds = 0; + + FLAGS(BIF_P) |= F_NEED_FULLSWEEP; + reds = erts_global_garbage_collect(BIF_P, 0, NULL, 0); + BIF_RET2(am_true, reds); +#else + BIF_RET(am_false); +#endif +} + +/**********************************************************************/ +/* Return a list of active ports */ + +BIF_RETTYPE ports_0(BIF_ALIST_0) +{ + Eterm res = NIL; + Eterm* port_buf = erts_alloc(ERTS_ALC_T_TMP, + sizeof(Eterm)*erts_max_ports); + Eterm* pp = port_buf; + Eterm* dead_ports; + int alive, dead; + Uint32 next_ss; + + /* To get a consistent snapshot... + * We add alive ports from start of the buffer + * while dying ports are added from the other end by the killing threads. + */ + + erts_smp_mtx_lock(&ports_snapshot_mtx); /* One snapshot at a time */ + + erts_smp_atomic_set(&erts_dead_ports_ptr, (long) (port_buf + erts_max_ports)); + + next_ss = erts_smp_atomic_inctest(&erts_ports_snapshot); + + if (erts_smp_atomic_read(&erts_ports_alive) > 0) { + long i; + for (i = erts_max_ports-1; i >= 0; i--) { + Port* prt = &erts_port[i]; + erts_smp_port_state_lock(prt); + if (!(prt->status & ERTS_PORT_SFLGS_DEAD) + && prt->snapshot != next_ss) { + ASSERT(prt->snapshot == next_ss - 1); + *pp++ = prt->id; + prt->snapshot = next_ss; /* Consumed by this snapshot */ + } + erts_smp_port_state_unlock(prt); + } + } + + dead_ports = (Eterm*)erts_smp_atomic_xchg(&erts_dead_ports_ptr, + (long)NULL); + erts_smp_mtx_unlock(&ports_snapshot_mtx); + + ASSERT(pp <= dead_ports); + + alive = pp - port_buf; + dead = port_buf + erts_max_ports - dead_ports; + + ASSERT((alive+dead) <= erts_max_ports); + + if (alive+dead > 0) { + long i; + Eterm *hp = HAlloc(BIF_P, (alive+dead)*2); + + for (i = 0; i < alive; i++) { + res = CONS(hp, port_buf[i], res); + hp += 2; + } + for (i = 0; i < dead; i++) { + res = CONS(hp, dead_ports[i], res); + hp += 2; + } + } + + erts_free(ERTS_ALC_T_TMP, port_buf); + + BIF_RET(res); +} + +/**********************************************************************/ + +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); +} + + +Eterm +display_string_1(Process* p, Eterm string) +{ + 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); +} + +Eterm +display_nl_0(Process* p) +{ + 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/0\n")); + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN); + erl_exit(0, ""); + return NIL; /* Pedantic (lint does not know about erl_exit) */ +} + +/**********************************************************************/ + +#define MSG_SIZE 200 + +/* stop the system with exit code */ +/* ARGSUSED */ +BIF_RETTYPE halt_1(BIF_ALIST_1) +{ + Sint code; + static char msg[MSG_SIZE]; + int i; + + if (is_small(BIF_ARG_1) && (code = signed_val(BIF_ARG_1)) >= 0) { + VERBOSE(DEBUG_SYSTEM,("System halted by BIF halt(%d)\n", code)); + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN); + erl_exit(-code, ""); + } else if (is_string(BIF_ARG_1) || BIF_ARG_1 == NIL) { + if ((i = intlist_to_buf(BIF_ARG_1, msg, MSG_SIZE-1)) < 0) { + goto error; + } + msg[i] = '\0'; + VERBOSE(DEBUG_SYSTEM,("System halted by BIF halt(%s)\n", msg)); + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN); + erl_exit(ERTS_DUMP_EXIT, "%s\n", msg); + } else { + error: + BIF_ERROR(BIF_P, BADARG); + } + return NIL; /* Pedantic (lint does not know about erl_exit) */ +} + +BIF_RETTYPE function_exported_3(BIF_ALIST_3) +{ + if (is_not_atom(BIF_ARG_1) || + is_not_atom(BIF_ARG_2) || + is_not_small(BIF_ARG_3)) { + BIF_ERROR(BIF_P, BADARG); + } + if (erts_find_function(BIF_ARG_1, BIF_ARG_2, signed_val(BIF_ARG_3)) == NULL) { + BIF_RET(am_false); + } + BIF_RET(am_true); +} + +/**********************************************************************/ + +BIF_RETTYPE is_builtin_3(Process* p, Eterm Mod, Eterm Name, Eterm Arity) +{ + 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; + } + 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); + BIF_RET(make_export(hp)); +} + +Eterm +fun_to_list_1(Process* p, Eterm fun) +{ + 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; + + /* <a.b.c> a = node, b = process number, c = serial */ + + dep = erts_channel_no_to_dist_entry(a); + + if (!dep) + goto bad; + + + if (c > ERTS_MAX_PID_SERIAL || b > ERTS_MAX_PID_NUMBER) + goto bad; + + if(dep == erts_this_dist_entry) { + erts_deref_dist_entry(dep); + BIF_RET(make_internal_pid(make_pid_data(c, b))); + } + else { + ExternalThing *etp; + ErlNode *enp; + + if (is_nil(dep->cid)) + goto bad; + + enp = erts_find_or_insert_node(dep->sysname, dep->creation); + + etp = (ExternalThing *) HAlloc(BIF_P, EXTERNAL_THING_HEAD_SIZE + 1); + etp->header = make_external_pid_header(1); + etp->next = MSO(BIF_P).externals; + etp->node = enp; + etp->data.ui[0] = make_pid_data(c, b); + + MSO(BIF_P).externals = etp; + erts_deref_dist_entry(dep); + BIF_RET(make_external_pid(etp)); + } + + bad: + if (dep) + erts_deref_dist_entry(dep); + if (buf) + erts_free(ERTS_ALC_T_TMP, (void *) buf); + BIF_ERROR(BIF_P, BADARG); +} + +/**********************************************************************/ + +BIF_RETTYPE group_leader_0(BIF_ALIST_0) +{ + BIF_RET(BIF_P->group_leader); +} + +/**********************************************************************/ +/* arg1 == leader, arg2 == new member */ + +BIF_RETTYPE group_leader_2(BIF_ALIST_2) +{ + Process* new_member; + + if (is_not_pid(BIF_ARG_1)) { + BIF_ERROR(BIF_P, BADARG); + } + + if (is_external_pid(BIF_ARG_2)) { + DistEntry *dep; + int code; + ErtsDSigData dsd; + dep = external_pid_dist_entry(BIF_ARG_2); + if(dep == erts_this_dist_entry) + BIF_ERROR(BIF_P, BADARG); + + code = erts_dsig_prepare(&dsd, dep, BIF_P, ERTS_DSP_NO_LOCK, 0); + switch (code) { + case ERTS_DSIG_PREP_NOT_ALIVE: + BIF_RET(am_true); + case ERTS_DSIG_PREP_NOT_CONNECTED: + BIF_TRAP2(dgroup_leader_trap, BIF_P, BIF_ARG_1, BIF_ARG_2); + case ERTS_DSIG_PREP_CONNECTED: + code = erts_dsig_send_group_leader(&dsd, 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_internal_pid(BIF_ARG_2)) { + int await_x; + ErtsProcLocks locks = ERTS_PROC_LOCK_MAIN|ERTS_PROC_LOCK_STATUS; + new_member = erts_pid2proc_nropt(BIF_P, ERTS_PROC_LOCK_MAIN, + BIF_ARG_2, locks); + if (!new_member) + BIF_ERROR(BIF_P, BADARG); + + if (new_member == ERTS_PROC_LOCK_BUSY) + ERTS_BIF_YIELD2(bif_export[BIF_group_leader_2], BIF_P, + BIF_ARG_1, BIF_ARG_2); + + await_x = (new_member != BIF_P + && ERTS_PROC_PENDING_EXIT(new_member)); + if (!await_x) { + if (is_immed(BIF_ARG_1)) + new_member->group_leader = BIF_ARG_1; + else { + locks &= ~ERTS_PROC_LOCK_STATUS; + erts_smp_proc_unlock(new_member, ERTS_PROC_LOCK_STATUS); + new_member->group_leader = STORE_NC_IN_PROC(new_member, + BIF_ARG_1); + } + } + + if (new_member == BIF_P) + locks &= ~ERTS_PROC_LOCK_MAIN; + if (locks) + erts_smp_proc_unlock(new_member, locks); + + if (await_x) { + /* Wait for new_member to terminate; then badarg */ + Eterm args[2] = {BIF_ARG_1, BIF_ARG_2}; + ERTS_BIF_AWAIT_X_APPLY_TRAP(BIF_P, + BIF_ARG_2, + am_erlang, + am_group_leader, + args, + 2); + } + + BIF_RET(am_true); + } + else { + BIF_ERROR(BIF_P, BADARG); + } +} + +BIF_RETTYPE system_flag_2(BIF_ALIST_2) +{ + Sint n; + + if (BIF_ARG_1 == am_multi_scheduling) { + if (BIF_ARG_2 == am_block || BIF_ARG_2 == am_unblock) { +#ifndef ERTS_SMP + BIF_RET(am_disabled); +#else + if (erts_no_schedulers == 1) + BIF_RET(am_disabled); + else { + switch (erts_block_multi_scheduling(BIF_P, + ERTS_PROC_LOCK_MAIN, + BIF_ARG_2 == am_block, + 0)) { + case ERTS_SCHDLR_SSPND_DONE_MSCHED_BLOCKED: + BIF_RET(am_blocked); + case ERTS_SCHDLR_SSPND_YIELD_DONE_MSCHED_BLOCKED: + ERTS_BIF_YIELD_RETURN_X(BIF_P, am_blocked, + am_multi_scheduling); + case ERTS_SCHDLR_SSPND_DONE: + BIF_RET(am_enabled); + case ERTS_SCHDLR_SSPND_YIELD_RESTART: + ERTS_VBUMP_ALL_REDS(BIF_P); + BIF_TRAP2(bif_export[BIF_system_flag_2], + BIF_P, BIF_ARG_1, BIF_ARG_2); + case ERTS_SCHDLR_SSPND_YIELD_DONE: + ERTS_BIF_YIELD_RETURN_X(BIF_P, am_enabled, + am_multi_scheduling); + case ERTS_SCHDLR_SSPND_EINVAL: + goto error; + default: + ASSERT(0); + BIF_ERROR(BIF_P, EXC_INTERNAL_ERROR); + break; + } + } +#endif + } + } else if (BIF_ARG_1 == am_schedulers_online) { +#ifndef ERTS_SMP + if (BIF_ARG_2 != make_small(1)) + goto error; + else + BIF_RET(make_small(1)); +#else + Sint old_no; + if (!is_small(BIF_ARG_2)) + goto error; + switch (erts_set_schedulers_online(BIF_P, + ERTS_PROC_LOCK_MAIN, + signed_val(BIF_ARG_2), + &old_no)) { + case ERTS_SCHDLR_SSPND_DONE: + BIF_RET(make_small(old_no)); + case ERTS_SCHDLR_SSPND_YIELD_RESTART: + ERTS_VBUMP_ALL_REDS(BIF_P); + BIF_TRAP2(bif_export[BIF_system_flag_2], + BIF_P, BIF_ARG_1, BIF_ARG_2); + case ERTS_SCHDLR_SSPND_YIELD_DONE: + ERTS_BIF_YIELD_RETURN_X(BIF_P, make_small(old_no), + am_schedulers_online); + case ERTS_SCHDLR_SSPND_EINVAL: + goto error; + default: + ASSERT(0); + BIF_ERROR(BIF_P, EXC_INTERNAL_ERROR); + break; + } +#endif + } else if (BIF_ARG_1 == am_fullsweep_after) { + Uint16 nval; + Uint oval; + if (!is_small(BIF_ARG_2) || (n = signed_val(BIF_ARG_2)) < 0) { + goto error; + } + nval = (n > (Sint) ((Uint16) -1)) ? ((Uint16) -1) : ((Uint16) n); + oval = (Uint) erts_smp_atomic_xchg(&erts_max_gen_gcs, (long) nval); + BIF_RET(make_small(oval)); + } else if (BIF_ARG_1 == am_min_heap_size) { + int oval = H_MIN_SIZE; + if (!is_small(BIF_ARG_2) || (n = signed_val(BIF_ARG_2)) < 0) { + goto error; + } + H_MIN_SIZE = erts_next_heap_size(n, 0); + BIF_RET(make_small(oval)); + } else if (BIF_ARG_1 == am_display_items) { + int oval = display_items; + if (!is_small(BIF_ARG_2) || (n = signed_val(BIF_ARG_2)) < 0) { + goto error; + } + display_items = n < 32 ? 32 : n; + BIF_RET(make_small(oval)); + } else if (BIF_ARG_1 == am_debug_flags) { + BIF_RET(am_true); + } else if (BIF_ARG_1 == am_backtrace_depth) { + int oval = erts_backtrace_depth; + if (!is_small(BIF_ARG_2) || (n = signed_val(BIF_ARG_2)) < 0) { + goto error; + } + if (n > MAX_BACKTRACE_SIZE) n = MAX_BACKTRACE_SIZE; + erts_backtrace_depth = n; + BIF_RET(make_small(oval)); + } else if (BIF_ARG_1 == am_trace_control_word) { + BIF_RET(db_set_trace_control_word_1(BIF_P, BIF_ARG_2)); + } else if (BIF_ARG_1 == am_sequential_tracer) { + Eterm old_value = erts_set_system_seq_tracer(BIF_P, + ERTS_PROC_LOCK_MAIN, + BIF_ARG_2); + if (old_value != THE_NON_VALUE) { + BIF_RET(old_value); + } + } else if (BIF_ARG_1 == make_small(1)) { + Uint i; + ErlMessage* mp; + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN); + erts_smp_block_system(0); + + for (i = 0; i < erts_max_processes; i++) { + if (process_tab[i] != (Process*) 0) { + Process* p = process_tab[i]; + p->seq_trace_token = NIL; + p->seq_trace_clock = 0; + p->seq_trace_lastcnt = 0; + ERTS_SMP_MSGQ_MV_INQ2PRIVQ(p); + mp = p->msg.first; + while(mp != NULL) { + ERL_MESSAGE_TOKEN(mp) = NIL; + mp = mp->next; + } + } + } + + erts_smp_release_system(); + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_MAIN); + + BIF_RET(am_true); + } else if (ERTS_IS_ATOM_STR("scheduling_statistics", BIF_ARG_1)) { + int what; + if (ERTS_IS_ATOM_STR("disable", BIF_ARG_2)) + what = ERTS_SCHED_STAT_MODIFY_DISABLE; + else if (ERTS_IS_ATOM_STR("enable", BIF_ARG_2)) + what = ERTS_SCHED_STAT_MODIFY_ENABLE; + else if (ERTS_IS_ATOM_STR("clear", BIF_ARG_2)) + what = ERTS_SCHED_STAT_MODIFY_CLEAR; + else + goto error; + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN); + erts_sched_stat_modify(what); + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_MAIN); + BIF_RET(am_true); + } else if (ERTS_IS_ATOM_STR("internal_cpu_topology", BIF_ARG_1)) { + Eterm res = erts_set_cpu_topology(BIF_P, BIF_ARG_2); + if (is_value(res)) + BIF_RET(res); + } else if (ERTS_IS_ATOM_STR("cpu_topology", BIF_ARG_1)) { + BIF_TRAP1(set_cpu_topology_trap, BIF_P, BIF_ARG_2); + } else if (ERTS_IS_ATOM_STR("scheduler_bind_type", BIF_ARG_1)) { + return erts_bind_schedulers(BIF_P, BIF_ARG_2); + } + error: + BIF_ERROR(BIF_P, BADARG); +} + +/**********************************************************************/ + +BIF_RETTYPE hash_2(BIF_ALIST_2) +{ + Uint32 hash; + Sint range; + + if (is_not_small(BIF_ARG_2)) { + BIF_ERROR(BIF_P, BADARG); + } + if ((range = signed_val(BIF_ARG_2)) <= 0) { /* [1..MAX_SMALL] */ + BIF_ERROR(BIF_P, BADARG); + } +#ifdef ARCH_64 + if (range > ((1L << 27) - 1)) + BIF_ERROR(BIF_P, BADARG); +#endif + hash = make_broken_hash(BIF_ARG_1); + BIF_RET(make_small(1 + (hash % range))); /* [1..range] */ +} + +BIF_RETTYPE phash_2(BIF_ALIST_2) +{ + Uint32 hash; + Uint32 final_hash; + Uint32 range; + + /* Check for special case 2^32 */ + if (term_equals_2pow32(BIF_ARG_2)) { + range = 0; + } else { + Uint u; + if (!term_to_Uint(BIF_ARG_2, &u) || ((u >> 16) >> 16) != 0 || !u) { + BIF_ERROR(BIF_P, BADARG); + } + range = (Uint32) u; + } + hash = make_hash(BIF_ARG_1); + if (range) { + final_hash = 1 + (hash % range); /* [1..range] */ + } else if ((final_hash = hash + 1) == 0) { + /* + * XXX In this case, there will still be a ArithAlloc() in erts_mixed_plus(). + */ + BIF_RET(erts_mixed_plus(BIF_P, + erts_make_integer(hash, BIF_P), + make_small(1))); + } + + BIF_RET(erts_make_integer(final_hash, BIF_P)); +} + +BIF_RETTYPE phash2_1(BIF_ALIST_1) +{ + Uint32 hash; + + hash = make_hash2(BIF_ARG_1); + BIF_RET(make_small(hash & ((1L << 27) - 1))); +} + +BIF_RETTYPE phash2_2(BIF_ALIST_2) +{ + Uint32 hash; + Uint32 final_hash; + Uint32 range; + + /* Check for special case 2^32 */ + if (term_equals_2pow32(BIF_ARG_2)) { + range = 0; + } else { + Uint u; + if (!term_to_Uint(BIF_ARG_2, &u) || ((u >> 16) >> 16) != 0 || !u) { + BIF_ERROR(BIF_P, BADARG); + } + range = (Uint32) u; + } + hash = make_hash2(BIF_ARG_1); + if (range) { + final_hash = hash % range; /* [0..range-1] */ + } else { + final_hash = hash; + } + /* + * Return either a small or a big. Use the heap for bigs if there is room. + */ +#ifdef ARCH_64 + BIF_RET(make_small(final_hash)); +#else + if (IS_USMALL(0, final_hash)) { + BIF_RET(make_small(final_hash)); + } else { + Eterm* hp = HAlloc(BIF_P, BIG_UINT_HEAP_SIZE); + BIF_RET(uint_to_big(final_hash, hp)); + } +#endif +} + +BIF_RETTYPE bump_reductions_1(BIF_ALIST_1) +{ + Sint reds; + + if (is_not_small(BIF_ARG_1) || ((reds = signed_val(BIF_ARG_1)) < 0)) { + BIF_ERROR(BIF_P, BADARG); + } + + if (reds > CONTEXT_REDS) { + reds = CONTEXT_REDS; + } + BIF_RET2(am_true, reds); +} + +/* + * Processes doing yield on return in a bif ends up in bif_return_trap(). + */ +static BIF_RETTYPE bif_return_trap( +#ifdef DEBUG + BIF_ALIST_2 +#else + BIF_ALIST_1 +#endif + ) +{ +#ifdef DEBUG + switch (BIF_ARG_2) { + case am_multi_scheduling: +#ifdef ERTS_SMP + erts_dbg_multi_scheduling_return_trap(BIF_P, BIF_ARG_1); +#endif + break; + case am_schedulers_online: + break; + default: + break; + } +#endif + + BIF_RET(BIF_ARG_1); +} + +/* + * NOTE: The erts_bif_prep_await_proc_exit_*() functions are + * tightly coupled with the implementation of erlang:await_proc_exit/3. + * The erts_bif_prep_await_proc_exit_*() functions can safely call + * skip_current_msgq() since they know that erlang:await_proc_exit/3 + * unconditionally will do a monitor and then unconditionally will + * wait for the corresponding 'DOWN' message in a receive, and no other + * receive is done before this receive. This optimization removes an + * unnecessary scan of the currently existing message queue (which + * can be large). If the erlang:await_proc_exit/3 implementation + * is changed so that the above isn't true, nasty bugs in later + * receives, etc, may appear. + */ + +static ERTS_INLINE int +skip_current_msgq(Process *c_p) +{ + int res; +#if defined(ERTS_ENABLE_LOCK_CHECK) && defined(ERTS_SMP) + erts_proc_lc_chk_only_proc_main(c_p); +#endif + + erts_smp_proc_lock(c_p, ERTS_PROC_LOCKS_MSG_RECEIVE); + if (ERTS_PROC_PENDING_EXIT(c_p)) { + KILL_CATCHES(c_p); + c_p->freason = EXC_EXIT; + res = 0; + } + else { + ERTS_SMP_MSGQ_MV_INQ2PRIVQ(c_p); + c_p->msg.save = c_p->msg.last; + res = 1; + } + erts_smp_proc_unlock(c_p, ERTS_PROC_LOCKS_MSG_RECEIVE); + return res; +} + +void +erts_bif_prep_await_proc_exit_data_trap(Process *c_p, Eterm pid, Eterm ret) +{ + if (skip_current_msgq(c_p)) { + Eterm unused; + ERTS_BIF_PREP_TRAP3(unused, await_proc_exit_trap, c_p, pid, am_data, ret); + } +} + +void +erts_bif_prep_await_proc_exit_reason_trap(Process *c_p, Eterm pid) +{ + if (skip_current_msgq(c_p)) { + Eterm unused; + ERTS_BIF_PREP_TRAP3(unused, await_proc_exit_trap, c_p, + pid, am_reason, am_undefined); + } +} + +void +erts_bif_prep_await_proc_exit_apply_trap(Process *c_p, + Eterm pid, + Eterm module, + Eterm function, + Eterm args[], + int nargs) +{ + ASSERT(is_atom(module) && is_atom(function)); + if (skip_current_msgq(c_p)) { + Eterm unused; + Eterm term; + Eterm *hp; + int i; + + hp = HAlloc(c_p, 4+2*nargs); + term = NIL; + for (i = nargs-1; i >= 0; i--) { + term = CONS(hp, args[i], term); + hp += 2; + } + term = TUPLE3(hp, module, function, term); + ERTS_BIF_PREP_TRAP3(unused, await_proc_exit_trap, c_p, pid, am_apply, term); + } +} + +Export bif_return_trap_export; + +void erts_init_bif(void) +{ + reference0 = 0; + reference1 = 0; + reference2 = 0; + + erts_smp_spinlock_init(&make_ref_lock, "make_ref"); + erts_smp_mtx_init(&ports_snapshot_mtx, "ports_snapshot"); + erts_smp_atomic_init(&erts_dead_ports_ptr, (long)NULL); + + /* + * bif_return_trap/1 is a hidden BIF that bifs that need to + * yield the calling process traps to. The only thing it does: + * return the value passed as argument. + */ + sys_memset((void *) &bif_return_trap_export, 0, sizeof(Export)); + bif_return_trap_export.address = &bif_return_trap_export.code[3]; + bif_return_trap_export.code[0] = am_erlang; + bif_return_trap_export.code[1] = am_bif_return_trap; +#ifdef DEBUG + bif_return_trap_export.code[2] = 2; +#else + bif_return_trap_export.code[2] = 1; +#endif + bif_return_trap_export.code[3] = (Eterm) em_apply_bif; + bif_return_trap_export.code[4] = (Eterm) &bif_return_trap; + + flush_monitor_message_trap = erts_export_put(am_erlang, + am_flush_monitor_message, + 2); + + set_cpu_topology_trap = erts_export_put(am_erlang, + am_set_cpu_topology, + 1); + erts_format_cpu_topology_trap = erts_export_put(am_erlang, + am_format_cpu_topology, + 1); + await_proc_exit_trap = erts_export_put(am_erlang,am_await_proc_exit,3); +} + +BIF_RETTYPE blocking_read_file_1(BIF_ALIST_1) +{ + Eterm bin; + Eterm* hp; + byte *buff; + int i, buff_size; + FILE *file; + struct stat file_info; + char *filename = NULL; + + i = list_length(BIF_ARG_1); + if (i < 0) { + BIF_ERROR(BIF_P, BADARG); + } + filename = erts_alloc(ERTS_ALC_T_TMP, i + 1); + if (intlist_to_buf(BIF_ARG_1, filename, i) != i) + erl_exit(1, "%s:%d: Internal error\n", __FILE__, __LINE__); + filename[i] = '\0'; + + hp = HAlloc(BIF_P, 3); + + file = fopen(filename, "r"); + if(file == NULL){ + erts_free(ERTS_ALC_T_TMP, (void *) filename); + BIF_RET(TUPLE2(hp, am_error, am_nofile)); + } + + stat(filename, &file_info); + erts_free(ERTS_ALC_T_TMP, (void *) filename); + + buff_size = file_info.st_size; + buff = (byte *) erts_alloc_fnf(ERTS_ALC_T_TMP, buff_size); + if (!buff) { + fclose(file); + BIF_RET(TUPLE2(hp, am_error, am_allocator)); + } + fread(buff, 1, buff_size, file); + fclose(file); + bin = new_binary(BIF_P, buff, buff_size); + erts_free(ERTS_ALC_T_TMP, (void *) buff); + + BIF_RET(TUPLE2(hp, am_ok, bin)); +} +#ifdef HARDDEBUG +/* +You'll need this line in bif.tab to be able to use this debug bif + +bif erlang:send_to_logger/2 + +*/ +BIF_RETTYPE send_to_logger_2(BIF_ALIST_2) +{ + byte *buf; + int len; + if (!is_atom(BIF_ARG_1) || !(is_list(BIF_ARG_2) || + is_nil(BIF_ARG_1))) { + BIF_ERROR(BIF_P,BADARG); + } + len = io_list_len(BIF_ARG_2); + if (len < 0) + BIF_ERROR(BIF_P,BADARG); + else if (len == 0) + buf = ""; + else { +#ifdef DEBUG + int len2; +#endif + buf = (byte *) erts_alloc(ERTS_ALC_T_TMP, len+1); +#ifdef DEBUG + len2 = +#else + (void) +#endif + io_list_to_buf(BIF_ARG_2, buf, len); + ASSERT(len2 == len); + buf[len] = '\0'; + switch (BIF_ARG_1) { + case am_info: + erts_send_info_to_logger(BIF_P->group_leader, buf, len); + break; + case am_warning: + erts_send_warning_to_logger(BIF_P->group_leader, buf, len); + break; + case am_error: + erts_send_error_to_logger(BIF_P->group_leader, buf, len); + break; + default: + { + BIF_ERROR(BIF_P,BADARG); + } + } + erts_free(ERTS_ALC_T_TMP, (void *) buf); + } + BIF_RET(am_true); +} +#endif /* HARDDEBUG */ + +BIF_RETTYPE get_module_info_1(BIF_ALIST_1) +{ + Eterm ret = erts_module_info_0(BIF_P, BIF_ARG_1); + + if (is_non_value(ret)) { + BIF_ERROR(BIF_P, BADARG); + } + BIF_RET(ret); +} + + +BIF_RETTYPE get_module_info_2(BIF_ALIST_2) +{ + Eterm ret = erts_module_info_1(BIF_P, BIF_ARG_1, BIF_ARG_2); + + if (is_non_value(ret)) { + BIF_ERROR(BIF_P, BADARG); + } + BIF_RET(ret); +} |