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