From 84adefa331c4159d432d22840663c38f155cd4c1 Mon Sep 17 00:00:00 2001 From: Erlang/OTP Date: Fri, 20 Nov 2009 14:54:40 +0000 Subject: The R13B03 release. --- erts/emulator/beam/atom.c | 354 + erts/emulator/beam/atom.h | 104 + erts/emulator/beam/atom.names | 540 ++ erts/emulator/beam/beam_bif_load.c | 795 +++ erts/emulator/beam/beam_bp.c | 785 ++ erts/emulator/beam/beam_bp.h | 165 + erts/emulator/beam/beam_catches.c | 102 + erts/emulator/beam/beam_catches.h | 32 + erts/emulator/beam/beam_debug.c | 548 ++ erts/emulator/beam/beam_emu.c | 6198 ++++++++++++++++ erts/emulator/beam/beam_load.c | 5234 ++++++++++++++ erts/emulator/beam/beam_load.h | 120 + erts/emulator/beam/benchmark.c | 395 ++ erts/emulator/beam/benchmark.h | 340 + erts/emulator/beam/bif.c | 4201 +++++++++++ erts/emulator/beam/bif.h | 386 + erts/emulator/beam/bif.tab | 761 ++ erts/emulator/beam/big.c | 2241 ++++++ erts/emulator/beam/big.h | 155 + erts/emulator/beam/binary.c | 677 ++ erts/emulator/beam/break.c | 747 ++ erts/emulator/beam/copy.c | 981 +++ erts/emulator/beam/decl.h | 55 + erts/emulator/beam/dist.c | 3256 +++++++++ erts/emulator/beam/dist.h | 290 + erts/emulator/beam/elib_malloc.c | 2334 ++++++ erts/emulator/beam/elib_memmove.c | 113 + erts/emulator/beam/elib_stat.h | 45 + erts/emulator/beam/erl_afit_alloc.c | 256 + erts/emulator/beam/erl_afit_alloc.h | 67 + erts/emulator/beam/erl_alloc.c | 3157 +++++++++ erts/emulator/beam/erl_alloc.h | 564 ++ erts/emulator/beam/erl_alloc.types | 383 + erts/emulator/beam/erl_alloc_util.c | 3467 +++++++++ erts/emulator/beam/erl_alloc_util.h | 342 + erts/emulator/beam/erl_arith.c | 2040 ++++++ erts/emulator/beam/erl_async.c | 469 ++ erts/emulator/beam/erl_bestfit_alloc.c | 1161 +++ erts/emulator/beam/erl_bestfit_alloc.h | 64 + erts/emulator/beam/erl_bif_chksum.c | 612 ++ erts/emulator/beam/erl_bif_ddll.c | 1964 +++++ erts/emulator/beam/erl_bif_guard.c | 628 ++ erts/emulator/beam/erl_bif_info.c | 3803 ++++++++++ erts/emulator/beam/erl_bif_lists.c | 392 + erts/emulator/beam/erl_bif_op.c | 327 + erts/emulator/beam/erl_bif_os.c | 190 + erts/emulator/beam/erl_bif_port.c | 1476 ++++ erts/emulator/beam/erl_bif_re.c | 1142 +++ erts/emulator/beam/erl_bif_timer.c | 701 ++ erts/emulator/beam/erl_bif_timer.h | 36 + erts/emulator/beam/erl_bif_trace.c | 2106 ++++++ erts/emulator/beam/erl_binary.h | 282 + erts/emulator/beam/erl_bits.c | 1975 ++++++ erts/emulator/beam/erl_bits.h | 212 + erts/emulator/beam/erl_db.c | 3631 ++++++++++ erts/emulator/beam/erl_db.h | 247 + erts/emulator/beam/erl_db_hash.c | 2868 ++++++++ erts/emulator/beam/erl_db_hash.h | 103 + erts/emulator/beam/erl_db_tree.c | 3289 +++++++++ erts/emulator/beam/erl_db_tree.h | 55 + erts/emulator/beam/erl_db_util.c | 4651 ++++++++++++ erts/emulator/beam/erl_db_util.h | 405 ++ erts/emulator/beam/erl_debug.c | 899 +++ erts/emulator/beam/erl_debug.h | 102 + erts/emulator/beam/erl_driver.h | 626 ++ erts/emulator/beam/erl_drv_thread.c | 706 ++ erts/emulator/beam/erl_fun.c | 315 + erts/emulator/beam/erl_fun.h | 92 + erts/emulator/beam/erl_gc.c | 2690 +++++++ erts/emulator/beam/erl_gc.h | 72 + erts/emulator/beam/erl_goodfit_alloc.c | 662 ++ erts/emulator/beam/erl_goodfit_alloc.h | 88 + erts/emulator/beam/erl_init.c | 1461 ++++ erts/emulator/beam/erl_instrument.c | 1221 ++++ erts/emulator/beam/erl_instrument.h | 41 + erts/emulator/beam/erl_lock_check.c | 1307 ++++ erts/emulator/beam/erl_lock_check.h | 117 + erts/emulator/beam/erl_lock_count.c | 675 ++ erts/emulator/beam/erl_lock_count.h | 195 + erts/emulator/beam/erl_math.c | 233 + erts/emulator/beam/erl_md5.c | 340 + erts/emulator/beam/erl_message.c | 1070 +++ erts/emulator/beam/erl_message.h | 251 + erts/emulator/beam/erl_monitors.c | 1019 +++ erts/emulator/beam/erl_monitors.h | 180 + erts/emulator/beam/erl_mtrace.c | 1240 ++++ erts/emulator/beam/erl_mtrace.h | 51 + erts/emulator/beam/erl_nif.c | 641 ++ erts/emulator/beam/erl_nif.h | 122 + erts/emulator/beam/erl_nif_api_funcs.h | 68 + erts/emulator/beam/erl_nmgc.c | 1402 ++++ erts/emulator/beam/erl_nmgc.h | 364 + erts/emulator/beam/erl_node_container_utils.h | 318 + erts/emulator/beam/erl_node_tables.c | 1660 +++++ erts/emulator/beam/erl_node_tables.h | 261 + erts/emulator/beam/erl_obsolete.c | 186 + erts/emulator/beam/erl_port_task.c | 1100 +++ erts/emulator/beam/erl_port_task.h | 135 + erts/emulator/beam/erl_posix_str.c | 641 ++ erts/emulator/beam/erl_printf_term.c | 458 ++ erts/emulator/beam/erl_printf_term.h | 26 + erts/emulator/beam/erl_process.c | 9469 +++++++++++++++++++++++++ erts/emulator/beam/erl_process.h | 1495 ++++ erts/emulator/beam/erl_process_dict.c | 1001 +++ erts/emulator/beam/erl_process_dict.h | 42 + erts/emulator/beam/erl_process_dump.c | 454 ++ erts/emulator/beam/erl_process_lock.c | 1431 ++++ erts/emulator/beam/erl_process_lock.h | 990 +++ erts/emulator/beam/erl_resolv_dns.c | 23 + erts/emulator/beam/erl_resolv_nodns.c | 23 + erts/emulator/beam/erl_smp.h | 993 +++ erts/emulator/beam/erl_sock.h | 44 + erts/emulator/beam/erl_sys_driver.h | 44 + erts/emulator/beam/erl_term.c | 174 + erts/emulator/beam/erl_term.h | 1056 +++ erts/emulator/beam/erl_threads.h | 1524 ++++ erts/emulator/beam/erl_time.h | 67 + erts/emulator/beam/erl_time_sup.c | 899 +++ erts/emulator/beam/erl_trace.c | 3260 +++++++++ erts/emulator/beam/erl_unicode.c | 1815 +++++ erts/emulator/beam/erl_unicode.h | 23 + erts/emulator/beam/erl_vm.h | 204 + erts/emulator/beam/erl_zlib.c | 113 + erts/emulator/beam/erl_zlib.h | 52 + erts/emulator/beam/error.h | 196 + erts/emulator/beam/export.c | 296 + erts/emulator/beam/export.h | 79 + erts/emulator/beam/external.c | 2839 ++++++++ erts/emulator/beam/external.h | 211 + erts/emulator/beam/fix_alloc.c | 287 + erts/emulator/beam/global.h | 1800 +++++ erts/emulator/beam/hash.c | 407 ++ erts/emulator/beam/hash.h | 97 + erts/emulator/beam/index.c | 137 + erts/emulator/beam/index.h | 71 + erts/emulator/beam/io.c | 4732 ++++++++++++ erts/emulator/beam/module.c | 134 + erts/emulator/beam/module.h | 56 + erts/emulator/beam/ops.tab | 1430 ++++ erts/emulator/beam/packet_parser.c | 847 +++ erts/emulator/beam/packet_parser.h | 181 + erts/emulator/beam/register.c | 655 ++ erts/emulator/beam/register.h | 66 + erts/emulator/beam/safe_hash.c | 276 + erts/emulator/beam/safe_hash.h | 104 + erts/emulator/beam/sys.h | 1257 ++++ erts/emulator/beam/time.c | 571 ++ erts/emulator/beam/utils.c | 4053 +++++++++++ erts/emulator/beam/version.h | 19 + 149 files changed, 144051 insertions(+) create mode 100644 erts/emulator/beam/atom.c create mode 100644 erts/emulator/beam/atom.h create mode 100644 erts/emulator/beam/atom.names create mode 100644 erts/emulator/beam/beam_bif_load.c create mode 100644 erts/emulator/beam/beam_bp.c create mode 100644 erts/emulator/beam/beam_bp.h create mode 100644 erts/emulator/beam/beam_catches.c create mode 100644 erts/emulator/beam/beam_catches.h create mode 100644 erts/emulator/beam/beam_debug.c create mode 100644 erts/emulator/beam/beam_emu.c create mode 100644 erts/emulator/beam/beam_load.c create mode 100644 erts/emulator/beam/beam_load.h create mode 100644 erts/emulator/beam/benchmark.c create mode 100644 erts/emulator/beam/benchmark.h create mode 100644 erts/emulator/beam/bif.c create mode 100644 erts/emulator/beam/bif.h create mode 100644 erts/emulator/beam/bif.tab create mode 100644 erts/emulator/beam/big.c create mode 100644 erts/emulator/beam/big.h create mode 100644 erts/emulator/beam/binary.c create mode 100644 erts/emulator/beam/break.c create mode 100644 erts/emulator/beam/copy.c create mode 100644 erts/emulator/beam/decl.h create mode 100644 erts/emulator/beam/dist.c create mode 100644 erts/emulator/beam/dist.h create mode 100644 erts/emulator/beam/elib_malloc.c create mode 100644 erts/emulator/beam/elib_memmove.c create mode 100644 erts/emulator/beam/elib_stat.h create mode 100644 erts/emulator/beam/erl_afit_alloc.c create mode 100644 erts/emulator/beam/erl_afit_alloc.h create mode 100644 erts/emulator/beam/erl_alloc.c create mode 100644 erts/emulator/beam/erl_alloc.h create mode 100644 erts/emulator/beam/erl_alloc.types create mode 100644 erts/emulator/beam/erl_alloc_util.c create mode 100644 erts/emulator/beam/erl_alloc_util.h create mode 100644 erts/emulator/beam/erl_arith.c create mode 100644 erts/emulator/beam/erl_async.c create mode 100644 erts/emulator/beam/erl_bestfit_alloc.c create mode 100644 erts/emulator/beam/erl_bestfit_alloc.h create mode 100644 erts/emulator/beam/erl_bif_chksum.c create mode 100644 erts/emulator/beam/erl_bif_ddll.c create mode 100644 erts/emulator/beam/erl_bif_guard.c create mode 100644 erts/emulator/beam/erl_bif_info.c create mode 100644 erts/emulator/beam/erl_bif_lists.c create mode 100644 erts/emulator/beam/erl_bif_op.c create mode 100644 erts/emulator/beam/erl_bif_os.c create mode 100644 erts/emulator/beam/erl_bif_port.c create mode 100644 erts/emulator/beam/erl_bif_re.c create mode 100644 erts/emulator/beam/erl_bif_timer.c create mode 100644 erts/emulator/beam/erl_bif_timer.h create mode 100644 erts/emulator/beam/erl_bif_trace.c create mode 100644 erts/emulator/beam/erl_binary.h create mode 100644 erts/emulator/beam/erl_bits.c create mode 100644 erts/emulator/beam/erl_bits.h create mode 100644 erts/emulator/beam/erl_db.c create mode 100644 erts/emulator/beam/erl_db.h create mode 100644 erts/emulator/beam/erl_db_hash.c create mode 100644 erts/emulator/beam/erl_db_hash.h create mode 100644 erts/emulator/beam/erl_db_tree.c create mode 100644 erts/emulator/beam/erl_db_tree.h create mode 100644 erts/emulator/beam/erl_db_util.c create mode 100644 erts/emulator/beam/erl_db_util.h create mode 100644 erts/emulator/beam/erl_debug.c create mode 100644 erts/emulator/beam/erl_debug.h create mode 100644 erts/emulator/beam/erl_driver.h create mode 100644 erts/emulator/beam/erl_drv_thread.c create mode 100644 erts/emulator/beam/erl_fun.c create mode 100644 erts/emulator/beam/erl_fun.h create mode 100644 erts/emulator/beam/erl_gc.c create mode 100644 erts/emulator/beam/erl_gc.h create mode 100644 erts/emulator/beam/erl_goodfit_alloc.c create mode 100644 erts/emulator/beam/erl_goodfit_alloc.h create mode 100644 erts/emulator/beam/erl_init.c create mode 100644 erts/emulator/beam/erl_instrument.c create mode 100644 erts/emulator/beam/erl_instrument.h create mode 100644 erts/emulator/beam/erl_lock_check.c create mode 100644 erts/emulator/beam/erl_lock_check.h create mode 100644 erts/emulator/beam/erl_lock_count.c create mode 100644 erts/emulator/beam/erl_lock_count.h create mode 100644 erts/emulator/beam/erl_math.c create mode 100644 erts/emulator/beam/erl_md5.c create mode 100644 erts/emulator/beam/erl_message.c create mode 100644 erts/emulator/beam/erl_message.h create mode 100644 erts/emulator/beam/erl_monitors.c create mode 100644 erts/emulator/beam/erl_monitors.h create mode 100644 erts/emulator/beam/erl_mtrace.c create mode 100644 erts/emulator/beam/erl_mtrace.h create mode 100644 erts/emulator/beam/erl_nif.c create mode 100644 erts/emulator/beam/erl_nif.h create mode 100644 erts/emulator/beam/erl_nif_api_funcs.h create mode 100644 erts/emulator/beam/erl_nmgc.c create mode 100644 erts/emulator/beam/erl_nmgc.h create mode 100644 erts/emulator/beam/erl_node_container_utils.h create mode 100644 erts/emulator/beam/erl_node_tables.c create mode 100644 erts/emulator/beam/erl_node_tables.h create mode 100644 erts/emulator/beam/erl_obsolete.c create mode 100644 erts/emulator/beam/erl_port_task.c create mode 100644 erts/emulator/beam/erl_port_task.h create mode 100644 erts/emulator/beam/erl_posix_str.c create mode 100644 erts/emulator/beam/erl_printf_term.c create mode 100644 erts/emulator/beam/erl_printf_term.h create mode 100644 erts/emulator/beam/erl_process.c create mode 100644 erts/emulator/beam/erl_process.h create mode 100644 erts/emulator/beam/erl_process_dict.c create mode 100644 erts/emulator/beam/erl_process_dict.h create mode 100644 erts/emulator/beam/erl_process_dump.c create mode 100644 erts/emulator/beam/erl_process_lock.c create mode 100644 erts/emulator/beam/erl_process_lock.h create mode 100644 erts/emulator/beam/erl_resolv_dns.c create mode 100644 erts/emulator/beam/erl_resolv_nodns.c create mode 100644 erts/emulator/beam/erl_smp.h create mode 100644 erts/emulator/beam/erl_sock.h create mode 100644 erts/emulator/beam/erl_sys_driver.h create mode 100644 erts/emulator/beam/erl_term.c create mode 100644 erts/emulator/beam/erl_term.h create mode 100644 erts/emulator/beam/erl_threads.h create mode 100644 erts/emulator/beam/erl_time.h create mode 100644 erts/emulator/beam/erl_time_sup.c create mode 100644 erts/emulator/beam/erl_trace.c create mode 100644 erts/emulator/beam/erl_unicode.c create mode 100644 erts/emulator/beam/erl_unicode.h create mode 100644 erts/emulator/beam/erl_vm.h create mode 100644 erts/emulator/beam/erl_zlib.c create mode 100644 erts/emulator/beam/erl_zlib.h create mode 100644 erts/emulator/beam/error.h create mode 100644 erts/emulator/beam/export.c create mode 100644 erts/emulator/beam/export.h create mode 100644 erts/emulator/beam/external.c create mode 100644 erts/emulator/beam/external.h create mode 100644 erts/emulator/beam/fix_alloc.c create mode 100644 erts/emulator/beam/global.h create mode 100644 erts/emulator/beam/hash.c create mode 100644 erts/emulator/beam/hash.h create mode 100644 erts/emulator/beam/index.c create mode 100644 erts/emulator/beam/index.h create mode 100644 erts/emulator/beam/io.c create mode 100644 erts/emulator/beam/module.c create mode 100644 erts/emulator/beam/module.h create mode 100644 erts/emulator/beam/ops.tab create mode 100644 erts/emulator/beam/packet_parser.c create mode 100644 erts/emulator/beam/packet_parser.h create mode 100644 erts/emulator/beam/register.c create mode 100644 erts/emulator/beam/register.h create mode 100644 erts/emulator/beam/safe_hash.c create mode 100644 erts/emulator/beam/safe_hash.h create mode 100644 erts/emulator/beam/sys.h create mode 100644 erts/emulator/beam/time.c create mode 100644 erts/emulator/beam/utils.c create mode 100644 erts/emulator/beam/version.h (limited to 'erts/emulator/beam') diff --git a/erts/emulator/beam/atom.c b/erts/emulator/beam/atom.c new file mode 100644 index 0000000000..dfc3cde6a7 --- /dev/null +++ b/erts/emulator/beam/atom.c @@ -0,0 +1,354 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_sys_driver.h" +#include "erl_vm.h" +#include "global.h" +#include "hash.h" +#include "atom.h" + + +#define ATOM_SIZE 3000 + +IndexTable erts_atom_table; /* The index table */ + +#include "erl_smp.h" + +static erts_smp_rwmtx_t atom_table_lock; + +#define atom_read_lock() erts_smp_rwmtx_rlock(&atom_table_lock) +#define atom_read_unlock() erts_smp_rwmtx_runlock(&atom_table_lock) +#define atom_write_lock() erts_smp_rwmtx_rwlock(&atom_table_lock) +#define atom_write_unlock() erts_smp_rwmtx_rwunlock(&atom_table_lock) +#define atom_init_lock() erts_smp_rwmtx_init(&atom_table_lock, \ + "atom_tab") +#if 0 +#define ERTS_ATOM_PUT_OPS_STAT +#endif +#ifdef ERTS_ATOM_PUT_OPS_STAT +static erts_smp_atomic_t atom_put_ops; +#endif + +/* Functions for allocating space for the ext of atoms. We do not + * use malloc for each atom to prevent excessive memory fragmentation + */ + +typedef struct _atom_text { + struct _atom_text* next; + unsigned char text[ATOM_TEXT_SIZE]; +} AtomText; + +static AtomText* text_list; /* List of text buffers */ +static byte *atom_text_pos; +static byte *atom_text_end; +static Uint reserved_atom_space; /* Total amount of atom text space */ +static Uint atom_space; /* Amount of atom text space used */ + +/* + * Print info about atom tables + */ +void atom_info(int to, void *to_arg) +{ + int lock = !ERTS_IS_CRASH_DUMPING; + if (lock) + atom_read_lock(); + index_info(to, to_arg, &erts_atom_table); +#ifdef ERTS_ATOM_PUT_OPS_STAT + erts_print(to, to_arg, "atom_put_ops: %ld\n", + erts_smp_atomic_read(&atom_put_ops)); +#endif + + if (lock) + atom_read_unlock(); +} + +/* + * Allocate an atom text segment. + */ +static void +more_atom_space(void) +{ + AtomText* ptr; + + ptr = (AtomText*) erts_alloc(ERTS_ALC_T_ATOM_TXT, sizeof(AtomText)); + + ptr->next = text_list; + text_list = ptr; + + atom_text_pos = ptr->text; + atom_text_end = atom_text_pos + ATOM_TEXT_SIZE; + reserved_atom_space += sizeof(AtomText); + + VERBOSE(DEBUG_SYSTEM,("Allocated %d atom space\n",ATOM_TEXT_SIZE)); +} + +/* + * Allocate string space within an atom text segment. + */ + +static byte* +atom_text_alloc(int bytes) +{ + byte *res; + + ASSERT(bytes <= MAX_ATOM_LENGTH); + if (atom_text_pos + bytes >= atom_text_end) { + more_atom_space(); + } + res = atom_text_pos; + atom_text_pos += bytes; + atom_space += bytes; + return res; +} + +/* + * Calculate atom hash value (using the hash algorithm + * hashpjw from the Dragon Book). + */ + +static HashValue +atom_hash(Atom* obj) +{ + byte* p = obj->name; + int len = obj->len; + HashValue h = 0, g; + + while(len--) { + h = (h << 4) + *p++; + if ((g = h & 0xf0000000)) { + h ^= (g >> 24); + h ^= g; + } + } + return h; +} + + +static int +atom_cmp(Atom* tmpl, Atom* obj) +{ + if (tmpl->len == obj->len && + sys_memcmp(tmpl->name, obj->name, tmpl->len) == 0) + return 0; + return 1; +} + + +static Atom* +atom_alloc(Atom* tmpl) +{ + Atom* obj = (Atom*) erts_alloc(ERTS_ALC_T_ATOM, sizeof(Atom)); + + obj->name = atom_text_alloc(tmpl->len); + sys_memcpy(obj->name, tmpl->name, tmpl->len); + obj->len = tmpl->len; + obj->slot.index = -1; + + /* + * Precompute ordinal value of first 3 bytes + 7 bits. + * This is used by utils.c:cmp_atoms(). + * We cannot use the full 32 bits of the first 4 bytes, + * since we use the sign of the difference between two + * ordinal values to represent their relative order. + */ + { + unsigned char c[4]; + int i; + int j; + + j = (tmpl->len < 4) ? tmpl->len : 4; + for(i = 0; i < j; ++i) + c[i] = tmpl->name[i]; + for(; i < 4; ++i) + c[i] = '\0'; + obj->ord0 = (c[0] << 23) + (c[1] << 15) + (c[2] << 7) + (c[3] >> 1); + } + return obj; +} + +static void +atom_free(Atom* obj) +{ + erts_free(ERTS_ALC_T_ATOM, (void*) obj); +} + +Eterm +am_atom_put(const char* name, int len) +{ + Atom a; + Eterm ret; + int aix; + + /* + * Silently truncate the atom if it is too long. Overlong atoms + * could occur in situations where we have no good way to return + * an error, such as in the I/O system. (Unfortunately, many + * drivers don't check for errors.) + * + * If an error should be produced for overlong atoms (such in + * list_to_atom/1), the caller should check the length before + * calling this function. + */ + if (len > MAX_ATOM_LENGTH) { + len = MAX_ATOM_LENGTH; + } +#ifdef ERTS_ATOM_PUT_OPS_STAT + erts_smp_atomic_inc(&atom_put_ops); +#endif + a.len = len; + a.name = (byte*)name; + atom_read_lock(); + aix = index_get(&erts_atom_table, (void*) &a); + atom_read_unlock(); + if (aix >= 0) + ret = make_atom(aix); + else { + atom_write_lock(); + ret = make_atom(index_put(&erts_atom_table, (void*) &a)); + atom_write_unlock(); + } + return ret; +} + + +int atom_table_size(void) +{ + int ret; +#ifdef ERTS_SMP + int lock = !ERTS_IS_CRASH_DUMPING; + if (lock) + atom_read_lock(); +#endif + ret = erts_atom_table.entries; +#ifdef ERTS_SMP + if (lock) + atom_read_unlock(); +#endif + return ret; +} + +int atom_table_sz(void) +{ + int ret; +#ifdef ERTS_SMP + int lock = !ERTS_IS_CRASH_DUMPING; + if (lock) + atom_read_lock(); +#endif + ret = index_table_sz(&erts_atom_table); +#ifdef ERTS_SMP + if (lock) + atom_read_unlock(); +#endif + return ret; +} + +int +erts_atom_get(const char *name, int len, Eterm* ap) +{ + Atom a; + int i; + int res; + + a.len = len; + a.name = (byte *)name; + atom_read_lock(); + i = index_get(&erts_atom_table, (void*) &a); + res = i < 0 ? 0 : (*ap = make_atom(i), 1); + atom_read_unlock(); + return res; +} + +void +erts_atom_get_text_space_sizes(Uint *reserved, Uint *used) +{ +#ifdef ERTS_SMP + int lock = !ERTS_IS_CRASH_DUMPING; + if (lock) + atom_read_lock(); +#endif + if (reserved) + *reserved = reserved_atom_space; + if (used) + *used = atom_space; +#ifdef ERTS_SMP + if (lock) + atom_read_unlock(); +#endif +} + +void +init_atom_table(void) +{ + HashFunctions f; + int i; + Atom a; + +#ifdef ERTS_ATOM_PUT_OPS_STAT + erts_smp_atomic_init(&atom_put_ops, 0); +#endif + + atom_init_lock(); + f.hash = (H_FUN) atom_hash; + f.cmp = (HCMP_FUN) atom_cmp; + f.alloc = (HALLOC_FUN) atom_alloc; + f.free = (HFREE_FUN) atom_free; + + atom_text_pos = NULL; + atom_text_end = NULL; + reserved_atom_space = 0; + atom_space = 0; + text_list = NULL; + + erts_index_init(ERTS_ALC_T_ATOM_TABLE, &erts_atom_table, + "atom_tab", ATOM_SIZE, ATOM_LIMIT, f); + more_atom_space(); + + /* Ordinary atoms */ + for (i = 0; erl_atom_names[i] != 0; i++) { + int ix; + a.len = strlen(erl_atom_names[i]); + a.name = (byte*)erl_atom_names[i]; + a.slot.index = i; + ix = index_put(&erts_atom_table, (void*) &a); + atom_text_pos -= a.len; + atom_space -= a.len; + atom_tab(ix)->name = (byte*)erl_atom_names[i]; + } +} + +void +dump_atoms(int to, void *to_arg) +{ + int i = erts_atom_table.entries; + + /* + * Print out the atom table starting from the end. + */ + while (--i >= 0) { + if (erts_index_lookup(&erts_atom_table, i)) { + erts_print(to, to_arg, "%T\n", make_atom(i)); + } + } +} diff --git a/erts/emulator/beam/atom.h b/erts/emulator/beam/atom.h new file mode 100644 index 0000000000..e7e0dc440d --- /dev/null +++ b/erts/emulator/beam/atom.h @@ -0,0 +1,104 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifndef __ATOM_H__ +#define __ATOM_H__ + +#ifndef __INDEX_H__ +#include "index.h" +#endif + +#include "erl_atom_table.h" + +#define MAX_ATOM_LENGTH 255 +#define ATOM_LIMIT (1024*1024) + +/* + * Atom entry. + */ +typedef struct atom { + IndexSlot slot; /* MUST BE LOCATED AT TOP OF STRUCT!!! */ + int len; /* length of atom name */ + int ord0; /* ordinal value of first 3 bytes + 7 bits */ + byte* name; /* name of atom */ +} Atom; + +extern IndexTable erts_atom_table; + +ERTS_GLB_INLINE Atom* atom_tab(Uint i); +ERTS_GLB_INLINE int erts_is_atom_bytes(byte *text, size_t len, Eterm term); +ERTS_GLB_INLINE int erts_is_atom_str(char *str, Eterm term); + +#if ERTS_GLB_INLINE_INCL_FUNC_DEF +ERTS_GLB_INLINE Atom* +atom_tab(Uint i) +{ + return (Atom *) erts_index_lookup(&erts_atom_table, i); +} + +ERTS_GLB_INLINE int erts_is_atom_bytes(byte *text, size_t len, Eterm term) +{ + Atom *a; + if (!is_atom(term)) + return 0; + a = atom_tab(atom_val(term)); + return (len == (size_t) a->len + && sys_memcmp((void *) a->name, (void *) text, len) == 0); +} + +ERTS_GLB_INLINE int erts_is_atom_str(char *str, Eterm term) +{ + Atom *a; + int i, len; + char *aname; + if (!is_atom(term)) + return 0; + a = atom_tab(atom_val(term)); + len = a->len; + aname = (char *) a->name; + for (i = 0; i < len; i++) + if (aname[i] != str[i] || str[i] == '\0') + return 0; + return str[len] == '\0'; +} + +#endif + +/* + * Note, ERTS_IS_ATOM_STR() expects the first argument to be a + * string literal. + */ +#define ERTS_IS_ATOM_STR(LSTR, TERM) \ + (erts_is_atom_bytes((byte *) LSTR, sizeof(LSTR) - 1, (TERM))) +#define ERTS_DECL_AM(S) Eterm AM_ ## S = am_atom_put(#S, sizeof(#S) - 1) +#define ERTS_INIT_AM(S) AM_ ## S = am_atom_put(#S, sizeof(#S) - 1) + +int atom_table_size(void); /* number of elements */ +int atom_table_sz(void); /* table size in bytes, excluding stored objects */ + +Eterm am_atom_put(const char*, int); /* most callers pass plain char*'s */ +int atom_erase(byte*, int); +int atom_static_put(byte*, int); +void init_atom_table(void); +void atom_info(int, void *); +void dump_atoms(int, void *); +int erts_atom_get(const char* name, int len, Eterm* ap); +void erts_atom_get_text_space_sizes(Uint *reserved, Uint *used); +#endif + diff --git a/erts/emulator/beam/atom.names b/erts/emulator/beam/atom.names new file mode 100644 index 0000000000..04eac2d807 --- /dev/null +++ b/erts/emulator/beam/atom.names @@ -0,0 +1,540 @@ +# +# %CopyrightBegin% +# +# Copyright Ericsson AB 1996-2009. All Rights Reserved. +# +# The contents of this file are subject to the Erlang Public License, +# Version 1.1, (the "License"); you may not use this file except in +# compliance with the License. You should have received a copy of the +# Erlang Public License along with this software. If not, it can be +# retrieved online at http://www.erlang.org/. +# +# Software distributed under the License is distributed on an "AS IS" +# basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +# the License for the specific language governing rights and limitations +# under the License. +# +# %CopyrightEnd% +# + +# +# File format: +# +# Lines starting with '#' are ignored. +# +# ::= "atom" + +# ::= | +# "'" "'" | +# "=" "'" "'" +# ::= [a-z][a-zA-Z_0-9]* +# ::= [A-Z][a-zA-Z_0-9]* +# ::= .* +# +# (although some characters may poison the Perl parser) +# + +# +# Frequently used atoms. +# +atom false true +atom Underscore='_' +atom Noname='nonode@nohost' +atom EOT='$end_of_table' +atom Cookie='' + +# +# Used in the Beam emulator loop. (Smaller literals usually means tighter code.) +# +atom fun infinity timeout normal call return +atom throw error exit +atom undefined + +# +# Used in beam_emu.c. +# +atom nocatch +atom undefined_function +atom undefined_lambda + + +# All other atoms. Try to keep the order alphabetic. +# +atom DOWN='DOWN' +atom UP='UP' +atom EXIT='EXIT' +atom aborted +atom abs_path +atom absoluteURI +atom active +atom all +atom all_but_first +atom allocated +atom allocated_areas +atom allocator +atom allocator_sizes +atom alloc_util_allocators +atom allow_passive_connect +atom already_loaded +atom anchored +atom and +atom andalso +atom andthen +atom any +atom anycrlf +atom apply +atom args +atom arg0 +atom arity +atom asn1 +atom asynchronous +atom atom +atom atom_used +atom attributes +atom await_proc_exit +atom awaiting_load +atom awaiting_unload +atom backtrace backtrace_depth +atom badarg badarith badarity badfile badmatch badsig badfun +atom bag +atom band +atom big +atom bif_return_trap +atom binary +atom block +atom blocked +atom bnot +atom bor +atom bxor +atom break_ignored +atom breakpoint +atom bsl +atom bsr +atom bsr_anycrlf +atom bsr_unicode +atom busy_dist_port +atom busy_port +atom call +atom call_count +atom caller +atom capture +atom case_clause +atom caseless +atom catchlevel +atom cd +atom cdr +atom characters_to_binary_int +atom characters_to_list_int +atom clear +atom close +atom closed +atom code +atom command +atom compat_rel +atom compile +atom compressed +atom connect +atom connected +atom connection_closed +atom cons +atom const +atom context_switches +atom copy +atom cpu +atom cpu_timestamp +atom cr +atom crlf +atom creation +atom current_function +atom data +atom debug_flags +atom delay_trap +atom dexit +atom depth +atom dgroup_leader +atom dictionary +atom disable_trace +atom disabled +atom display_items +atom dist +atom Div='/' +atom div +atom dlink +atom dmonitor_node +atom dmonitor_p +atom DollarDollar='$$' +atom DollarUnderscore='$_' +atom dollar_endonly +atom dotall +atom driver +atom driver_options +atom dsend +atom dunlink +atom duplicate_bag +atom dupnames +atom elib_malloc +atom emulator +atom enable_trace +atom enabled +atom endian +atom env +atom eof +atom eol +atom exception_from +atom exception_trace +atom extended +atom Eq='=:=' +atom Eqeq='==' +atom erlang +atom ERROR='ERROR' +atom error_handler +atom error_logger +atom ets +atom ETS_TRANSFER='ETS-TRANSFER' +atom event +atom exact_reductions +atom exclusive +atom exit_status +atom existing +atom exiting +atom exports +atom external +atom false +atom fcgi +atom fd +atom first +atom firstline +atom flags +atom flush +atom flush_monitor_message +atom force +atom format_cpu_topology +atom free +atom fullsweep_after +atom fullsweep_if_old_binaries +atom fun +atom function +atom functions +atom function_clause +atom garbage_collecting +atom garbage_collection +atom gc_end +atom gc_start +atom Ge='>=' +atom generational +atom get_seq_token +atom get_tcw +atom getenv +atom getting_linked +atom getting_unlinked +atom global +atom global_heaps_size +atom Gt='>' +atom grun +atom group_leader +atom heap_block_size +atom heap_size +atom heap_sizes +atom heap_type +atom heir +atom hidden +atom hide +atom high +atom hipe_architecture +atom http httph https http_response http_request http_header http_eoh http_error http_bin httph_bin +atom hybrid +atom id +atom if_clause +atom imports +atom in +atom in_exiting +atom inactive +atom incomplete +atom inconsistent +atom index +atom infinity +atom info +atom info_msg +atom initial_call +atom input +atom internal_error +atom internal_status +atom instruction_counts +atom invalid +atom is_constant +atom is_seq_trace +atom io +atom keypos +atom kill +atom killed +atom kill_ports +atom known +atom label +atom large_heap +atom last_calls +atom latin1 +atom Le='=<' +atom lf +atom line +atom line_length +atom linked_in_driver +atom links +atom list +atom little +atom loaded +atom load_cancelled +atom load_failure +atom local +atom long_gc +atom low +atom Lt='<' +atom machine +atom match +atom match_spec +atom max +atom maximum +atom max_tables max_processes +atom mbuf_size +atom memory +atom memory_types +atom message +atom message_binary +atom message_queue_len +atom messages +atom meta +atom meta_match_spec +atom min_heap_size +atom minor_version +atom Minus='-' +atom module +atom module_info +atom monitored_by +atom monitor +atom monitor_nodes +atom monitors +atom more +atom multi_scheduling +atom multiline +atom name +atom named_table +atom native_addresses +atom Neq='=/=' +atom Neqeq='/=' +atom net_kernel +atom net_kernel_terminated +atom new +atom new_index +atom new_uniq +atom newline +atom next +atom no +atom nomatch +atom none +atom no_auto_capture +atom noconnect +atom noconnection +atom nocookie +atom node +atom node_type +atom nodedown +atom nodedown_reason +atom nodeup +atom noeol +atom nofile +atom noproc +atom normal +atom nosuspend +atom no_float +atom no_integer +atom no_network +atom not +atom not_a_list +atom not_loaded +atom not_loaded_by_this_process +atom not_pending +atom not_purged +atom notalive +atom notbol +atom noteol +atom notempty +atom notify +atom notsup +atom nouse_stdio +atom objects +atom offset +atom ok +atom old_heap_block_size +atom old_heap_size +atom on_load +atom open +atom open_error +atom or +atom ordered_set +atom orelse +atom os_type +atom os_version +atom ose_bg_proc +atom ose_int_proc +atom ose_phantom +atom ose_pri_proc +atom ose_process_prio +atom ose_process_type +atom ose_ti_proc +atom out +atom out_exited +atom out_exiting +atom output +atom overlapped_io +atom owner +atom packet +atom packet_size +atom Plus='+' +atom pause +atom pending +atom pending_driver +atom pending_process +atom pending_reload +atom permanent +atom pid +atom port +atom ports +atom port_count +atom print +atom priority +atom private +atom process +atom processes +atom processes_trap +atom processes_used +atom process_count +atom process_display +atom process_limit +atom process_dump +atom procs +atom profile +atom protected +atom protection +atom public +atom purify +atom quantify +atom queue_size +atom raw +atom re +atom re_pattern +atom re_run_trap +atom ready_input +atom ready_output +atom ready_async +atom reason +atom receive +atom recent_size +atom reductions +atom refc +atom register +atom registered_name +atom reload +atom rem +atom reset +atom restart +atom return_from +atom return_to +atom return_trace +atom run_queue +atom runnable +atom runnable_ports +atom runnable_procs +atom running +atom running_ports +atom running_procs +atom runtime +atom save_calls +atom scheduler +atom scheduler_id +atom schedulers_online +atom scheme +atom sensitive +atom sequential_tracer +atom sequential_trace_token +atom serial +atom set +atom set_cpu_topology +atom set_on_first_link +atom set_on_first_spawn +atom set_on_link +atom set_on_spawn +atom set_seq_token +atom set_tcw +atom set_tcw_fake +atom separate +atom shared +atom silent +atom size +atom sl_alloc +atom spawn_executable +atom spawn_driver +atom ssl_tls +atom stack_size +atom start +atom status +atom static +atom stderr_to_stdout +atom stop +atom stream +atom sunrm +atom suspend +atom suspended +atom suspending +atom sys_misc +atom system +atom system_error +atom system_limit +atom system_version +atom system_architecture +atom SYSTEM='SYSTEM' +atom table +atom this +atom thread_pool_size +atom threads +atom timeout +atom timeout_value +atom Times='*' +atom timestamp +atom total +atom total_heap_size +atom tpkt +atom trace trace_ts traced +atom trace_control_word +atom tracer +atom trap_exit +atom try_clause +atom true +atom tuple +atom type +atom ucompile +atom undef +atom ungreedy +atom unicode +atom unregister +atom urun +atom use_stdio +atom used +atom utf8 +atom unblock +atom uniq +atom unless_suspending +atom unloaded +atom unloading +atom unloaded_only +atom unload_cancelled +atom value +atom values +atom version +atom visible +atom waiting +atom wall_clock +atom warning +atom warning_msg +atom wordsize +atom write_concurrency +atom xor +atom yes +atom yield diff --git a/erts/emulator/beam/beam_bif_load.c b/erts/emulator/beam/beam_bif_load.c new file mode 100644 index 0000000000..d3a1ed4e7d --- /dev/null +++ b/erts/emulator/beam/beam_bif_load.c @@ -0,0 +1,795 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1999-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "erl_process.h" +#include "error.h" +#include "bif.h" +#include "beam_load.h" +#include "big.h" +#include "beam_bp.h" +#include "beam_catches.h" +#include "erl_binary.h" +#include "erl_nif.h" + +static void set_default_trace_pattern(Eterm module); +static Eterm check_process_code(Process* rp, Module* modp); +static void delete_code(Process *c_p, ErtsProcLocks c_p_locks, Module* modp); +static void delete_export_references(Eterm module); +static int purge_module(int module); +static int is_native(Eterm* code); +static int any_heap_ref_ptrs(Eterm* start, Eterm* end, char* mod_start, Uint mod_size); +static int any_heap_refs(Eterm* start, Eterm* end, char* mod_start, Uint mod_size); +static void remove_from_address_table(Eterm* code); + +Eterm +load_module_2(BIF_ALIST_2) +{ + Eterm reason; + Eterm* hp; + int i; + int sz; + byte* code; + Eterm res; + byte* temp_alloc = NULL; + + if (is_not_atom(BIF_ARG_1)) { + error: + erts_free_aligned_binary_bytes(temp_alloc); + BIF_ERROR(BIF_P, BADARG); + } + if ((code = erts_get_aligned_binary_bytes(BIF_ARG_2, &temp_alloc)) == NULL) { + goto error; + } + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN); + erts_smp_block_system(0); + + erts_export_consolidate(); + + hp = HAlloc(BIF_P, 3); + sz = binary_size(BIF_ARG_2); + if ((i = erts_load_module(BIF_P, 0, + BIF_P->group_leader, &BIF_ARG_1, code, sz)) < 0) { + switch (i) { + case -1: reason = am_badfile; break; + case -2: reason = am_nofile; break; + case -3: reason = am_not_purged; break; + case -4: + reason = am_atom_put("native_code", sizeof("native_code")-1); + break; + case -5: + { + /* + * The module contains an on_load function. The loader + * has loaded the module as usual, except that the + * export entries does not point into the module, so it + * is not possible to call any code in the module. + */ + + ERTS_DECL_AM(on_load); + reason = AM_on_load; + break; + } + default: reason = am_badfile; break; + } + res = TUPLE2(hp, am_error, reason); + goto done; + } + + set_default_trace_pattern(BIF_ARG_1); + res = TUPLE2(hp, am_module, BIF_ARG_1); + + done: + erts_free_aligned_binary_bytes(temp_alloc); + erts_smp_release_system(); + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_MAIN); + + BIF_RET(res); +} + +BIF_RETTYPE purge_module_1(BIF_ALIST_1) +{ + int purge_res; + + if (is_not_atom(BIF_ARG_1)) { + BIF_ERROR(BIF_P, BADARG); + } + + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN); + erts_smp_block_system(0); + + erts_export_consolidate(); + purge_res = purge_module(atom_val(BIF_ARG_1)); + + erts_smp_release_system(); + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_MAIN); + + if (purge_res < 0) { + BIF_ERROR(BIF_P, BADARG); + } + BIF_RET(am_true); +} + +BIF_RETTYPE code_is_module_native_1(BIF_ALIST_1) +{ + Module* modp; + + if (is_not_atom(BIF_ARG_1)) { + BIF_ERROR(BIF_P, BADARG); + } + if ((modp = erts_get_module(BIF_ARG_1)) == NULL) { + return am_undefined; + } + return (is_native(modp->code) || + (modp->old_code != 0 && is_native(modp->old_code))) ? + am_true : am_false; +} + +BIF_RETTYPE code_make_stub_module_3(BIF_ALIST_3) +{ + Eterm res; + + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN); + erts_smp_block_system(0); + + erts_export_consolidate(); + res = erts_make_stub_module(BIF_P, BIF_ARG_1, BIF_ARG_2, BIF_ARG_3); + + erts_smp_release_system(); + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_MAIN); + return res; +} + +Eterm +check_process_code_2(BIF_ALIST_2) +{ + Process* rp; + Module* modp; + + if (is_not_atom(BIF_ARG_2)) { + goto error; + } + if (is_internal_pid(BIF_ARG_1)) { + Eterm res; + if (internal_pid_index(BIF_ARG_1) >= erts_max_processes) + goto error; + rp = erts_pid2proc_not_running(BIF_P, ERTS_PROC_LOCK_MAIN, + BIF_ARG_1, ERTS_PROC_LOCK_MAIN); + if (!rp) { + BIF_RET(am_false); + } + if (rp == ERTS_PROC_LOCK_BUSY) { + ERTS_BIF_YIELD2(bif_export[BIF_check_process_code_2], BIF_P, + BIF_ARG_1, BIF_ARG_2); + } + modp = erts_get_module(BIF_ARG_2); + res = check_process_code(rp, modp); +#ifdef ERTS_SMP + if (BIF_P != rp) + erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_MAIN); +#endif + BIF_RET(res); + } + else if (is_external_pid(BIF_ARG_1) + && external_pid_dist_entry(BIF_ARG_1) == erts_this_dist_entry) { + BIF_RET(am_false); + } + + error: + BIF_ERROR(BIF_P, BADARG); +} + + +BIF_RETTYPE delete_module_1(BIF_ALIST_1) +{ + int res; + + if (is_not_atom(BIF_ARG_1)) + goto badarg; + + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN); + erts_smp_block_system(0); + + { + Module *modp = erts_get_module(BIF_ARG_1); + if (!modp) { + res = am_undefined; + } + else if (modp->old_code != 0) { + erts_dsprintf_buf_t *dsbufp = erts_create_logger_dsbuf(); + erts_dsprintf(dsbufp, "Module %T must be purged before loading\n", + BIF_ARG_1); + erts_send_error_to_logger(BIF_P->group_leader, dsbufp); + res = am_badarg; + } + else { + delete_export_references(BIF_ARG_1); + delete_code(BIF_P, 0, modp); + res = am_true; + } + } + + erts_smp_release_system(); + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_MAIN); + + if (res == am_badarg) { + badarg: + BIF_ERROR(BIF_P, BADARG); + } + BIF_RET(res); +} + +BIF_RETTYPE module_loaded_1(BIF_ALIST_1) +{ + Module* modp; + + if (is_not_atom(BIF_ARG_1)) { + BIF_ERROR(BIF_P, BADARG); + } + if ((modp = erts_get_module(BIF_ARG_1)) == NULL || + modp->code == NULL || + modp->code[MI_ON_LOAD_FUNCTION_PTR] != 0) { + BIF_RET(am_false); + } + BIF_RET(am_true); +} + +BIF_RETTYPE pre_loaded_0(BIF_ALIST_0) +{ + return erts_preloaded(BIF_P); +} + +BIF_RETTYPE loaded_0(BIF_ALIST_0) +{ + Eterm previous = NIL; + Eterm* hp; + int i; + int j = 0; + + for (i = 0; i < module_code_size(); i++) { + if (module_code(i) != NULL && + ((module_code(i)->code_length != 0) || + (module_code(i)->old_code_length != 0))) { + j++; + } + } + if (j > 0) { + hp = HAlloc(BIF_P, j*2); + + for (i = 0; i < module_code_size(); i++) { + if (module_code(i) != NULL && + ((module_code(i)->code_length != 0) || + (module_code(i)->old_code_length != 0))) { + previous = CONS(hp, make_atom(module_code(i)->module), + previous); + hp += 2; + } + } + } + BIF_RET(previous); +} + +BIF_RETTYPE call_on_load_function_1(BIF_ALIST_1) +{ + Module* modp = erts_get_module(BIF_ARG_1); + Eterm on_load; + + if (!modp || modp->code == 0) { + error: + BIF_ERROR(BIF_P, BADARG); + } + if ((on_load = modp->code[MI_ON_LOAD_FUNCTION_PTR]) == 0) { + goto error; + } + BIF_TRAP_CODE_PTR_0(BIF_P, on_load); +} + +BIF_RETTYPE finish_after_on_load_2(BIF_ALIST_2) +{ + Module* modp = erts_get_module(BIF_ARG_1); + Eterm on_load; + + if (!modp || modp->code == 0) { + error: + BIF_ERROR(BIF_P, BADARG); + } + if ((on_load = modp->code[MI_ON_LOAD_FUNCTION_PTR]) == 0) { + goto error; + } + if (BIF_ARG_2 != am_false && BIF_ARG_2 != am_true) { + goto error; + } + + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN); + erts_smp_block_system(0); + + if (BIF_ARG_2 == am_true) { + int i; + + /* + * The on_load function succeded. Fix up export entries. + */ + for (i = 0; i < export_list_size(); i++) { + Export *ep = export_list(i); + if (ep != NULL && + ep->code[0] == BIF_ARG_1 && + ep->code[4] != 0) { + ep->address = (void *) ep->code[4]; + ep->code[3] = 0; + ep->code[4] = 0; + } + } + modp->code[MI_ON_LOAD_FUNCTION_PTR] = 0; + set_default_trace_pattern(BIF_ARG_1); + } else if (BIF_ARG_2 == am_false) { + Eterm* code; + Eterm* end; + + /* + * The on_load function failed. Remove the loaded code. + * This is an combination of delete and purge. We purge + * the current code; the old code is not touched. + */ + erts_total_code_size -= modp->code_length; + code = modp->code; + end = (Eterm *)((char *)code + modp->code_length); + erts_cleanup_funs_on_purge(code, end); + beam_catches_delmod(modp->catches, code, modp->code_length); + erts_free(ERTS_ALC_T_CODE, (void *) code); + modp->code = NULL; + modp->code_length = 0; + modp->catches = BEAM_CATCHES_NIL; + remove_from_address_table(code); + } + erts_smp_release_system(); + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_MAIN); + BIF_RET(am_true); +} + + +static void +set_default_trace_pattern(Eterm module) +{ + int trace_pattern_is_on; + Binary *match_spec; + Binary *meta_match_spec; + struct trace_pattern_flags trace_pattern_flags; + Eterm meta_tracer_pid; + + erts_get_default_trace_pattern(&trace_pattern_is_on, + &match_spec, + &meta_match_spec, + &trace_pattern_flags, + &meta_tracer_pid); + if (trace_pattern_is_on) { + Eterm mfa[1]; + mfa[0] = module; + (void) erts_set_trace_pattern(mfa, 1, + match_spec, + meta_match_spec, + 1, trace_pattern_flags, + meta_tracer_pid); + } +} + +static Eterm +check_process_code(Process* rp, Module* modp) +{ + Eterm* start; + char* mod_start; + Uint mod_size; + Eterm* end; + Eterm* sp; +#ifndef HYBRID /* FIND ME! */ + ErlFunThing* funp; + int done_gc = 0; +#endif + +#define INSIDE(a) (start <= (a) && (a) < end) + if (modp == NULL) { /* Doesn't exist. */ + return am_false; + } else if (modp->old_code == NULL) { /* No old code. */ + return am_false; + } + + /* + * Pick up limits for the module. + */ + start = modp->old_code; + end = (Eterm *)((char *)start + modp->old_code_length); + mod_start = (char *) start; + mod_size = modp->old_code_length; + + /* + * Check if current instruction or continuation pointer points into module. + */ + if (INSIDE(rp->i) || INSIDE(rp->cp)) { + return am_true; + } + + /* + * Check all continuation pointers stored on the stack. + */ + for (sp = rp->stop; sp < STACK_START(rp); sp++) { + if (is_CP(*sp) && INSIDE(cp_val(*sp))) { + return am_true; + } + } + + /* + * Check all continuation pointers stored in stackdump + * and clear exception stackdump if there is a pointer + * to the module. + */ + if (rp->ftrace != NIL) { + struct StackTrace *s; + ASSERT(is_list(rp->ftrace)); + s = (struct StackTrace *) big_val(CDR(list_val(rp->ftrace))); + if ((s->pc && INSIDE(s->pc)) || + (s->current && INSIDE(s->current))) { + rp->freason = EXC_NULL; + rp->fvalue = NIL; + rp->ftrace = NIL; + } else { + int i; + for (i = 0; i < s->depth; i++) { + if (INSIDE(s->trace[i])) { + rp->freason = EXC_NULL; + rp->fvalue = NIL; + rp->ftrace = NIL; + break; + } + } + } + } + + /* + * See if there are funs that refer to the old version of the module. + */ + +#ifndef HYBRID /* FIND ME! */ + rescan: + for (funp = MSO(rp).funs; funp; funp = funp->next) { + Eterm* fun_code; + + fun_code = funp->fe->address; + + if (INSIDE((Eterm *) funp->fe->address)) { + if (done_gc) { + return am_true; + } else { + /* + * Try to get rid of this fun by garbage collecting. + * Clear both fvalue and ftrace to make sure they + * don't hold any funs. + */ + rp->freason = EXC_NULL; + rp->fvalue = NIL; + rp->ftrace = NIL; + done_gc = 1; + FLAGS(rp) |= F_NEED_FULLSWEEP; + (void) erts_garbage_collect(rp, 0, rp->arg_reg, rp->arity); + goto rescan; + } + } + } +#endif + + /* + * See if there are constants inside the module referenced by the process. + */ + done_gc = 0; + for (;;) { + ErlMessage* mp; + + if (any_heap_ref_ptrs(&rp->fvalue, &rp->fvalue+1, mod_start, mod_size)) { + rp->freason = EXC_NULL; + rp->fvalue = NIL; + rp->ftrace = NIL; + } + if (any_heap_ref_ptrs(rp->stop, rp->hend, mod_start, mod_size)) { + goto need_gc; + } + if (any_heap_refs(rp->heap, rp->htop, mod_start, mod_size)) { + goto need_gc; + } + + if (any_heap_refs(rp->old_heap, rp->old_htop, mod_start, mod_size)) { + goto need_gc; + } + + if (rp->dictionary != NULL) { + Eterm* start = rp->dictionary->data; + Eterm* end = start + rp->dictionary->used; + + if (any_heap_ref_ptrs(start, end, mod_start, mod_size)) { + goto need_gc; + } + } + + for (mp = rp->msg.first; mp != NULL; mp = mp->next) { + if (any_heap_ref_ptrs(mp->m, mp->m+2, mod_start, mod_size)) { + goto need_gc; + } + } + break; + + need_gc: + if (done_gc) { + return am_true; + } else { + Eterm* literals; + Uint lit_size; + + /* + * Try to get rid of constants by by garbage collecting. + * Clear both fvalue and ftrace. + */ + rp->freason = EXC_NULL; + rp->fvalue = NIL; + rp->ftrace = NIL; + done_gc = 1; + FLAGS(rp) |= F_NEED_FULLSWEEP; + (void) erts_garbage_collect(rp, 0, rp->arg_reg, rp->arity); + literals = (Eterm *) modp->old_code[MI_LITERALS_START]; + lit_size = (Eterm *) modp->old_code[MI_LITERALS_END] - literals; + erts_garbage_collect_literals(rp, literals, lit_size); + } + } + return am_false; +#undef INSIDE +} + +#define in_area(ptr,start,nbytes) \ + ((unsigned long)((char*)(ptr) - (char*)(start)) < (nbytes)) + +static int +any_heap_ref_ptrs(Eterm* start, Eterm* end, char* mod_start, Uint mod_size) +{ + Eterm* p; + Eterm val; + + for (p = start; p < end; p++) { + val = *p; + switch (primary_tag(val)) { + case TAG_PRIMARY_BOXED: + case TAG_PRIMARY_LIST: + if (in_area(val, mod_start, mod_size)) { + return 1; + } + break; + } + } + return 0; +} + +static int +any_heap_refs(Eterm* start, Eterm* end, char* mod_start, Uint mod_size) +{ + Eterm* p; + Eterm val; + + for (p = start; p < end; p++) { + val = *p; + switch (primary_tag(val)) { + case TAG_PRIMARY_BOXED: + case TAG_PRIMARY_LIST: + if (in_area(val, mod_start, mod_size)) { + return 1; + } + break; + case TAG_PRIMARY_HEADER: + if (!header_is_transparent(val)) { + Eterm* new_p = p + thing_arityval(val); + ASSERT(start <= new_p && new_p < end); + p = new_p; + } + } + } + return 0; +} + +#undef in_area + + +static int +purge_module(int module) +{ + Eterm* code; + Eterm* end; + Module* modp; + + /* + * Correct module? + */ + + if ((modp = erts_get_module(make_atom(module))) == NULL) { + return -2; + } + + /* + * Any code to purge? + */ + if (modp->old_code == 0) { + if (display_loads) { + erts_printf("No code to purge for %T\n", make_atom(module)); + } + return -1; + } + + /* + * Unload any NIF library + */ + if (modp->old_nif.handle != NULL) { + if (modp->old_nif.entry->unload != NULL) { + ErlNifEnv env; + env.nif_data = modp->old_nif.data; + env.proc = NULL; /* BUGBUG: unlink can not access calling process */ + env.hp = NULL; + env.hp_end = NULL; + env.heap_frag_sz = 0; + env.fpe_was_unmasked = erts_block_fpe(); + modp->old_nif.entry->unload(NULL, modp->old_nif.data); + erts_unblock_fpe(env.fpe_was_unmasked); + } + erts_sys_ddll_close(modp->old_nif.handle); + modp->old_nif.handle = NULL; + modp->old_nif.entry = NULL; + } + + /* + * Remove the old code. + */ + ASSERT(erts_total_code_size >= modp->old_code_length); + erts_total_code_size -= modp->old_code_length; + code = modp->old_code; + end = (Eterm *)((char *)code + modp->old_code_length); + erts_cleanup_funs_on_purge(code, end); + beam_catches_delmod(modp->old_catches, code, modp->old_code_length); + erts_free(ERTS_ALC_T_CODE, (void *) code); + modp->old_code = NULL; + modp->old_code_length = 0; + modp->old_catches = BEAM_CATCHES_NIL; + remove_from_address_table(code); + return 0; +} + +static void +remove_from_address_table(Eterm* code) +{ + int i; + + for (i = 0; i < num_loaded_modules; i++) { + if (modules[i].start == code) { + num_loaded_modules--; + while (i < num_loaded_modules) { + modules[i] = modules[i+1]; + i++; + } + mid_module = &modules[num_loaded_modules/2]; + return; + } + } + ASSERT(0); /* Not found? */ +} + + +/* + * Move code from current to old. + */ + +static void +delete_code(Process *c_p, ErtsProcLocks c_p_locks, Module* modp) +{ +#ifdef ERTS_ENABLE_LOCK_CHECK +#ifdef ERTS_SMP + if (c_p && c_p_locks) + erts_proc_lc_chk_only_proc_main(c_p); + else +#endif + erts_lc_check_exact(NULL, 0); +#endif + + /* + * Clear breakpoints if any + */ + if (modp->code != NULL && modp->code[MI_NUM_BREAKPOINTS] > 0) { + if (c_p && c_p_locks) + erts_smp_proc_unlock(c_p, ERTS_PROC_LOCK_MAIN); + erts_smp_block_system(0); + erts_clear_module_break(modp); + modp->code[MI_NUM_BREAKPOINTS] = 0; + erts_smp_release_system(); + if (c_p && c_p_locks) + erts_smp_proc_lock(c_p, ERTS_PROC_LOCK_MAIN); + } + modp->old_code = modp->code; + modp->old_code_length = modp->code_length; + modp->old_catches = modp->catches; + modp->old_nif = modp->nif; + modp->code = NULL; + modp->code_length = 0; + modp->catches = BEAM_CATCHES_NIL; + modp->nif.handle = NULL; + modp->nif.entry = NULL; +} + + +/* null all references on the export table for the module called with the + atom index below */ + +static void +delete_export_references(Eterm module) +{ + int i; + + ASSERT(is_atom(module)); + + for (i = 0; i < export_list_size(); i++) { + Export *ep = export_list(i); + if (ep != NULL && (ep->code[0] == module)) { + if (ep->address == ep->code+3 && + (ep->code[3] == (Eterm) em_apply_bif)) { + continue; + } + ep->address = ep->code+3; + ep->code[3] = (Uint) em_call_error_handler; + ep->code[4] = 0; + MatchSetUnref(ep->match_prog_set); + ep->match_prog_set = NULL; + } + } +} + + +int +beam_make_current_old(Process *c_p, ErtsProcLocks c_p_locks, Eterm module) +{ + Module* modp = erts_put_module(module); + + /* + * Check if the previous code has been already deleted; + * if not, delete old code; error if old code already exists. + */ + + if (modp->code != NULL && modp->old_code != NULL) { + return -3; + } else if (modp->old_code == NULL) { /* Make the current version old. */ + if (display_loads) { + erts_printf("saving old code\n"); + } + delete_code(c_p, c_p_locks, modp); + delete_export_references(module); + } + return 0; +} + +static int +is_native(Eterm* code) +{ + return ((Eterm *)code[MI_FUNCTIONS])[1] != 0; +} + + diff --git a/erts/emulator/beam/beam_bp.c b/erts/emulator/beam/beam_bp.c new file mode 100644 index 0000000000..1abf1dc10c --- /dev/null +++ b/erts/emulator/beam/beam_bp.c @@ -0,0 +1,785 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2000-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "erl_process.h" +#include "beam_load.h" +#include "bif.h" +#include "error.h" +#include "erl_binary.h" +#include "beam_bp.h" + +/* ************************************************************************* +** Macros +*/ + +/* +** Memory allocation macros +*/ +/* Breakpoint data */ +#define Alloc(SZ) erts_alloc(ERTS_ALC_T_BPD, (SZ)) +#define ReAlloc(P, SIZ) erts_realloc(ERTS_ALC_T_BPD, (P), (SZ)) +#define Free(P) erts_free(ERTS_ALC_T_BPD, (P)) + +/* +** Doubly linked ring macros +*/ + +#define BpInit(a,i) \ +do { \ + (a)->orig_instr = (i); \ + (a)->next = (a); \ + (a)->prev = (a); \ +} while (0) + +#define BpSpliceNext(a,b) \ +do { \ + register BpData *c = (a), *d = (b), *e; \ + e = c->next->prev; \ + c->next->prev = d->next->prev; \ + d->next->prev = e; \ + e = c->next; \ + c->next = d->next; \ + d->next = e; \ +} while (0) + +#define BpSplicePrev(a,b) \ +do { \ + register BpData *c = (a), *d = (b), *e; \ + e = c->prev->next; \ + c->prev->next = d->prev->next; \ + d->prev->next = e; \ + e = c->prev; \ + c->prev = d->prev; \ + d->prev = e; \ +} while (0) + +#ifdef DEBUG +# define BpSingleton(a) ((a)->next == (a) && (a)->prev == (a)) +#else +# define BpSingleton(a) ((a)->next == (a)) +#endif + +#define BpInitAndSpliceNext(a,i,b) \ +do { \ + (a)->orig_instr = (i); \ + (a)->prev = (b); \ + (b)->next->prev = (a); \ + (a)->next = (b)->next; \ + (b)->next = (a); \ +} while (0) + +#define BpInitAndSplicePrev(a,i,b) \ +do { \ + (a)->orig_instr = (i); \ + (a)->next = (b); \ + (b)->prev->next = (a); \ + (a)->prev = (b)->prev; \ + (b)->prev = (a); \ +} while (0) + +/* ************************************************************************* +** Local prototypes +*/ + +/* +** Helpers +*/ + +static int set_break(Eterm mfa[3], int specified, + Binary *match_spec, Uint break_op, + enum erts_break_op count_op, Eterm tracer_pid); +static int set_module_break(Module *modp, Eterm mfa[3], int specified, + Binary *match_spec, Uint break_op, + enum erts_break_op count_op, Eterm tracer_pid); +static int set_function_break(Module *modp, Uint *pc, + Binary *match_spec, Uint break_op, + enum erts_break_op count_op, Eterm tracer_pid); + +static int clear_break(Eterm mfa[3], int specified, + Uint break_op); +static int clear_module_break(Module *modp, Eterm mfa[3], int specified, + Uint break_op); +static int clear_function_break(Module *modp, Uint *pc, + Uint break_op); + +static BpData *is_break(Uint *pc, Uint break_op); + + + +/* ************************************************************************* +** External interfaces +*/ + +erts_smp_spinlock_t erts_bp_lock; + +void +erts_bp_init(void) { + erts_smp_spinlock_init(&erts_bp_lock, "breakpoints"); +} + +int +erts_set_trace_break(Eterm mfa[3], int specified, Binary *match_spec, + Eterm tracer_pid) { + ERTS_SMP_LC_ASSERT(erts_smp_is_system_blocked(0)); + return set_break(mfa, specified, match_spec, + (Uint) BeamOp(op_i_trace_breakpoint), 0, tracer_pid); +} + +int +erts_set_mtrace_break(Eterm mfa[3], int specified, Binary *match_spec, + Eterm tracer_pid) { + ERTS_SMP_LC_ASSERT(erts_smp_is_system_blocked(0)); + return set_break(mfa, specified, match_spec, + (Uint) BeamOp(op_i_mtrace_breakpoint), 0, tracer_pid); +} + +void +erts_set_mtrace_bif(Uint *pc, Binary *match_spec, Eterm tracer_pid) { + BpDataTrace *bdt; + ERTS_SMP_LC_ASSERT(erts_smp_is_system_blocked(0)); + + bdt = (BpDataTrace *) pc[-4]; + if (bdt) { + MatchSetUnref(bdt->match_spec); + MatchSetRef(match_spec); + bdt->match_spec = match_spec; + bdt->tracer_pid = tracer_pid; + } else { + bdt = Alloc(sizeof(BpDataTrace)); + BpInit((BpData *) bdt, 0); + MatchSetRef(match_spec); + bdt->match_spec = match_spec; + bdt->tracer_pid = tracer_pid; + pc[-4] = (Uint) bdt; + } +} + +int +erts_set_debug_break(Eterm mfa[3], int specified) { + ERTS_SMP_LC_ASSERT(erts_smp_is_system_blocked(0)); + return set_break(mfa, specified, NULL, + (Uint) BeamOp(op_i_debug_breakpoint), 0, NIL); +} + +int +erts_set_count_break(Eterm mfa[3], int specified, enum erts_break_op count_op) { + ERTS_SMP_LC_ASSERT(erts_smp_is_system_blocked(0)); + return set_break(mfa, specified, NULL, + (Uint) BeamOp(op_i_count_breakpoint), count_op, NIL); +} + + + +int +erts_clear_trace_break(Eterm mfa[3], int specified) { + ERTS_SMP_LC_ASSERT(erts_smp_is_system_blocked(0)); + return clear_break(mfa, specified, + (Uint) BeamOp(op_i_trace_breakpoint)); +} + +int +erts_clear_mtrace_break(Eterm mfa[3], int specified) { + ERTS_SMP_LC_ASSERT(erts_smp_is_system_blocked(0)); + return clear_break(mfa, specified, + (Uint) BeamOp(op_i_mtrace_breakpoint)); +} + +void +erts_clear_mtrace_bif(Uint *pc) { + BpDataTrace *bdt; + ERTS_SMP_LC_ASSERT(erts_smp_is_system_blocked(0)); + + bdt = (BpDataTrace *) pc[-4]; + if (bdt) { + if (bdt->match_spec) { + MatchSetUnref(bdt->match_spec); + } + Free(bdt); + } + pc[-4] = (Uint) NULL; +} + +int +erts_clear_debug_break(Eterm mfa[3], int specified) { + ERTS_SMP_LC_ASSERT(erts_smp_is_system_blocked(0)); + return clear_break(mfa, specified, + (Uint) BeamOp(op_i_debug_breakpoint)); +} + +int +erts_clear_count_break(Eterm mfa[3], int specified) { + ERTS_SMP_LC_ASSERT(erts_smp_is_system_blocked(0)); + return clear_break(mfa, specified, + (Uint) BeamOp(op_i_count_breakpoint)); +} + +int +erts_clear_break(Eterm mfa[3], int specified) { + ERTS_SMP_LC_ASSERT(erts_smp_is_system_blocked(0)); + return clear_break(mfa, specified, 0); +} + +int +erts_clear_module_break(Module *modp) { + ERTS_SMP_LC_ASSERT(erts_smp_is_system_blocked(0)); + ASSERT(modp); + return clear_module_break(modp, NULL, 0, 0); +} + +int +erts_clear_function_break(Module *modp, Uint *pc) { + ERTS_SMP_LC_ASSERT(erts_smp_is_system_blocked(0)); + ASSERT(modp); + return clear_function_break(modp, pc, 0); +} + + + +/* + * SMP NOTE: Process p may have become exiting on return! + */ +Uint +erts_trace_break(Process *p, Uint *pc, Eterm *args, + Uint32 *ret_flags, Eterm *tracer_pid) { + Eterm tpid1, tpid2; + BpDataTrace *bdt = (BpDataTrace *) pc[-4]; + + ASSERT(pc[-5] == (Uint) BeamOp(op_i_func_info_IaaI)); + ASSERT(bdt); + bdt = (BpDataTrace *) bdt->next; + ASSERT(bdt); + ASSERT(ret_flags); + ASSERT(tracer_pid); + + ErtsSmpBPLock(bdt); + tpid1 = tpid2 = bdt->tracer_pid; + ErtsSmpBPUnlock(bdt); + + *ret_flags = erts_call_trace(p, pc-3/*mfa*/, bdt->match_spec, args, + 1, &tpid2); + *tracer_pid = tpid2; + if (tpid1 != tpid2) { + ErtsSmpBPLock(bdt); + bdt->tracer_pid = tpid2; + ErtsSmpBPUnlock(bdt); + } + pc[-4] = (Uint) bdt; + return bdt->orig_instr; +} + + + +/* + * SMP NOTE: Process p may have become exiting on return! + */ +Uint32 +erts_bif_mtrace(Process *p, Uint *pc, Eterm *args, int local, + Eterm *tracer_pid) { + BpDataTrace *bdt = (BpDataTrace *) pc[-4]; + + ASSERT(tracer_pid); + if (bdt) { + Eterm tpid1, tpid2; + Uint32 flags; + + ErtsSmpBPLock(bdt); + tpid1 = tpid2 = bdt->tracer_pid; + ErtsSmpBPUnlock(bdt); + + flags = erts_call_trace(p, pc-3/*mfa*/, bdt->match_spec, args, + local, &tpid2); + *tracer_pid = tpid2; + if (tpid1 != tpid2) { + ErtsSmpBPLock(bdt); + bdt->tracer_pid = tpid2; + ErtsSmpBPUnlock(bdt); + } + return flags; + } + *tracer_pid = NIL; + return 0; +} + + + +int +erts_is_trace_break(Uint *pc, Binary **match_spec_ret, Eterm *tracer_pid_ret) { + BpDataTrace *bdt = + (BpDataTrace *) is_break(pc, (Uint) BeamOp(op_i_trace_breakpoint)); + + if (bdt) { + if (match_spec_ret) { + *match_spec_ret = bdt->match_spec; + } + if (tracer_pid_ret) { + ErtsSmpBPLock(bdt); + *tracer_pid_ret = bdt->tracer_pid; + ErtsSmpBPUnlock(bdt); + } + return !0; + } + return 0; +} + +int +erts_is_mtrace_break(Uint *pc, Binary **match_spec_ret, Eterm *tracer_pid_ret) { + BpDataTrace *bdt = + (BpDataTrace *) is_break(pc, (Uint) BeamOp(op_i_mtrace_breakpoint)); + + if (bdt) { + if (match_spec_ret) { + *match_spec_ret = bdt->match_spec; + } + if (tracer_pid_ret) { + ErtsSmpBPLock(bdt); + *tracer_pid_ret = bdt->tracer_pid; + ErtsSmpBPUnlock(bdt); + } + return !0; + } + return 0; +} + +int +erts_is_mtrace_bif(Uint *pc, Binary **match_spec_ret, Eterm *tracer_pid_ret) { + BpDataTrace *bdt = (BpDataTrace *) pc[-4]; + + if (bdt) { + if (match_spec_ret) { + *match_spec_ret = bdt->match_spec; + } + if (tracer_pid_ret) { + ErtsSmpBPLock(bdt); + *tracer_pid_ret = bdt->tracer_pid; + ErtsSmpBPUnlock(bdt); + } + return !0; + } + return 0; +} + +int +erts_is_native_break(Uint *pc) { +#ifdef HIPE + ASSERT(pc[-5] == (Uint) BeamOp(op_i_func_info_IaaI)); + return pc[0] == (Uint) BeamOp(op_hipe_trap_call) + || pc[0] == (Uint) BeamOp(op_hipe_trap_call_closure); +#else + return 0; +#endif +} + +int +erts_is_count_break(Uint *pc, Sint *count_ret) { + BpDataCount *bdc = + (BpDataCount *) is_break(pc, (Uint) BeamOp(op_i_count_breakpoint)); + + if (bdc) { + if (count_ret) { + ErtsSmpBPLock(bdc); + *count_ret = bdc->count; + ErtsSmpBPUnlock(bdc); + } + return !0; + } + return 0; +} + +Uint * +erts_find_local_func(Eterm mfa[3]) { + Module *modp; + Uint** code_base; + Uint* code_ptr; + Uint i,n; + + if ((modp = erts_get_module(mfa[0])) == NULL) + return NULL; + if ((code_base = (Uint **) modp->code) == NULL) + return NULL; + n = (Uint) code_base[MI_NUM_FUNCTIONS]; + for (i = 0; i < n; ++i) { + code_ptr = code_base[MI_FUNCTIONS+i]; + ASSERT(((Uint) BeamOp(op_i_func_info_IaaI)) == code_ptr[0]); + ASSERT(mfa[0] == ((Eterm) code_ptr[2])); + if (mfa[1] == ((Eterm) code_ptr[3]) && + ((Uint) mfa[2]) == code_ptr[4]) { + return code_ptr + 5; + } + } + return NULL; +} + + + +/* ************************************************************************* +** Local helpers +*/ + + +static int set_break(Eterm mfa[3], int specified, + Binary *match_spec, Eterm break_op, + enum erts_break_op count_op, Eterm tracer_pid) +{ + Module *modp; + int num_processed = 0; + if (!specified) { + /* Find and process all modules in the system... */ + int current; + int last = module_code_size(); + for (current = 0; current < last; current++) { + modp = module_code(current); + ASSERT(modp != NULL); + num_processed += + set_module_break(modp, mfa, specified, + match_spec, break_op, count_op, + tracer_pid); + } + } else { + /* Process a single module */ + if ((modp = erts_get_module(mfa[0])) != NULL) { + num_processed += + set_module_break(modp, mfa, specified, + match_spec, break_op, count_op, + tracer_pid); + } + } + return num_processed; +} + +static int set_module_break(Module *modp, Eterm mfa[3], int specified, + Binary *match_spec, Uint break_op, + enum erts_break_op count_op, Eterm tracer_pid) { + Uint** code_base; + Uint* code_ptr; + int num_processed = 0; + Uint i,n; + + ASSERT(break_op); + ASSERT(modp); + code_base = (Uint **) modp->code; + if (code_base == NULL) { + return 0; + } + n = (Uint) code_base[MI_NUM_FUNCTIONS]; + for (i = 0; i < n; ++i) { + code_ptr = code_base[MI_FUNCTIONS+i]; + ASSERT(code_ptr[0] == (Uint) BeamOp(op_i_func_info_IaaI)); + if ((specified < 2 || mfa[1] == ((Eterm) code_ptr[3])) && + (specified < 3 || ((int) mfa[2]) == ((int) code_ptr[4]))) { + Uint *pc = code_ptr+5; + + num_processed += + set_function_break(modp, pc, match_spec, + break_op, count_op, tracer_pid); + } + } + return num_processed; +} + +static int set_function_break(Module *modp, Uint *pc, + Binary *match_spec, Uint break_op, + enum erts_break_op count_op, Eterm tracer_pid) { + BpData *bd, **r; + size_t size; + Uint **code_base = (Uint **)modp->code; + + ASSERT(code_base); + ASSERT(code_base <= (Uint **)pc); + ASSERT((Uint **)pc < code_base + (modp->code_length/sizeof(Uint *))); + /* + * Currently no trace support for native code. + */ + if (erts_is_native_break(pc)) { + return 0; + } + /* Do not allow two breakpoints of the same kind */ + if ( (bd = is_break(pc, break_op))) { + if (break_op == (Uint) BeamOp(op_i_trace_breakpoint) + || break_op == (Uint) BeamOp(op_i_mtrace_breakpoint)) { + BpDataTrace *bdt = (BpDataTrace *) bd; + Binary *old_match_spec; + + /* Update match spec and tracer */ + MatchSetRef(match_spec); + ErtsSmpBPLock(bdt); + old_match_spec = bdt->match_spec; + bdt->match_spec = match_spec; + bdt->tracer_pid = tracer_pid; + ErtsSmpBPUnlock(bdt); + MatchSetUnref(old_match_spec); + } else { + ASSERT(! match_spec); + ASSERT(is_nil(tracer_pid)); + if (break_op == (Uint) BeamOp(op_i_count_breakpoint)) { + BpDataCount *bdc = (BpDataCount *) bd; + + ErtsSmpBPLock(bdc); + if (count_op == erts_break_stop) { + if (bdc->count >= 0) { + bdc->count = -bdc->count-1; /* Stop call counter */ + } + } else { + bdc->count = 0; /* Reset call counter */ + } + ErtsSmpBPUnlock(bdc); + } else { + ASSERT (! count_op); + } + } + return 1; + } + if (break_op == (Uint) BeamOp(op_i_trace_breakpoint) || + break_op == (Uint) BeamOp(op_i_mtrace_breakpoint)) { + size = sizeof(BpDataTrace); + } else { + ASSERT(! match_spec); + ASSERT(is_nil(tracer_pid)); + if (break_op == (Uint) BeamOp(op_i_count_breakpoint)) { + if (count_op == erts_break_reset + || count_op == erts_break_stop) { + /* Do not insert a new breakpoint */ + return 1; + } + size = sizeof(BpDataCount); + } else { + ASSERT(! count_op); + ASSERT(break_op == (Uint) BeamOp(op_i_debug_breakpoint)); + size = sizeof(BpDataDebug); + } + } + r = (BpData **) (pc-4); + if (! *r) { + ASSERT(*pc != (Uint) BeamOp(op_i_trace_breakpoint)); + ASSERT(*pc != (Uint) BeamOp(op_i_mtrace_breakpoint)); + ASSERT(*pc != (Uint) BeamOp(op_i_debug_breakpoint)); + ASSERT(*pc != (Uint) BeamOp(op_i_count_breakpoint)); + /* First breakpoint; create singleton ring */ + bd = Alloc(size); + BpInit(bd, *pc); + *pc = break_op; + *r = bd; + } else { + ASSERT(*pc == (Uint) BeamOp(op_i_trace_breakpoint) || + *pc == (Uint) BeamOp(op_i_mtrace_breakpoint) || + *pc == (Uint) BeamOp(op_i_debug_breakpoint) || + *pc == (Uint) BeamOp(op_i_count_breakpoint)); + if (*pc == (Uint) BeamOp(op_i_debug_breakpoint)) { + /* Debug bp must be last, so if it is also first; + * it must be singleton. */ + ASSERT(BpSingleton(*r)); + /* Insert new bp first in the ring, i.e second to last. */ + bd = Alloc(size); + BpInitAndSpliceNext(bd, *pc, *r); + *pc = break_op; + } else if ((*r)->prev->orig_instr + == (Uint) BeamOp(op_i_debug_breakpoint)) { + /* Debug bp last in the ring; insert new second to last. */ + bd = Alloc(size); + BpInitAndSplicePrev(bd, (*r)->prev->orig_instr, *r); + (*r)->prev->orig_instr = break_op; + } else { + /* Just insert last in the ring */ + bd = Alloc(size); + BpInitAndSpliceNext(bd, (*r)->orig_instr, *r); + (*r)->orig_instr = break_op; + *r = bd; + } + } + /* Init the bp type specific data */ + if (break_op == (Uint) BeamOp(op_i_trace_breakpoint) || + break_op == (Uint) BeamOp(op_i_mtrace_breakpoint)) { + + BpDataTrace *bdt = (BpDataTrace *) bd; + + MatchSetRef(match_spec); + bdt->match_spec = match_spec; + bdt->tracer_pid = tracer_pid; + } else if (break_op == (Uint) BeamOp(op_i_count_breakpoint)) { + BpDataCount *bdc = (BpDataCount *) bd; + + bdc->count = 0; + } + ++(*(Uint*)&code_base[MI_NUM_BREAKPOINTS]); + return 1; +} + +static int clear_break(Eterm mfa[3], int specified, Uint break_op) +{ + int num_processed = 0; + Module *modp; + + if (!specified) { + /* Iterate over all modules */ + int current; + int last = module_code_size(); + + for (current = 0; current < last; current++) { + modp = module_code(current); + ASSERT(modp != NULL); + num_processed += clear_module_break(modp, mfa, specified, break_op); + } + } else { + /* Process a single module */ + if ((modp = erts_get_module(mfa[0])) != NULL) { + num_processed += + clear_module_break(modp, mfa, specified, break_op); + } + } + return num_processed; +} + +static int clear_module_break(Module *m, Eterm mfa[3], int specified, + Uint break_op) { + Uint** code_base; + Uint* code_ptr; + int num_processed = 0; + Uint i,n; + + ASSERT(m); + code_base = (Uint **) m->code; + if (code_base == NULL) { + return 0; + } + n = (Uint) code_base[MI_NUM_FUNCTIONS]; + for (i = 0; i < n; ++i) { + code_ptr = code_base[MI_FUNCTIONS+i]; + if ((specified < 2 || mfa[1] == ((Eterm) code_ptr[3])) && + (specified < 3 || ((int) mfa[2]) == ((int) code_ptr[4]))) { + Uint *pc = code_ptr + 5; + + num_processed += + clear_function_break(m, pc, break_op); + } + } + return num_processed; +} + +static int clear_function_break(Module *m, Uint *pc, Uint break_op) { + BpData *bd; + Uint **code_base = (Uint **)m->code; + + ASSERT(code_base); + ASSERT(code_base <= (Uint **)pc); + ASSERT((Uint **)pc < code_base + (m->code_length/sizeof(Uint *))); + /* + * Currently no trace support for native code. + */ + if (erts_is_native_break(pc)) { + return 0; + } + while ( (bd = is_break(pc, break_op))) { + /* Remove all breakpoints of this type. + * There should be only one of each type, + * but break_op may be 0 which matches any type. + */ + Uint op; + BpData **r = (BpData **) (pc-4); + + ASSERT(*r); + /* Find opcode for this breakpoint */ + if (break_op) { + op = break_op; + } else { + if (bd == (*r)->next) { + /* First breakpoint in ring */ + op = *pc; + } else { + op = bd->prev->orig_instr; + } + } + if (BpSingleton(bd)) { + ASSERT(*r == bd); + /* Only one breakpoint to remove */ + *r = NULL; + *pc = bd->orig_instr; + } else { + BpData *bd_prev = bd->prev; + + BpSpliceNext(bd, bd_prev); + ASSERT(BpSingleton(bd)); + if (bd == *r) { + /* We removed the last breakpoint in the ring */ + *r = bd_prev; + bd_prev->orig_instr = bd->orig_instr; + } else if (bd_prev == *r) { + /* We removed the first breakpoint in the ring */ + *pc = bd->orig_instr; + } else { + bd_prev->orig_instr = bd->orig_instr; + } + } + if (op == (Uint) BeamOp(op_i_trace_breakpoint) || + op == (Uint) BeamOp(op_i_mtrace_breakpoint)) { + + BpDataTrace *bdt = (BpDataTrace *) bd; + + MatchSetUnref(bdt->match_spec); + } + Free(bd); + ASSERT(((Uint) code_base[MI_NUM_BREAKPOINTS]) > 0); + --(*(Uint*)&code_base[MI_NUM_BREAKPOINTS]); + } + return 1; +} + + + +/* +** Searches (linear forward) the breakpoint ring for a specified opcode +** and returns a pointer to the breakpoint data structure or NULL if +** not found. If the specified opcode is 0, the last breakpoint is +** returned. The program counter must point to the first executable +** (breakpoint) instruction of the function. +*/ +static BpData *is_break(Uint *pc, Uint break_op) { + ASSERT(pc[-5] == (Uint) BeamOp(op_i_func_info_IaaI)); + if (! erts_is_native_break(pc)) { + BpData *bd = (BpData *) pc[-4]; + + if (break_op == 0) { + return bd; + } + if (*pc == break_op) { + ASSERT(bd); + return bd->next; + } + if (! bd){ + return NULL; + } + bd = bd->next; + while (bd != (BpData *) pc[-4]) { + ASSERT(bd); + if (bd->orig_instr == break_op) { + bd = bd->next; + ASSERT(bd); + return bd; + } else { + bd = bd->next; + } + } + } + return NULL; +} diff --git a/erts/emulator/beam/beam_bp.h b/erts/emulator/beam/beam_bp.h new file mode 100644 index 0000000000..44e6b294d8 --- /dev/null +++ b/erts/emulator/beam/beam_bp.h @@ -0,0 +1,165 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2000-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + + +#ifndef _BEAM_BP_H +#define _BEAM_BP_H + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" + + + +/* +** Common struct to all bp_data_* +** +** Two gotchas: +** +** 1) The type of bp_data structure in the ring is deduced from the +** orig_instr field of the structure _before_ in the ring, except for +** the first structure in the ring that has its instruction in +** pc[0] of the code to execute. +** +** 2) pc[-4] points to the _last_ structure in the ring before the +** breakpoints are being executed. +** +** So, as an example, when a breakpointed function starts to execute, +** the first instruction that is a breakpoint instruction at pc[0] finds +** its data at ((BpData *) pc[-4])->next and has to cast that pointer +** to the correct bp_data type. +*/ +typedef struct bp_data { + struct bp_data *next; /* Doubly linked ring pointers */ + struct bp_data *prev; /* -"- */ + Uint orig_instr; /* The original instruction to execute */ +} BpData; +/* +** All the following bp_data_.. structs must begin the same way +*/ + +typedef struct bp_data_trace { + struct bp_data *next; + struct bp_data *prev; + Uint orig_instr; + Binary *match_spec; + Eterm tracer_pid; +} BpDataTrace; + +typedef struct bp_data_debug { + struct bp_data *next; + struct bp_data *prev; + Uint orig_instr; +} BpDataDebug; + +typedef struct bp_data_count { /* Call count */ + struct bp_data *next; + struct bp_data *prev; + Uint orig_instr; + Sint count; +} BpDataCount; + +extern erts_smp_spinlock_t erts_bp_lock; + +#ifdef ERTS_SMP +#define ErtsSmpBPLock(BDC) erts_smp_spin_lock(&erts_bp_lock) +#define ErtsSmpBPUnlock(BDC) erts_smp_spin_unlock(&erts_bp_lock) +#else +#define ErtsSmpBPLock(BDC) +#define ErtsSmpBPUnlock(BDC) +#endif + +#define ErtsCountBreak(pc,instr_result) \ +do { \ + BpDataCount *bdc = (BpDataCount *) (pc)[-4]; \ + \ + ASSERT((pc)[-5] == (Uint) BeamOp(op_i_func_info_IaaI)); \ + ASSERT(bdc); \ + bdc = (BpDataCount *) bdc->next; \ + ASSERT(bdc); \ + (pc)[-4] = (Uint) bdc; \ + ErtsSmpBPLock(bdc); \ + if (bdc->count >= 0) bdc->count++; \ + ErtsSmpBPUnlock(bdc); \ + *(instr_result) = bdc->orig_instr; \ +} while (0) + +#define ErtsBreakSkip(pc,instr_result) \ +do { \ + BpData *bd = (BpData *) (pc)[-4]; \ + \ + ASSERT((pc)[-5] == (Uint) BeamOp(op_i_func_info_IaaI)); \ + ASSERT(bd); \ + bd = bd->next; \ + ASSERT(bd); \ + (pc)[-4] = (Uint) bd; \ + *(instr_result) = bd->orig_instr; \ +} while (0) + +enum erts_break_op{ + erts_break_nop = 0, /* Must be false */ + erts_break_set = !0, /* Must be true */ + erts_break_reset, + erts_break_stop +}; + + + +/* +** Function interface exported from beam_bp.c +*/ + +void erts_bp_init(void); + +int erts_set_trace_break(Eterm mfa[3], int specified, Binary *match_spec, + Eterm tracer_pid); +int erts_clear_trace_break(Eterm mfa[3], int specified); +int erts_set_mtrace_break(Eterm mfa[3], int specified, Binary *match_spec, + Eterm tracer_pid); +int erts_clear_mtrace_break(Eterm mfa[3], int specified); +void erts_set_mtrace_bif(Uint *pc, Binary *match_spec, + Eterm tracer_pid); +void erts_clear_mtrace_bif(Uint *pc); +int erts_set_debug_break(Eterm mfa[3], int specified); +int erts_clear_debug_break(Eterm mfa[3], int specified); +int erts_set_count_break(Eterm mfa[3], int specified, enum erts_break_op); +int erts_clear_count_break(Eterm mfa[3], int specified); + + +int erts_clear_break(Eterm mfa[3], int specified); +int erts_clear_module_break(Module *modp); +int erts_clear_function_break(Module *modp, Uint *pc); + +Uint erts_trace_break(Process *p, Uint *pc, Eterm *args, + Uint32 *ret_flags, Eterm *tracer_pid); +Uint32 erts_bif_mtrace(Process *p, Uint *pc, Eterm *args, + int local, Eterm *tracer_pid); + +int erts_is_trace_break(Uint *pc, Binary **match_spec_ret, + Eterm *tracer_pid_ret); +int erts_is_mtrace_break(Uint *pc, Binary **match_spec_ret, + Eterm *tracer_pid_rte); +int erts_is_mtrace_bif(Uint *pc, Binary **match_spec_ret, + Eterm *tracer_pid_ret); +int erts_is_native_break(Uint *pc); +int erts_is_count_break(Uint *pc, Sint *count_ret); + +Uint *erts_find_local_func(Eterm mfa[3]); + +#endif /* _BEAM_BP_H */ diff --git a/erts/emulator/beam/beam_catches.c b/erts/emulator/beam/beam_catches.c new file mode 100644 index 0000000000..d5cef1cad2 --- /dev/null +++ b/erts/emulator/beam/beam_catches.c @@ -0,0 +1,102 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2000-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#include "sys.h" +#include "beam_catches.h" + +/* XXX: should use dynamic reallocation */ +#define TABSIZ (16*1024) +static struct { + Eterm *cp; + unsigned cdr; +} beam_catches[TABSIZ]; + +static int free_list; +static unsigned high_mark; + +void beam_catches_init(void) +{ + free_list = -1; + high_mark = 0; +} + +unsigned beam_catches_cons(Eterm *cp, unsigned cdr) +{ + int i; + + /* + * Allocate from free_list while it is non-empty. + * If free_list is empty, allocate at high_mark. + * + * This avoids the need to initialise the free list in + * beam_catches_init(), which would cost O(TABSIZ) time. + */ + if( (i = free_list) >= 0 ) { + free_list = beam_catches[i].cdr; + } else if( (i = high_mark) < TABSIZ ) { + high_mark = i + 1; + } else { + fprintf(stderr, "beam_catches_cons: no free slots :-(\r\n"); + exit(1); + } + + beam_catches[i].cp = cp; + beam_catches[i].cdr = cdr; + + return i; +} + +Eterm *beam_catches_car(unsigned i) +{ + if( i >= TABSIZ ) { + fprintf(stderr, + "beam_catches_car: index %#x is out of range\r\n", i); + abort(); + } + return beam_catches[i].cp; +} + +void beam_catches_delmod(unsigned head, Eterm *code, unsigned code_bytes) +{ + unsigned i, cdr; + + for(i = head; i != (unsigned)-1;) { + if( i >= TABSIZ ) { + fprintf(stderr, + "beam_catches_delmod: index %#x is out of range\r\n", i); + abort(); + } + if( (char*)beam_catches[i].cp - (char*)code >= code_bytes ) { + fprintf(stderr, + "beam_catches_delmod: item %#x has cp %#lx which is not " + "in module's range [%#lx,%#lx[\r\n", + i, (long)beam_catches[i].cp, + (long)code, (long)((char*)code + code_bytes)); + abort(); + } + beam_catches[i].cp = 0; + cdr = beam_catches[i].cdr; + beam_catches[i].cdr = free_list; + free_list = i; + i = cdr; + } +} diff --git a/erts/emulator/beam/beam_catches.h b/erts/emulator/beam/beam_catches.h new file mode 100644 index 0000000000..ccf33d5e86 --- /dev/null +++ b/erts/emulator/beam/beam_catches.h @@ -0,0 +1,32 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2000-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifndef __BEAM_CATCHES_H +#define __BEAM_CATCHES_H + +#define BEAM_CATCHES_NIL (-1) + +void beam_catches_init(void); +unsigned beam_catches_cons(Eterm* cp, unsigned cdr); +Eterm *beam_catches_car(unsigned i); +void beam_catches_delmod(unsigned head, Eterm* code, unsigned code_bytes); + +#define catch_pc(x) beam_catches_car(catch_val((x))) + +#endif /* __BEAM_CATCHES_H */ diff --git a/erts/emulator/beam/beam_debug.c b/erts/emulator/beam/beam_debug.c new file mode 100644 index 0000000000..4242a4161e --- /dev/null +++ b/erts/emulator/beam/beam_debug.c @@ -0,0 +1,548 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1998-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* + * Purpose: Basic debugging support. + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "erl_process.h" +#include "error.h" +#include "erl_driver.h" +#include "bif.h" +#include "big.h" +#include "external.h" +#include "beam_load.h" +#include "beam_bp.h" +#include "erl_binary.h" + +#ifdef ARCH_64 +# define HEXF "%016bpX" +#else +# define HEXF "%08bpX" +#endif + +void dbg_bt(Process* p, Eterm* sp); +void dbg_where(Eterm* addr, Eterm x0, Eterm* reg); + +static void print_big(int to, void *to_arg, Eterm* addr); +static int print_op(int to, void *to_arg, int op, int size, Eterm* addr); +Eterm +erts_debug_same_2(Process* p, Eterm term1, Eterm term2) +{ + return (term1 == term2) ? am_true : am_false; +} + +Eterm +erts_debug_flat_size_1(Process* p, Eterm term) +{ + Uint size = size_object(term); + + if (IS_USMALL(0, size)) { + BIF_RET(make_small(size)); + } else { + Eterm* hp = HAlloc(p, BIG_UINT_HEAP_SIZE); + BIF_RET(uint_to_big(size, hp)); + } +} + +Eterm +erts_debug_breakpoint_2(Process* p, Eterm MFA, Eterm bool) +{ + Eterm* tp; + Eterm mfa[3]; + int i; + int specified = 0; + Eterm res; + + if (bool != am_true && bool != am_false) + goto error; + + if (is_not_tuple(MFA)) { + goto error; + } + tp = tuple_val(MFA); + if (*tp != make_arityval(3)) { + goto error; + } + mfa[0] = tp[1]; + mfa[1] = tp[2]; + mfa[2] = tp[3]; + if (!is_atom(mfa[0]) || !is_atom(mfa[1]) || + (!is_small(mfa[2]) && mfa[2] != am_Underscore)) { + goto error; + } + for (i = 0; i < 3 && mfa[i] != am_Underscore; i++, specified++) { + /* Empty loop body */ + } + for (i = specified; i < 3; i++) { + if (mfa[i] != am_Underscore) { + goto error; + } + } + if (is_small(mfa[2])) { + mfa[2] = signed_val(mfa[2]); + } + + erts_smp_proc_unlock(p, ERTS_PROC_LOCK_MAIN); + erts_smp_block_system(0); + + if (bool == am_true) { + res = make_small(erts_set_debug_break(mfa, specified)); + } else { + res = make_small(erts_clear_debug_break(mfa, specified)); + } + + erts_smp_release_system(); + erts_smp_proc_lock(p, ERTS_PROC_LOCK_MAIN); + + return res; + + error: + BIF_ERROR(p, BADARG); +} + +Eterm +erts_debug_disassemble_1(Process* p, Eterm addr) +{ + erts_dsprintf_buf_t *dsbufp; + Eterm* hp; + Eterm* tp; + Eterm bin; + Eterm mfa; + Eterm* funcinfo = NULL; /* Initialized to eliminate warning. */ + Uint* code_base; + Uint* code_ptr = NULL; /* Initialized to eliminate warning. */ + Uint instr; + Uint uaddr; + Uint hsz; + int i; + + if (term_to_Uint(addr, &uaddr)) { + code_ptr = (Uint *) uaddr; + if ((funcinfo = find_function_from_pc(code_ptr)) == NULL) { + BIF_RET(am_false); + } + } else if (is_tuple(addr)) { + Module* modp; + Eterm mod; + Eterm name; + Export* ep; + Sint arity; + int n; + + tp = tuple_val(addr); + if (tp[0] != make_arityval(3)) { + error: + BIF_ERROR(p, BADARG); + } + mod = tp[1]; + name = tp[2]; + if (!is_atom(mod) || !is_atom(name) || !is_small(tp[3])) { + goto error; + } + arity = signed_val(tp[3]); + modp = erts_get_module(mod); + + /* + * Try the export entry first to allow disassembly of special functions + * such as erts_debug:apply/4. Then search for it in the module. + */ + + if ((ep = erts_find_function(mod, name, arity)) != NULL) { + /* XXX: add "&& ep->address != ep->code+3" condition? + * Consider a traced function. + * Its ep will have ep->address == ep->code+3. + * erts_find_function() will return the non-NULL ep. + * Below we'll try to derive a code_ptr from ep->address. + * But this code_ptr will point to the start of the Export, + * not the function's func_info instruction. BOOM !? + */ + code_ptr = ((Eterm *) ep->address) - 5; + funcinfo = code_ptr+2; + } else if (modp == NULL || (code_base = modp->code) == NULL) { + BIF_RET(am_undef); + } else { + n = code_base[MI_NUM_FUNCTIONS]; + for (i = 0; i < n; i++) { + code_ptr = (Uint *) code_base[MI_FUNCTIONS+i]; + if (code_ptr[3] == name && code_ptr[4] == arity) { + funcinfo = code_ptr+2; + break; + } + } + if (i == n) { + BIF_RET(am_undef); + } + } + } else { + goto error; + } + + dsbufp = erts_create_tmp_dsbuf(0); + erts_print(ERTS_PRINT_DSBUF, (void *) dsbufp, HEXF ": ", code_ptr); + instr = (Uint) code_ptr[0]; + for (i = 0; i < NUM_SPECIFIC_OPS; i++) { + if (instr == (Uint) BeamOp(i) && opc[i].name[0] != '\0') { + code_ptr += print_op(ERTS_PRINT_DSBUF, (void *) dsbufp, + i, opc[i].sz-1, code_ptr+1) + 1; + break; + } + } + if (i >= NUM_SPECIFIC_OPS) { + erts_print(ERTS_PRINT_DSBUF, (void *) dsbufp, + "unknown " HEXF "\n", instr); + code_ptr++; + } + bin = new_binary(p, (byte *) dsbufp->str, (int) dsbufp->str_len); + erts_destroy_tmp_dsbuf(dsbufp); + hsz = 4+4; + (void) erts_bld_uint(NULL, &hsz, (Uint) code_ptr); + hp = HAlloc(p, hsz); + addr = erts_bld_uint(&hp, NULL, (Uint) code_ptr); + ASSERT(is_atom(funcinfo[0])); + ASSERT(is_atom(funcinfo[1])); + mfa = TUPLE3(hp, funcinfo[0], funcinfo[1], make_small(funcinfo[2])); + hp += 4; + return TUPLE3(hp, addr, bin, mfa); +} + +void +dbg_bt(Process* p, Eterm* sp) +{ + Eterm* stack = STACK_START(p); + + while (sp < stack) { + if (is_CP(*sp)) { + Eterm* addr = find_function_from_pc(cp_val(*sp)); + if (addr) + erts_fprintf(stderr, + HEXF ": %T:%T/%bpu\n", + addr, addr[0], addr[1], addr[2]); + } + sp++; + } +} + +void +dbg_where(Eterm* addr, Eterm x0, Eterm* reg) +{ + Eterm* f = find_function_from_pc(addr); + + if (f == NULL) { + erts_fprintf(stderr, "???\n"); + } else { + int arity; + int i; + + addr = f; + arity = addr[2]; + erts_fprintf(stderr, HEXF ": %T:%T(", addr, addr[0], addr[1]); + for (i = 0; i < arity; i++) + erts_fprintf(stderr, i ? ", %T" : "%T", i ? reg[i] : x0); + erts_fprintf(stderr, ")\n"); + } +} + +static int +print_op(int to, void *to_arg, int op, int size, Eterm* addr) +{ + int i; + Uint tag; + char* sign; + char* start_prog; /* Start of program for packer. */ + char* prog; /* Current position in packer program. */ + Uint stack[8]; /* Stack for packer. */ + Uint* sp = stack; /* Points to next free position. */ + Uint packed = 0; /* Accumulator for packed operations. */ + Uint args[8]; /* Arguments for this instruction. */ + Uint* ap; /* Pointer to arguments. */ + + start_prog = opc[op].pack; + + if (start_prog[0] == '\0') { + /* + * There is no pack program. + * Avoid copying because instructions containing bignum operands + * are bigger than actually declared. + */ + ap = (Uint *) addr; + } else { + /* + * Copy all arguments to a local buffer for the unpacking. + */ + + ASSERT(size <= sizeof(args)/sizeof(args[0])); + ap = args; + for (i = 0; i < size; i++) { + *ap++ = addr[i]; + } + + /* + * Undo any packing done by the loader. This is easily done by running + * the packing program backwards and in reverse. + */ + + prog = start_prog + strlen(start_prog); + while (start_prog < prog) { + prog--; + switch (*prog) { + case 'g': + *ap++ = *--sp; + break; + case 'i': /* Initialize packing accumulator. */ + *ap++ = packed; + break; + case 's': + *ap++ = packed & 0x3ff; + packed >>= 10; + break; + case '0': /* Tight shift */ + *ap++ = packed & (BEAM_TIGHT_MASK / sizeof(Eterm)); + packed >>= BEAM_TIGHT_SHIFT; + break; + case '6': /* Shift 16 steps */ + *ap++ = packed & 0xffff; + packed >>= 16; + break; + case 'p': + *sp++ = *--ap; + break; + case 'P': + packed = *--sp; + break; + default: + ASSERT(0); + } + } + ap = args; + } + + /* + * Print the name and all operands of the instructions. + */ + + erts_print(to, to_arg, "%s ", opc[op].name); + sign = opc[op].sign; + while (*sign) { + switch (*sign) { + case 'r': /* x(0) */ + erts_print(to, to_arg, "x(0)"); + break; + case 'x': /* x(N) */ + if (reg_index(ap[0]) == 0) { + erts_print(to, to_arg, "X[0]"); + } else { + erts_print(to, to_arg, "x(%d)", reg_index(ap[0])); + } + ap++; + break; + case 'y': /* y(N) */ + erts_print(to, to_arg, "y(%d)", reg_index(ap[0]) - CP_SIZE); + ap++; + break; + case 'n': /* Nil */ + erts_print(to, to_arg, "[]"); + break; + case 's': /* Any source (tagged constant or register) */ + tag = beam_reg_tag(*ap); + if (tag == X_REG_DEF) { + if (reg_index(*ap) == 0) { + erts_print(to, to_arg, "x[0]"); + } else { + erts_print(to, to_arg, "x(%d)", reg_index(*ap)); + } + ap++; + break; + } else if (tag == Y_REG_DEF) { + erts_print(to, to_arg, "y(%d)", reg_index(*ap) - CP_SIZE); + ap++; + break; + } else if (tag == R_REG_DEF) { + erts_print(to, to_arg, "x(0)"); + ap++; + break; + } + /*FALLTHROUGH*/ + case 'a': /* Tagged atom */ + case 'i': /* Tagged integer */ + case 'c': /* Tagged constant */ + case 'q': /* Tagged literal */ + erts_print(to, to_arg, "%T", *ap); + ap++; + break; + case 'A': + erts_print(to, to_arg, "%d", arityval(ap[0])); + ap++; + break; + case 'd': /* Destination (x(0), x(N), y(N)) */ + switch (beam_reg_tag(*ap)) { + case X_REG_DEF: + if (reg_index(*ap) == 0) { + erts_print(to, to_arg, "x[0]"); + } else { + erts_print(to, to_arg, "x(%d)", reg_index(*ap)); + } + break; + case Y_REG_DEF: + erts_print(to, to_arg, "y(%d)", reg_index(*ap) - CP_SIZE); + break; + case R_REG_DEF: + erts_print(to, to_arg, "x(0)"); + break; + } + ap++; + break; + case 'I': /* Untagged integer. */ + case 't': + erts_print(to, to_arg, "%d", *ap); + ap++; + break; + case 'f': /* Destination label */ + erts_print(to, to_arg, "f(%X)", *ap); + ap++; + break; + case 'p': /* Pointer (to label) */ + { + Eterm* f = find_function_from_pc((Eterm *)*ap); + + if (f+3 != (Eterm *) *ap) { + erts_print(to, to_arg, "p(%X)", *ap); + } else { + erts_print(to, to_arg, "%T:%T/%bpu", f[0], f[1], f[2]); + } + ap++; + } + break; + case 'j': /* Pointer (to label) */ + erts_print(to, to_arg, "j(%X)", *ap); + ap++; + break; + case 'e': /* Export entry */ + { + Export* ex = (Export *) *ap; + erts_print(to, to_arg, + "%T:%T/%bpu", ex->code[0], ex->code[1], ex->code[2]); + ap++; + } + break; + case 'F': /* Function definition */ + break; + case 'b': + for (i = 0; i < BIF_SIZE; i++) { + BifFunction bif = (BifFunction) *ap; + if (bif == bif_table[i].f) { + break; + } + } + if (i == BIF_SIZE) { + erts_print(to, to_arg, "b(%d)", (Uint) *ap); + } else { + Eterm name = bif_table[i].name; + unsigned arity = bif_table[i].arity; + erts_print(to, to_arg, "%T/%u", name, arity); + } + ap++; + break; + case 'P': /* Byte offset into tuple (see beam_load.c) */ + erts_print(to, to_arg, "%d", (*ap / sizeof(Eterm*)) - 1); + ap++; + break; + case 'l': /* fr(N) */ + erts_print(to, to_arg, "fr(%d)", reg_index(ap[0])); + ap++; + break; + default: + erts_print(to, to_arg, "???"); + ap++; + break; + } + erts_print(to, to_arg, " "); + sign++; + } + + /* + * Print more information about certain instructions. + */ + + ap = addr + size; + switch (op) { + case op_i_select_val_sfI: + { + int n = ap[-1]; + + while (n > 0) { + erts_print(to, to_arg, "%T f(%X) ", ap[0], ap[1]); + ap += 2; + size += 2; + n--; + } + } + break; + case op_i_jump_on_val_sfII: + { + int n; + for (n = ap[-2]; n > 0; n--) { + erts_print(to, to_arg, "f(%X) ", ap[0]); + ap++; + size++; + } + } + break; + case op_i_select_big_sf: + while (ap[0]) { + int arity = thing_arityval(ap[0]); + print_big(to, to_arg, ap); + size += arity+1; + ap += arity+1; + erts_print(to, to_arg, " f(%X) ", ap[0]); + ap++; + size++; + } + ap++; + size++; + break; + } + erts_print(to, to_arg, "\n"); + + return size; +} + +static void +print_big(int to, void *to_arg, Eterm* addr) +{ + int i; + int k; + + i = BIG_SIZE(addr); + if (BIG_SIGN(addr)) + erts_print(to, to_arg, "-#integer(%d) = {", i); + else + erts_print(to, to_arg, "#integer(%d) = {", i); + erts_print(to, to_arg, "%d", BIG_DIGIT(addr, 0)); + for (k = 1; k < i; k++) + erts_print(to, to_arg, ",%d", BIG_DIGIT(addr, k)); + erts_print(to, to_arg, "}"); +} diff --git a/erts/emulator/beam/beam_emu.c b/erts/emulator/beam/beam_emu.c new file mode 100644 index 0000000000..dcaa43b51c --- /dev/null +++ b/erts/emulator/beam/beam_emu.c @@ -0,0 +1,6198 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include /* offsetof() */ +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "erl_process.h" +#include "erl_nmgc.h" +#include "error.h" +#include "bif.h" +#include "big.h" +#include "beam_load.h" +#include "erl_binary.h" +#include "erl_bits.h" +#include "dist.h" +#include "beam_bp.h" +#include "beam_catches.h" +#ifdef HIPE +#include "hipe_mode_switch.h" +#include "hipe_bif1.h" +#endif + +/* #define HARDDEBUG 1 */ + +#if defined(NO_JUMP_TABLE) +# define OpCase(OpCode) case op_##OpCode: lb_##OpCode +# define CountCase(OpCode) case op_count_##OpCode +# define OpCode(OpCode) ((Uint*)op_##OpCode) +# define Goto(Rel) {Go = (int)(Rel); goto emulator_loop;} +# define LabelAddr(Addr) &&##Addr +#else +# define OpCase(OpCode) lb_##OpCode +# define CountCase(OpCode) lb_count_##OpCode +# define Goto(Rel) goto *(Rel) +# define LabelAddr(Label) &&Label +# define OpCode(OpCode) (&&lb_##OpCode) +#endif + +#ifdef ERTS_ENABLE_LOCK_CHECK +# ifdef ERTS_SMP +# define PROCESS_MAIN_CHK_LOCKS(P) \ +do { \ + if ((P)) { \ + erts_pix_lock_t *pix_lock__ = ERTS_PIX2PIXLOCK(internal_pid_index((P)->id));\ + erts_proc_lc_chk_only_proc_main((P)); \ + erts_pix_lock(pix_lock__); \ + ASSERT(0 < (P)->lock.refc && (P)->lock.refc < erts_no_schedulers*5);\ + erts_pix_unlock(pix_lock__); \ + } \ + else \ + erts_lc_check_exact(NULL, 0); \ + ERTS_SMP_LC_ASSERT(!ERTS_LC_IS_BLOCKING); \ +} while (0) +# define ERTS_SMP_REQ_PROC_MAIN_LOCK(P) \ + if ((P)) erts_proc_lc_require_lock((P), ERTS_PROC_LOCK_MAIN) +# define ERTS_SMP_UNREQ_PROC_MAIN_LOCK(P) \ + if ((P)) erts_proc_lc_unrequire_lock((P), ERTS_PROC_LOCK_MAIN) +# else +# define ERTS_SMP_REQ_PROC_MAIN_LOCK(P) +# define ERTS_SMP_UNREQ_PROC_MAIN_LOCK(P) +# define PROCESS_MAIN_CHK_LOCKS(P) erts_lc_check_exact(NULL, 0) +# endif +#else +# define PROCESS_MAIN_CHK_LOCKS(P) +# define ERTS_SMP_REQ_PROC_MAIN_LOCK(P) +# define ERTS_SMP_UNREQ_PROC_MAIN_LOCK(P) +#endif + +/* + * Define macros for deep checking of terms. + */ + +#if defined(HARDDEBUG) + +# define CHECK_TERM(T) size_object(T) + +# define CHECK_ARGS(PC) \ +do { \ + int i_; \ + int Arity_ = PC[-1]; \ + if (Arity_ > 0) { \ + CHECK_TERM(r(0)); \ + } \ + for (i_ = 1; i_ < Arity_; i_++) { \ + CHECK_TERM(x(i_)); \ + } \ +} while (0) + +#else +# define CHECK_TERM(T) ASSERT(!is_CP(T)) +# define CHECK_ARGS(T) +#endif + +#ifndef MAX +#define MAX(x, y) (((x) > (y)) ? (x) : (y)) +#endif + +#define GET_BIF_ADDRESS(p) ((BifFunction) (((Export *) p)->code[4])) + + +/* + * We reuse some of fields in the save area in the process structure. + * This is safe to do, since this space is only activly used when + * the process is switched out. + */ +#define REDS_IN(p) ((p)->def_arg_reg[5]) + +/* + * Add a byte offset to a pointer to Eterm. This is useful when the + * the loader has precalculated a byte offset. + */ +#define ADD_BYTE_OFFSET(ptr, offset) \ + ((Eterm *) (((unsigned char *)ptr) + (offset))) + +/* We don't check the range if an ordinary switch is used */ +#ifdef NO_JUMP_TABLE +#define VALID_INSTR(IP) (0 <= (int)(IP) && ((int)(IP) < (NUMBER_OF_OPCODES*2+10))) +#else +#define VALID_INSTR(IP) \ + ((Sint)LabelAddr(emulator_loop) <= (Sint)(IP) && \ + (Sint)(IP) < (Sint)LabelAddr(end_emulator_loop)) +#endif /* NO_JUMP_TABLE */ + +#define SET_CP(p, ip) \ + ASSERT(VALID_INSTR(*(ip))); \ + (p)->cp = (ip) + +#define SET_I(ip) \ + ASSERT(VALID_INSTR(* (Eterm *)(ip))); \ + I = (ip) + +#define FetchArgs(S1, S2) tmp_arg1 = (S1); tmp_arg2 = (S2) + +/* + * Store a result into a register given a destination descriptor. + */ + +#define StoreResult(Result, DestDesc) \ + do { \ + Eterm stb_reg; \ + stb_reg = (DestDesc); \ + CHECK_TERM(Result); \ + switch (beam_reg_tag(stb_reg)) { \ + case R_REG_DEF: \ + r(0) = (Result); break; \ + case X_REG_DEF: \ + xb(x_reg_offset(stb_reg)) = (Result); break; \ + default: \ + yb(y_reg_offset(stb_reg)) = (Result); break; \ + } \ + } while (0) + +#define StoreSimpleDest(Src, Dest) Dest = (Src) + +/* + * Store a result into a register and execute the next instruction. + * Dst points to the word with a destination descriptor, which MUST + * be just before the next instruction. + */ + +#define StoreBifResult(Dst, Result) \ + do { \ + Eterm* stb_next; \ + Eterm stb_reg; \ + stb_reg = Arg(Dst); \ + I += (Dst) + 2; \ + stb_next = (Eterm *) *I; \ + CHECK_TERM(Result); \ + switch (beam_reg_tag(stb_reg)) { \ + case R_REG_DEF: \ + r(0) = (Result); Goto(stb_next); \ + case X_REG_DEF: \ + xb(x_reg_offset(stb_reg)) = (Result); Goto(stb_next); \ + default: \ + yb(y_reg_offset(stb_reg)) = (Result); Goto(stb_next); \ + } \ + } while (0) + +#define ClauseFail() goto lb_jump_f + +#define SAVE_CP(X) \ + do { \ + *(X) = make_cp(c_p->cp); \ + c_p->cp = 0; \ + } while(0) + +#define RESTORE_CP(X) SET_CP(c_p, cp_val(*(X))) + +#define ISCATCHEND(instr) ((Eterm *) *(instr) == OpCode(catch_end_y)) + +/* + * Special Beam instructions. + */ + +Eterm beam_apply[2]; +Eterm beam_exit[1]; +Eterm beam_continue_exit[1]; + +Eterm* em_call_error_handler; +Eterm* em_apply_bif; +Eterm* em_call_traced_function; + + +/* NOTE These should be the only variables containing trace instructions. +** Sometimes tests are form the instruction value, and sometimes +** for the refering variable (one of these), and rouge references +** will most likely cause chaos. +*/ +Eterm beam_return_to_trace[1]; /* OpCode(i_return_to_trace) */ +Eterm beam_return_trace[1]; /* OpCode(i_return_trace) */ +Eterm beam_exception_trace[1]; /* UGLY also OpCode(i_return_trace) */ + +/* + * All Beam instructions in numerical order. + */ + +#ifndef NO_JUMP_TABLE +void** beam_ops; +#endif + +#ifndef ERTS_SMP /* Not supported with smp emulator */ +extern int count_instructions; +#endif + +#if defined(HYBRID) +#define SWAPIN \ + g_htop = global_htop; \ + g_hend = global_hend; \ + HTOP = HEAP_TOP(c_p); \ + E = c_p->stop + +#define SWAPOUT \ + global_htop = g_htop; \ + global_hend = g_hend; \ + HEAP_TOP(c_p) = HTOP; \ + c_p->stop = E + +#else +#define SWAPIN \ + HTOP = HEAP_TOP(c_p); \ + E = c_p->stop + +#define SWAPOUT \ + HEAP_TOP(c_p) = HTOP; \ + c_p->stop = E + +/* + * Use LIGHT_SWAPOUT when the called function + * will call HeapOnlyAlloc() (and never HAlloc()). + */ +#ifdef DEBUG +# /* The stack pointer is used in an assertion. */ +# define LIGHT_SWAPOUT SWAPOUT +#else +# define LIGHT_SWAPOUT HEAP_TOP(c_p) = HTOP +#endif + +/* + * Use LIGHT_SWAPIN when we know that c_p->stop cannot + * have been updated (i.e. if there cannot have been + * a garbage-collection). + */ + +#define LIGHT_SWAPIN HTOP = HEAP_TOP(c_p) + +#endif + +#define PRE_BIF_SWAPOUT(P) \ + HEAP_TOP((P)) = HTOP; \ + (P)->stop = E; \ + PROCESS_MAIN_CHK_LOCKS((P)); \ + ERTS_SMP_UNREQ_PROC_MAIN_LOCK((P)) + +#if defined(HYBRID) +# define POST_BIF_GC_SWAPIN_0(_p, _res) \ + if (((_p)->mbuf) || (MSO(_p).overhead >= BIN_VHEAP_SZ(_p)) ) { \ + _res = erts_gc_after_bif_call((_p), (_res), NULL, 0); \ + } \ + SWAPIN + +# define POST_BIF_GC_SWAPIN(_p, _res, _regs, _arity) \ + if (((_p)->mbuf) || (MSO(_p).overhead >= BIN_VHEAP_SZ(_p)) ) { \ + _regs[0] = r(0); \ + _res = erts_gc_after_bif_call((_p), (_res), _regs, (_arity)); \ + r(0) = _regs[0]; \ + } \ + SWAPIN +#else +# define POST_BIF_GC_SWAPIN_0(_p, _res) \ + ERTS_SMP_REQ_PROC_MAIN_LOCK((_p)); \ + PROCESS_MAIN_CHK_LOCKS((_p)); \ + if (((_p)->mbuf) || (MSO(_p).overhead >= BIN_VHEAP_SZ(_p)) ) { \ + _res = erts_gc_after_bif_call((_p), (_res), NULL, 0); \ + E = (_p)->stop; \ + } \ + HTOP = HEAP_TOP((_p)) + +# define POST_BIF_GC_SWAPIN(_p, _res, _regs, _arity) \ + ERTS_SMP_REQ_PROC_MAIN_LOCK((_p)); \ + PROCESS_MAIN_CHK_LOCKS((_p)); \ + if (((_p)->mbuf) || (MSO(_p).overhead >= BIN_VHEAP_SZ(_p)) ) { \ + _regs[0] = r(0); \ + _res = erts_gc_after_bif_call((_p), (_res), _regs, (_arity)); \ + r(0) = _regs[0]; \ + E = (_p)->stop; \ + } \ + HTOP = HEAP_TOP((_p)) +#endif + +#define db(N) (N) +#define tb(N) (N) +#define xb(N) (*(Eterm *) (((unsigned char *)reg) + (N))) +#define yb(N) (*(Eterm *) (((unsigned char *)E) + (N))) +#define fb(N) (*(double *) (((unsigned char *)&(freg[0].fd)) + (N))) +#define x(N) reg[N] +#define y(N) E[N] +#define r(N) x##N + +/* + * Makes sure that there are StackNeed + HeapNeed + 1 words available + * on the combined heap/stack segment, then allocates StackNeed + 1 + * words on the stack and saves CP. + * + * M is number of live registers to preserve during garbage collection + */ + +#define AH(StackNeed, HeapNeed, M) \ + do { \ + int needed; \ + needed = (StackNeed) + 1; \ + if (E - HTOP < (needed + (HeapNeed))) { \ + SWAPOUT; \ + reg[0] = r(0); \ + PROCESS_MAIN_CHK_LOCKS(c_p); \ + FCALLS -= erts_garbage_collect(c_p, needed + (HeapNeed), reg, (M)); \ + PROCESS_MAIN_CHK_LOCKS(c_p); \ + r(0) = reg[0]; \ + SWAPIN; \ + } \ + E -= needed; \ + SAVE_CP(E); \ + } while (0) + +#define Allocate(Ns, Live) AH(Ns, 0, Live) + +#define AllocateZero(Ns, Live) \ + do { Eterm* ptr; \ + int i = (Ns); \ + AH(i, 0, Live); \ + for (ptr = E + i; ptr > E; ptr--) { \ + make_blank(*ptr); \ + } \ + } while (0) + +#define AllocateHeap(Ns, Nh, Live) AH(Ns, Nh, Live) + +#define AllocateHeapZero(Ns, Nh, Live) \ + do { Eterm* ptr; \ + int i = (Ns); \ + AH(i, Nh, Live); \ + for (ptr = E + i; ptr > E; ptr--) { \ + make_blank(*ptr); \ + } \ + } while (0) + +#define AllocateInit(Ns, Live, Y) \ + do { AH(Ns, 0, Live); make_blank(Y); } while (0) + +/* + * Like the AH macro, but allocates no additional heap space. + */ + +#define A(StackNeed, M) AH(StackNeed, 0, M) + +#define D(N) \ + RESTORE_CP(E); \ + E += (N) + 1; + + + +#define TestBinVHeap(VNh, Nh, Live) \ + do { \ + unsigned need = (Nh); \ + if ((E - HTOP < need) || (MSO(c_p).overhead + (VNh) >= BIN_VHEAP_SZ(c_p))) {\ + SWAPOUT; \ + reg[0] = r(0); \ + PROCESS_MAIN_CHK_LOCKS(c_p); \ + FCALLS -= erts_garbage_collect(c_p, need, reg, (Live)); \ + PROCESS_MAIN_CHK_LOCKS(c_p); \ + r(0) = reg[0]; \ + SWAPIN; \ + } \ + } while (0) + + + +/* + * Check if Nh words of heap are available; if not, do a garbage collection. + * Live is number of active argument registers to be preserved. + */ + +#define TestHeap(Nh, Live) \ + do { \ + unsigned need = (Nh); \ + if (E - HTOP < need) { \ + SWAPOUT; \ + reg[0] = r(0); \ + PROCESS_MAIN_CHK_LOCKS(c_p); \ + FCALLS -= erts_garbage_collect(c_p, need, reg, (Live)); \ + PROCESS_MAIN_CHK_LOCKS(c_p); \ + r(0) = reg[0]; \ + SWAPIN; \ + } \ + } while (0) + +/* + * Check if Nh words of heap are available; if not, do a garbage collection. + * Live is number of active argument registers to be preserved. + * Takes special care to preserve Extra if a garbage collection occurs. + */ + +#define TestHeapPreserve(Nh, Live, Extra) \ + do { \ + unsigned need = (Nh); \ + if (E - HTOP < need) { \ + SWAPOUT; \ + reg[0] = r(0); \ + reg[Live] = Extra; \ + PROCESS_MAIN_CHK_LOCKS(c_p); \ + FCALLS -= erts_garbage_collect(c_p, need, reg, (Live)+1); \ + PROCESS_MAIN_CHK_LOCKS(c_p); \ + if (Live > 0) { \ + r(0) = reg[0]; \ + } \ + Extra = reg[Live]; \ + SWAPIN; \ + } \ + } while (0) + +#ifdef HYBRID +#ifdef INCREMENTAL +#define TestGlobalHeap(Nh, Live, hp) \ + do { \ + unsigned need = (Nh); \ + ASSERT(global_heap <= g_htop && g_htop <= global_hend); \ + SWAPOUT; \ + reg[0] = r(0); \ + FCALLS -= need; \ + (hp) = IncAlloc(c_p,need,reg,(Live)); \ + r(0) = reg[0]; \ + SWAPIN; \ + } while (0) +#else +#define TestGlobalHeap(Nh, Live, hp) \ + do { \ + unsigned need = (Nh); \ + ASSERT(global_heap <= g_htop && g_htop <= global_hend); \ + if (g_hend - g_htop < need) { \ + SWAPOUT; \ + reg[0] = r(0); \ + FCALLS -= erts_global_garbage_collect(c_p, need, reg, (Live)); \ + r(0) = reg[0]; \ + SWAPIN; \ + } \ + (hp) = global_htop; \ + } while (0) +#endif +#endif /* HYBRID */ + +#define Init(N) make_blank(yb(N)) + +#define Init2(Y1, Y2) do { make_blank(Y1); make_blank(Y2); } while (0) +#define Init3(Y1, Y2, Y3) \ + do { make_blank(Y1); make_blank(Y2); make_blank(Y3); } while (0) + +#define MakeFun(FunP, NumFree) \ + do { \ + SWAPOUT; \ + reg[0] = r(0); \ + r(0) = new_fun(c_p, reg, (ErlFunEntry *) FunP, NumFree); \ + SWAPIN; \ + } while (0) + + +/* + * Check that we haven't used the reductions and jump to function pointed to by + * the I register. If we are out of reductions, do a context switch. + */ + +#define DispatchMacro() \ + do { \ + Eterm* dis_next; \ + dis_next = (Eterm *) *I; \ + CHECK_ARGS(I); \ + if (FCALLS > 0 || FCALLS > neg_o_reds) { \ + FCALLS--; \ + Goto(dis_next); \ + } else { \ + goto context_switch; \ + } \ + } while (0) + +#define DispatchMacroFun() \ + do { \ + Eterm* dis_next; \ + dis_next = (Eterm *) *I; \ + CHECK_ARGS(I); \ + if (FCALLS > 0 || FCALLS > neg_o_reds) { \ + FCALLS--; \ + Goto(dis_next); \ + } else { \ + goto context_switch_fun; \ + } \ + } while (0) + +#define DispatchMacrox() \ + do { \ + if (FCALLS > 0) { \ + Eterm* dis_next; \ + SET_I(((Export *) Arg(0))->address); \ + dis_next = (Eterm *) *I; \ + FCALLS--; \ + CHECK_ARGS(I); \ + Goto(dis_next); \ + } else if (ERTS_PROC_GET_SAVED_CALLS_BUF(c_p) \ + && FCALLS > neg_o_reds) { \ + goto save_calls1; \ + } else { \ + SET_I(((Export *) Arg(0))->address); \ + CHECK_ARGS(I); \ + goto context_switch; \ + } \ + } while (0) + +#ifdef DEBUG +/* + * To simplify breakpoint setting, put the code in one place only and jump to it. + */ +# define Dispatch() goto do_dispatch +# define Dispatchx() goto do_dispatchx +# define Dispatchfun() goto do_dispatchfun +#else +/* + * Inline for speed. + */ +# define Dispatch() DispatchMacro() +# define Dispatchx() DispatchMacrox() +# define Dispatchfun() DispatchMacroFun() +#endif + +#define Self(R) R = c_p->id +#define Node(R) R = erts_this_node->sysname + +#define Arg(N) I[(N)+1] +#define Next(N) \ + I += (N) + 1; \ + ASSERT(VALID_INSTR(*I)); \ + Goto(*I) + +#define PreFetch(N, Dst) do { Dst = (Eterm *) *(I + N + 1); } while (0) +#define NextPF(N, Dst) \ + I += N + 1; \ + ASSERT(VALID_INSTR(Dst)); \ + Goto(Dst) + +#define GetR(pos, tr) \ + do { \ + tr = Arg(pos); \ + switch (beam_reg_tag(tr)) { \ + case R_REG_DEF: tr = r(0); break; \ + case X_REG_DEF: tr = xb(x_reg_offset(tr)); break; \ + case Y_REG_DEF: ASSERT(y_reg_offset(tr) >= 1); tr = yb(y_reg_offset(tr)); break; \ + } \ + CHECK_TERM(tr); \ + } while (0) + +#define GetArg1(N, Dst) GetR((N), Dst) + +#define GetArg2(N, Dst1, Dst2) \ + do { \ + GetR(N, Dst1); \ + GetR((N)+1, Dst2); \ + } while (0) + +#define PutList(H, T, Dst, Store) \ + do { \ + HTOP[0] = (H); HTOP[1] = (T); \ + Store(make_list(HTOP), Dst); \ + HTOP += 2; \ + } while (0) + +#define Move(Src, Dst, Store) \ + do { \ + Eterm term = (Src); \ + Store(term, Dst); \ + } while (0) + +#define Move2(src1, dst1, src2, dst2) dst1 = (src1); dst2 = (src2) + +#define MoveGenDest(src, dstp) \ + if ((dstp) == NULL) { r(0) = (src); } else { *(dstp) = src; } + +#define MoveReturn(Src, Dest) \ + (Dest) = (Src); \ + I = c_p->cp; \ + ASSERT(VALID_INSTR(*c_p->cp)); \ + c_p->cp = 0; \ + CHECK_TERM(r(0)); \ + Goto(*I) + +#define DeallocateReturn(Deallocate) \ + do { \ + int words_to_pop = (Deallocate); \ + SET_I(cp_val(*E)); \ + E = ADD_BYTE_OFFSET(E, words_to_pop); \ + CHECK_TERM(r(0)); \ + Goto(*I); \ + } while (0) + +#define MoveDeallocateReturn(Src, Dest, Deallocate) \ + (Dest) = (Src); \ + DeallocateReturn(Deallocate) + +#define MoveCall(Src, Dest, CallDest, Size) \ + (Dest) = (Src); \ + SET_CP(c_p, I+Size+1); \ + SET_I((Eterm *) CallDest); \ + Dispatch(); + +#define MoveCallLast(Src, Dest, CallDest, Deallocate) \ + (Dest) = (Src); \ + RESTORE_CP(E); \ + E = ADD_BYTE_OFFSET(E, (Deallocate)); \ + SET_I((Eterm *) CallDest); \ + Dispatch(); + +#define MoveCallOnly(Src, Dest, CallDest) \ + (Dest) = (Src); \ + SET_I((Eterm *) CallDest); \ + Dispatch(); + +#define GetList(Src, H, T) do { \ + Eterm* tmp_ptr = list_val(Src); \ + H = CAR(tmp_ptr); \ + T = CDR(tmp_ptr); } while (0) + +#define GetTupleElement(Src, Element, Dest) \ + do { \ + tmp_arg1 = (Eterm) (((unsigned char *) tuple_val(Src)) + (Element)); \ + (Dest) = (*(Eterm *)tmp_arg1); \ + } while (0) + +#define ExtractNextElement(Dest) \ + tmp_arg1 += sizeof(Eterm); \ + (Dest) = (* (Eterm *) (((unsigned char *) tmp_arg1))) + +#define ExtractNextElement2(Dest) \ + do { \ + Eterm* ene_dstp = &(Dest); \ + ene_dstp[0] = ((Eterm *) tmp_arg1)[1]; \ + ene_dstp[1] = ((Eterm *) tmp_arg1)[2]; \ + tmp_arg1 += sizeof(Eterm) + sizeof(Eterm); \ + } while (0) + +#define ExtractNextElement3(Dest) \ + do { \ + Eterm* ene_dstp = &(Dest); \ + ene_dstp[0] = ((Eterm *) tmp_arg1)[1]; \ + ene_dstp[1] = ((Eterm *) tmp_arg1)[2]; \ + ene_dstp[2] = ((Eterm *) tmp_arg1)[3]; \ + tmp_arg1 += 3*sizeof(Eterm); \ + } while (0) + +#define ExtractNextElement4(Dest) \ + do { \ + Eterm* ene_dstp = &(Dest); \ + ene_dstp[0] = ((Eterm *) tmp_arg1)[1]; \ + ene_dstp[1] = ((Eterm *) tmp_arg1)[2]; \ + ene_dstp[2] = ((Eterm *) tmp_arg1)[3]; \ + ene_dstp[3] = ((Eterm *) tmp_arg1)[4]; \ + tmp_arg1 += 4*sizeof(Eterm); \ + } while (0) + +#define ExtractElement(Element, Dest) \ + do { \ + tmp_arg1 += (Element); \ + (Dest) = (* (Eterm *) tmp_arg1); \ + } while (0) + +#define PutTuple(Arity, Src, Dest) \ + ASSERT(is_arity_value(Arity)); \ + Dest = make_tuple(HTOP); \ + HTOP[0] = (Arity); \ + HTOP[1] = (Src); \ + HTOP += 2 + +#define Put(Word) *HTOP++ = (Word) + +#define EqualImmed(X, Y, Action) if (X != Y) { Action; } + +#define IsFloat(Src, Fail) if (is_not_float(Src)) { Fail; } + +#define IsInteger(Src, Fail) if (is_not_integer(Src)) { Fail; } + +#define IsNumber(X, Fail) if (is_not_integer(X) && is_not_float(X)) { Fail; } + +#define IsAtom(Src, Fail) if (is_not_atom(Src)) { Fail; } + +#define IsIntegerAllocate(Src, Need, Alive, Fail) \ + if (is_not_integer(Src)) { Fail; } \ + A(Need, Alive) + +#define IsNil(Src, Fail) if (is_not_nil(Src)) { Fail; } + +#define IsList(Src, Fail) if (is_not_list(Src) && is_not_nil(Src)) { Fail; } + +#define IsNonemptyList(Src, Fail) if (is_not_list(Src)) { Fail; } + +#define IsNonemptyListAllocate(Src, Need, Alive, Fail) \ + if (is_not_list(Src)) { Fail; } \ + A(Need, Alive) + +#define IsNonemptyListTestHeap(Src, Need, Alive, Fail) \ + if (is_not_list(Src)) { Fail; } \ + TestHeap(Need, Alive) + +#define IsTuple(X, Action) if (is_not_tuple(X)) Action + +#define IsArity(Pointer, Arity, Fail) \ + if (*(Eterm *)(tmp_arg1 = (Eterm)tuple_val(Pointer)) != (Arity)) { Fail; } + +#define IsFunction(X, Action) \ + do { \ + if ( !(is_any_fun(X)) ) { \ + Action; \ + } \ + } while (0) + +#define IsFunction2(F, A, Action) \ + do { \ + if (is_function_2(c_p, F, A) != am_true ) {\ + Action; \ + } \ + } while (0) + +#define IsTupleOfArity(Src, Arity, Fail) \ + do { \ + if (is_not_tuple(Src) || *(Eterm *)(tmp_arg1 = (Eterm) tuple_val(Src)) != Arity) { \ + Fail; \ + } \ + } while (0) + +#define IsBoolean(X, Fail) if ((X) != am_true && (X) != am_false) { Fail; } + +#define IsBinary(Src, Fail) \ + if (is_not_binary(Src) || binary_bitsize(Src) != 0) { Fail; } + +#define IsBitstring(Src, Fail) \ + if (is_not_binary(Src)) { Fail; } + +#ifdef ARCH_64 +#define BsSafeMul(A, B, Fail, Target) \ + do { Uint64 _res = (A) * (B); \ + if (_res / B != A) { Fail; } \ + Target = _res; \ + } while (0) +#else +#define BsSafeMul(A, B, Fail, Target) \ + do { Uint64 _res = (Uint64)(A) * (Uint64)(B); \ + if ((_res >> (8*sizeof(Uint))) != 0) { Fail; } \ + Target = _res; \ + } while (0) +#endif + +#define BsGetFieldSize(Bits, Unit, Fail, Target) \ + do { \ + Sint _signed_size; Uint _uint_size; \ + if (is_small(Bits)) { \ + _signed_size = signed_val(Bits); \ + if (_signed_size < 0) { Fail; } \ + _uint_size = (Uint) _signed_size; \ + } else { \ + if (!term_to_Uint(Bits, &temp_bits)) { Fail; } \ + _uint_size = temp_bits; \ + } \ + BsSafeMul(_uint_size, Unit, Fail, Target); \ + } while (0) + +#define BsGetUncheckedFieldSize(Bits, Unit, Fail, Target) \ + do { \ + Sint _signed_size; Uint _uint_size; \ + if (is_small(Bits)) { \ + _signed_size = signed_val(Bits); \ + if (_signed_size < 0) { Fail; } \ + _uint_size = (Uint) _signed_size; \ + } else { \ + if (!term_to_Uint(Bits, &temp_bits)) { Fail; } \ + _uint_size = (Uint) temp_bits; \ + } \ + Target = _uint_size * Unit; \ + } while (0) + +#define BsGetFloat2(Ms, Live, Sz, Flags, Dst, Store, Fail) \ + do { \ + ErlBinMatchBuffer *_mb; \ + Eterm _result; Sint _size; \ + if (!is_small(Sz) || (_size = unsigned_val(Sz)) > 64) { Fail; } \ + _size *= ((Flags) >> 3); \ + TestHeap(FLOAT_SIZE_OBJECT, Live); \ + _mb = ms_matchbuffer(Ms); \ + LIGHT_SWAPOUT; \ + _result = erts_bs_get_float_2(c_p, _size, (Flags), _mb); \ + LIGHT_SWAPIN; \ + if (is_non_value(_result)) { Fail; } \ + else { Store(_result, Dst); } \ + } while (0) + +#define BsGetBinaryImm_2(Ms, Live, Sz, Flags, Dst, Store, Fail) \ + do { \ + ErlBinMatchBuffer *_mb; \ + Eterm _result; \ + TestHeap(heap_bin_size(ERL_ONHEAP_BIN_LIMIT), Live); \ + _mb = ms_matchbuffer(Ms); \ + LIGHT_SWAPOUT; \ + _result = erts_bs_get_binary_2(c_p, (Sz), (Flags), _mb); \ + LIGHT_SWAPIN; \ + if (is_non_value(_result)) { Fail; } \ + else { Store(_result, Dst); } \ + } while (0) + +#define BsGetBinary_2(Ms, Live, Sz, Flags, Dst, Store, Fail) \ + do { \ + ErlBinMatchBuffer *_mb; \ + Eterm _result; Uint _size; \ + BsGetFieldSize(Sz, ((Flags) >> 3), Fail, _size); \ + TestHeap(ERL_SUB_BIN_SIZE, Live); \ + _mb = ms_matchbuffer(Ms); \ + LIGHT_SWAPOUT; \ + _result = erts_bs_get_binary_2(c_p, _size, (Flags), _mb); \ + LIGHT_SWAPIN; \ + if (is_non_value(_result)) { Fail; } \ + else { Store(_result, Dst); } \ + } while (0) + +#define BsGetBinaryAll_2(Ms, Live, Unit, Dst, Store, Fail) \ + do { \ + ErlBinMatchBuffer *_mb; \ + Eterm _result; \ + TestHeap(ERL_SUB_BIN_SIZE, Live); \ + _mb = ms_matchbuffer(Ms); \ + if (((_mb->size - _mb->offset) % Unit) == 0) { \ + LIGHT_SWAPOUT; \ + _result = erts_bs_get_binary_all_2(c_p, _mb); \ + LIGHT_SWAPIN; \ + ASSERT(is_value(_result)); \ + Store(_result, Dst); \ + } else { Fail; } \ + } while (0) + +#define BsSkipBits2(Ms, Bits, Unit, Fail) \ + do { \ + ErlBinMatchBuffer *_mb; \ + size_t new_offset; \ + Uint _size; \ + _mb = ms_matchbuffer(Ms); \ + BsGetFieldSize(Bits, Unit, Fail, _size); \ + new_offset = _mb->offset + _size; \ + if (new_offset <= _mb->size) { _mb->offset = new_offset; } \ + else { Fail; } \ + } while (0) + +#define BsSkipBitsAll2(Ms, Unit, Fail) \ + do { \ + ErlBinMatchBuffer *_mb; \ + _mb = ms_matchbuffer(Ms); \ + if (((_mb->size - _mb->offset) % Unit) == 0) {_mb->offset = _mb->size; } \ + else { Fail; } \ + } while (0) + +#define BsSkipBitsImm2(Ms, Bits, Fail) \ + do { \ + ErlBinMatchBuffer *_mb; \ + size_t new_offset; \ + _mb = ms_matchbuffer(Ms); \ + new_offset = _mb->offset + (Bits); \ + if (new_offset <= _mb->size) { _mb->offset = new_offset; } \ + else { Fail; } \ + } while (0) + +#define NewBsPutIntegerImm(Sz, Flags, Src) \ + do { \ + if (!erts_new_bs_put_integer(ERL_BITS_ARGS_3((Src), (Sz), (Flags)))) { goto badarg; } \ + } while (0) + +#define NewBsPutInteger(Sz, Flags, Src) \ + do { \ + Sint _size; \ + BsGetUncheckedFieldSize(Sz, ((Flags) >> 3), goto badarg, _size); \ + if (!erts_new_bs_put_integer(ERL_BITS_ARGS_3((Src), _size, (Flags)))) \ + { goto badarg; } \ + } while (0) + +#define NewBsPutFloatImm(Sz, Flags, Src) \ + do { \ + if (!erts_new_bs_put_float(c_p, (Src), (Sz), (Flags))) { goto badarg; } \ + } while (0) + +#define NewBsPutFloat(Sz, Flags, Src) \ + do { \ + Sint _size; \ + BsGetUncheckedFieldSize(Sz, ((Flags) >> 3), goto badarg, _size); \ + if (!erts_new_bs_put_float(c_p, (Src), _size, (Flags))) { goto badarg; } \ + } while (0) + +#define NewBsPutBinary(Sz, Flags, Src) \ + do { \ + Sint _size; \ + BsGetUncheckedFieldSize(Sz, ((Flags) >> 3), goto badarg, _size); \ + if (!erts_new_bs_put_binary(ERL_BITS_ARGS_2((Src), _size))) { goto badarg; } \ + } while (0) + +#define NewBsPutBinaryImm(Sz, Src) \ + do { \ + if (!erts_new_bs_put_binary(ERL_BITS_ARGS_2((Src), (Sz)))) { goto badarg; } \ + } while (0) + +#define NewBsPutBinaryAll(Src, Unit) \ + do { \ + if (!erts_new_bs_put_binary_all(ERL_BITS_ARGS_2((Src), (Unit)))) { goto badarg; } \ + } while (0) + + +#define IsPort(Src, Fail) if (is_not_port(Src)) { Fail; } +#define IsPid(Src, Fail) if (is_not_pid(Src)) { Fail; } +#define IsRef(Src, Fail) if (is_not_ref(Src)) { Fail; } + +static BifFunction translate_gc_bif(void* gcf); +static Eterm* handle_error(Process* c_p, Eterm* pc, Eterm* reg, BifFunction bf); +static Eterm* next_catch(Process* c_p, Eterm *reg); +static void terminate_proc(Process* c_p, Eterm Value); +static Eterm add_stacktrace(Process* c_p, Eterm Value, Eterm exc); +static void save_stacktrace(Process* c_p, Eterm* pc, Eterm* reg, + BifFunction bf, Eterm args); +static struct StackTrace * get_trace_from_exc(Eterm exc); +static Eterm make_arglist(Process* c_p, Eterm* reg, int a); +static Eterm call_error_handler(Process* p, Eterm* ip, Eterm* reg); +static Eterm call_breakpoint_handler(Process* p, Eterm* fi, Eterm* reg); +static Uint* fixed_apply(Process* p, Eterm* reg, Uint arity); +static Eterm* apply(Process* p, Eterm module, Eterm function, + Eterm args, Eterm* reg); +static int hibernate(Process* c_p, Eterm module, Eterm function, + Eterm args, Eterm* reg); +static Eterm* call_fun(Process* p, int arity, Eterm* reg, Eterm args); +static Eterm* apply_fun(Process* p, Eterm fun, Eterm args, Eterm* reg); +static Eterm new_fun(Process* p, Eterm* reg, ErlFunEntry* fe, int num_free); +static BIF_RETTYPE nif_dispatcher_0(Process* p, Uint* I); +static BIF_RETTYPE nif_dispatcher_1(Process* p, Eterm arg1, Uint* I); +static BIF_RETTYPE nif_dispatcher_2(Process* p, Eterm arg1, Eterm arg2, Uint* I); +static BIF_RETTYPE nif_dispatcher_3(Process* p, Eterm arg1, Eterm arg2, Eterm arg3, Uint* I); + +#if defined(_OSE_) || defined(VXWORKS) +static int init_done; +#endif + +void +init_emulator(void) +{ +#if defined(_OSE_) || defined(VXWORKS) + init_done = 0; +#endif + process_main(); +} + +/* + * On certain platforms, make sure that the main variables really are placed + * in registers. + */ + +#if defined(__GNUC__) && defined(sparc) && !defined(DEBUG) +# define REG_x0 asm("%l0") +# define REG_xregs asm("%l1") +# define REG_htop asm("%l2") +# define REG_stop asm("%l3") +# define REG_I asm("%l4") +# define REG_fcalls asm("%l5") +# define REG_tmp_arg1 asm("%l6") +# define REG_tmp_arg2 asm("%l7") +#else +# define REG_x0 +# define REG_xregs +# define REG_htop +# define REG_stop +# define REG_I +# define REG_fcalls +# define REG_tmp_arg1 +# define REG_tmp_arg2 +#endif + +/* + * process_main() is called twice: + * The first call performs some initialisation, including exporting + * the instructions' C labels to the loader. + * The second call starts execution of BEAM code. This call never returns. + */ +void process_main(void) +{ +#if !defined(_OSE_) && !defined(VXWORKS) + static int init_done = 0; +#endif + Process* c_p = NULL; + int reds_used; +#ifdef DEBUG + Eterm pid; +#endif + + /* + * X register zero; also called r(0) + */ + register Eterm x0 REG_x0 = NIL; + + /* Pointer to X registers: x(1)..x(N); reg[0] is used when doing GC, + * in all other cases x0 is used. + */ + register Eterm* reg REG_xregs = NULL; + + /* + * Top of heap (next free location); grows upwards. + */ + register Eterm* HTOP REG_htop = NULL; + + +#ifdef HYBRID + Eterm *g_htop; + Eterm *g_hend; +#endif + + /* Stack pointer. Grows downwards; points + * to last item pushed (normally a saved + * continuation pointer). + */ + register Eterm* E REG_stop = NULL; + + /* + * Pointer to next threaded instruction. + */ + register Eterm *I REG_I = NULL; + + /* Number of reductions left. This function + * returns to the scheduler when FCALLS reaches zero. + */ + register Sint FCALLS REG_fcalls = 0; + + /* + * Temporaries used for picking up arguments for instructions. + */ + register Eterm tmp_arg1 REG_tmp_arg1 = NIL; + register Eterm tmp_arg2 REG_tmp_arg2 = NIL; + Eterm tmp_big[2]; /* Temporary buffer for small bignums. */ + +#ifndef ERTS_SMP + static Eterm save_reg[ERTS_X_REGS_ALLOCATED]; + /* X registers -- not used directly, but + * through 'reg', because using it directly + * needs two instructions on a SPARC, + * while using it through reg needs only + * one. + */ + + /* + * Floating point registers. + */ + static FloatDef freg[MAX_REG]; +#else + /* X regisers and floating point registers are located in + * scheduler specific data. + */ + register FloatDef *freg; +#endif + + /* + * For keeping the negative old value of 'reds' when call saving is active. + */ + int neg_o_reds = 0; + + Eterm (*arith_func)(Process* p, Eterm* reg, Uint live); + +#ifndef NO_JUMP_TABLE + static void* opcodes[] = { DEFINE_OPCODES }; +#ifdef ERTS_OPCODE_COUNTER_SUPPORT + static void* counting_opcodes[] = { DEFINE_COUNTING_OPCODES }; +#endif +#else + int Go; +#endif + + Uint temp_bits; /* Temporary used by BsSkipBits2 & BsGetInteger2 */ + + ERL_BITS_DECLARE_STATEP; /* Has to be last declaration */ + + + /* + * Note: In this function, we attempt to place rarely executed code towards + * the end of the function, in the hope that the cache hit rate will be better. + * The initialization code is only run once, so it is at the very end. + * + * Note: c_p->arity must be set to reflect the number of useful terms in + * c_p->arg_reg before calling the scheduler. + */ + + if (!init_done) { + init_done = 1; + goto init_emulator; + } +#ifndef ERTS_SMP + reg = save_reg; /* XXX: probably wastes a register on x86 */ +#endif + c_p = NULL; + reds_used = 0; + goto do_schedule1; + + do_schedule: + reds_used = REDS_IN(c_p) - FCALLS; + do_schedule1: + PROCESS_MAIN_CHK_LOCKS(c_p); + ERTS_SMP_UNREQ_PROC_MAIN_LOCK(c_p); + c_p = schedule(c_p, reds_used); +#ifdef DEBUG + pid = c_p->id; +#endif + ERTS_SMP_REQ_PROC_MAIN_LOCK(c_p); + PROCESS_MAIN_CHK_LOCKS(c_p); +#ifdef ERTS_SMP + reg = c_p->scheduler_data->save_reg; + freg = c_p->scheduler_data->freg; +#endif + ERL_BITS_RELOAD_STATEP(c_p); + { + int reds; + Eterm* argp; + Eterm* next; + int i; + + argp = c_p->arg_reg; + for (i = c_p->arity - 1; i > 0; i--) { + reg[i] = argp[i]; + CHECK_TERM(reg[i]); + } + + /* + * We put the original reduction count in the process structure, to reduce + * the code size (referencing a field in a struct through a pointer stored + * in a register gives smaller code than referencing a global variable). + */ + + SET_I(c_p->i); + + reds = c_p->fcalls; + if (ERTS_PROC_GET_SAVED_CALLS_BUF(c_p) + && (c_p->trace_flags & F_SENSITIVE) == 0) { + neg_o_reds = -reds; + FCALLS = REDS_IN(c_p) = 0; + } else { + neg_o_reds = 0; + FCALLS = REDS_IN(c_p) = reds; + } + + next = (Eterm *) *I; + r(0) = c_p->arg_reg[0]; +#ifdef HARDDEBUG + if (c_p->arity > 0) { + CHECK_TERM(r(0)); + } +#endif + SWAPIN; + ASSERT(VALID_INSTR(next)); + Goto(next); + } + +#if defined(DEBUG) || defined(NO_JUMP_TABLE) + emulator_loop: +#endif + +#ifdef NO_JUMP_TABLE + switch (Go) { +#endif +#include "beam_hot.h" + +#define STORE_ARITH_RESULT(res) StoreBifResult(2, (res)); +#define ARITH_FUNC(name) erts_gc_##name + + OpCase(i_plus_jId): + { + Eterm result; + + if (is_both_small(tmp_arg1, tmp_arg2)) { + Sint i = signed_val(tmp_arg1) + signed_val(tmp_arg2); + ASSERT(MY_IS_SSMALL(i) == IS_SSMALL(i)); + if (MY_IS_SSMALL(i)) { + result = make_small(i); + STORE_ARITH_RESULT(result); + } + + } + arith_func = ARITH_FUNC(mixed_plus); + goto do_big_arith2; + } + + OpCase(i_minus_jId): + { + Eterm result; + + if (is_both_small(tmp_arg1, tmp_arg2)) { + Sint i = signed_val(tmp_arg1) - signed_val(tmp_arg2); + ASSERT(MY_IS_SSMALL(i) == IS_SSMALL(i)); + if (MY_IS_SSMALL(i)) { + result = make_small(i); + STORE_ARITH_RESULT(result); + } + } + arith_func = ARITH_FUNC(mixed_minus); + goto do_big_arith2; + } + + OpCase(i_is_lt_f): + if (CMP_GE(tmp_arg1, tmp_arg2)) { + ClauseFail(); + } + Next(1); + + OpCase(i_is_ge_f): + if (CMP_LT(tmp_arg1, tmp_arg2)) { + ClauseFail(); + } + Next(1); + + OpCase(i_is_eq_f): + if (CMP_NE(tmp_arg1, tmp_arg2)) { + ClauseFail(); + } + Next(1); + + OpCase(i_is_ne_f): + if (CMP_EQ(tmp_arg1, tmp_arg2)) { + ClauseFail(); + } + Next(1); + + OpCase(i_is_eq_exact_f): + if (!EQ(tmp_arg1, tmp_arg2)) { + ClauseFail(); + } + Next(1); + + OpCase(i_move_call_only_fcr): { + r(0) = Arg(1); + } + /* FALL THROUGH */ + OpCase(i_call_only_f): { + SET_I((Eterm *) Arg(0)); + Dispatch(); + } + + OpCase(i_move_call_last_fPcr): { + r(0) = Arg(2); + } + /* FALL THROUGH */ + OpCase(i_call_last_fP): { + RESTORE_CP(E); + E = ADD_BYTE_OFFSET(E, Arg(1)); + SET_I((Eterm *) Arg(0)); + Dispatch(); + } + + OpCase(i_move_call_crf): { + r(0) = Arg(0); + I++; + } + /* FALL THROUGH */ + OpCase(i_call_f): { + SET_CP(c_p, I+2); + SET_I((Eterm *) Arg(0)); + Dispatch(); + } + + OpCase(i_move_call_ext_last_ePcr): { + r(0) = Arg(2); + } + /* FALL THROUGH */ + OpCase(i_call_ext_last_eP): + RESTORE_CP(E); + E = ADD_BYTE_OFFSET(E, Arg(1)); + + /* + * Note: The pointer to the export entry is never NULL; if the module + * is not loaded, it points to code which will invoke the error handler + * (see lb_call_error_handler below). + */ + Dispatchx(); + + OpCase(i_move_call_ext_cre): { + r(0) = Arg(0); + I++; + } + /* FALL THROUGH */ + OpCase(i_call_ext_e): + SET_CP(c_p, I+2); + Dispatchx(); + + OpCase(i_move_call_ext_only_ecr): { + r(0) = Arg(1); + } + /* FALL THROUGH */ + OpCase(i_call_ext_only_e): + Dispatchx(); + + OpCase(init_y): { + Eterm* next; + + PreFetch(1, next); + make_blank(yb(Arg(0))); + NextPF(1, next); + } + + OpCase(i_trim_I): { + Eterm* next; + Uint words; + Uint cp; + + words = Arg(0); + cp = E[0]; + PreFetch(1, next); + E += words; + E[0] = cp; + NextPF(1, next); + } + + OpCase(return): { + SET_I(c_p->cp); + /* + * We must clear the CP to make sure that a stale value do not + * create a false module dependcy preventing code upgrading. + * It also means that we can use the CP in stack backtraces. + */ + c_p->cp = 0; + CHECK_TERM(r(0)); + Goto(*I); + } + + OpCase(test_heap_1_put_list_Iy): { + Eterm* next; + + PreFetch(2, next); + TestHeap(Arg(0), 1); + PutList(yb(Arg(1)), r(0), r(0), StoreSimpleDest); + CHECK_TERM(r(0)); + NextPF(2, next); + } + + OpCase(put_string_IId): + { + unsigned char* s; + int len; + Eterm result; + + len = Arg(0); /* Length. */ + result = NIL; + for (s = (unsigned char *) Arg(1); len > 0; s--, len--) { + PutList(make_small(*s), result, result, StoreSimpleDest); + } + StoreBifResult(2, result); + } + + /* + * Send is almost a standard call-BIF with two arguments, except for: + * 1) It cannot be traced. + * 2) There is no pointer to the send_2 function stored in + * the instruction. + */ + + OpCase(send): { + Eterm* next; + Eterm result; + + PRE_BIF_SWAPOUT(c_p); + c_p->fcalls = FCALLS - 1; + result = send_2(c_p, r(0), x(1)); + PreFetch(0, next); + POST_BIF_GC_SWAPIN(c_p, result, reg, 2); + FCALLS = c_p->fcalls; + if (is_value(result)) { + r(0) = result; + CHECK_TERM(r(0)); + NextPF(0, next); + } else if (c_p->freason == TRAP) { + SET_CP(c_p, I+1); + SET_I((Eterm *) c_p->def_arg_reg[3]); + SWAPIN; + r(0) = c_p->def_arg_reg[0]; + x(1) = c_p->def_arg_reg[1]; + Dispatch(); + } + goto find_func_info; + } + + OpCase(i_element_jssd): { + Eterm index; + Eterm tuple; + + /* + * Inlined version of element/2 for speed. + */ + GetArg2(1, index, tuple); + if (is_small(index) && is_tuple(tuple)) { + Eterm* tp = tuple_val(tuple); + + if ((signed_val(index) >= 1) && + (signed_val(index) <= arityval(*tp))) { + Eterm result = tp[signed_val(index)]; + StoreBifResult(3, result); + } + } + } + /* Fall through */ + + OpCase(badarg_j): + badarg: + c_p->freason = BADARG; + goto lb_Cl_error; + + OpCase(i_fast_element_jIsd): { + Eterm tuple; + + /* + * Inlined version of element/2 for even more speed. + * The first argument is an untagged integer >= 1. + * The second argument is guaranteed to be a register operand. + */ + GetArg1(2, tuple); + if (is_tuple(tuple)) { + Eterm* tp = tuple_val(tuple); + tmp_arg2 = Arg(1); + if (tmp_arg2 <= arityval(*tp)) { + Eterm result = tp[tmp_arg2]; + StoreBifResult(3, result); + } + } + goto badarg; + } + + OpCase(catch_yf): + c_p->catches++; + yb(Arg(0)) = Arg(1); + Next(2); + + OpCase(catch_end_y): { + c_p->catches--; + make_blank(yb(Arg(0))); + if (is_non_value(r(0))) { + if (x(1) == am_throw) { + r(0) = x(2); + } else { + if (x(1) == am_error) { + SWAPOUT; + x(2) = add_stacktrace(c_p, x(2), x(3)); + SWAPIN; + } + /* only x(2) is included in the rootset here */ + if (E - HTOP < 3 || c_p->mbuf) { /* Force GC in case add_stacktrace() + * created heap fragments */ + SWAPOUT; + PROCESS_MAIN_CHK_LOCKS(c_p); + FCALLS -= erts_garbage_collect(c_p, 3, reg+2, 1); + PROCESS_MAIN_CHK_LOCKS(c_p); + SWAPIN; + } + r(0) = TUPLE2(HTOP, am_EXIT, x(2)); + HTOP += 3; + } + } + CHECK_TERM(r(0)); + Next(1); + } + + OpCase(try_end_y): { + c_p->catches--; + make_blank(yb(Arg(0))); + if (is_non_value(r(0))) { + r(0) = x(1); + x(1) = x(2); + x(2) = x(3); + } + Next(1); + } + + /* + * Skeleton for receive statement: + * + * L1: <-------------------+ + * <-----------+ | + * | | + * loop_rec L2 ------+---+ | + * ... | | | + * remove_message | | | + * jump L3 | | | + * ... | | | + * loop_rec_end L1 --+ | | + * L2: <---------------+ | + * wait L1 -----------------+ or wait_timeout + * timeout + * + * L3: Code after receive... + * + * + */ + + /* + * Pick up the next message and place it in x(0). + * If no message, jump to a wait or wait_timeout instruction. + */ + OpCase(i_loop_rec_fr): + { + Eterm* next; + ErlMessage* msgp; + + loop_rec__: + + PROCESS_MAIN_CHK_LOCKS(c_p); + + msgp = PEEK_MESSAGE(c_p); + + if (!msgp) { +#ifdef ERTS_SMP + erts_smp_proc_lock(c_p, ERTS_PROC_LOCKS_MSG_RECEIVE); + /* Make sure messages wont pass exit signals... */ + if (ERTS_PROC_PENDING_EXIT(c_p)) { + erts_smp_proc_unlock(c_p, ERTS_PROC_LOCKS_MSG_RECEIVE); + SWAPOUT; + goto do_schedule; /* Will be rescheduled for exit */ + } + ERTS_SMP_MSGQ_MV_INQ2PRIVQ(c_p); + msgp = PEEK_MESSAGE(c_p); + if (msgp) + erts_smp_proc_unlock(c_p, ERTS_PROC_LOCKS_MSG_RECEIVE); + else { +#endif + SET_I((Eterm *) Arg(0)); + Goto(*I); /* Jump to a wait or wait_timeout instruction */ +#ifdef ERTS_SMP + } +#endif + } + ErtsMoveMsgAttachmentIntoProc(msgp, c_p, E, HTOP, FCALLS, + { + SWAPOUT; + reg[0] = r(0); + PROCESS_MAIN_CHK_LOCKS(c_p); + }, + { + PROCESS_MAIN_CHK_LOCKS(c_p); + r(0) = reg[0]; + SWAPIN; + }); + if (is_non_value(ERL_MESSAGE_TERM(msgp))) { + /* + * A corrupt distribution message that we weren't able to decode; + * remove it... + */ + ASSERT(!msgp->data.attached); + UNLINK_MESSAGE(c_p, msgp); + free_message(msgp); + goto loop_rec__; + } + PreFetch(1, next); + r(0) = ERL_MESSAGE_TERM(msgp); + NextPF(1, next); + } + + /* + * Remove a (matched) message from the message queue. + */ + OpCase(remove_message): { + Eterm* next; + ErlMessage* msgp; + + PROCESS_MAIN_CHK_LOCKS(c_p); + + PreFetch(0, next); + msgp = PEEK_MESSAGE(c_p); + + if (ERTS_PROC_GET_SAVED_CALLS_BUF(c_p)) { + save_calls(c_p, &exp_receive); + } + if (ERL_MESSAGE_TOKEN(msgp) == NIL) { + SEQ_TRACE_TOKEN(c_p) = NIL; + } else if (ERL_MESSAGE_TOKEN(msgp) != am_undefined) { + Eterm msg; + SEQ_TRACE_TOKEN(c_p) = ERL_MESSAGE_TOKEN(msgp); + ASSERT(is_tuple(SEQ_TRACE_TOKEN(c_p))); + ASSERT(SEQ_TRACE_TOKEN_ARITY(c_p) == 5); + ASSERT(is_small(SEQ_TRACE_TOKEN_SERIAL(c_p))); + ASSERT(is_small(SEQ_TRACE_TOKEN_LASTCNT(c_p))); + ASSERT(is_small(SEQ_TRACE_TOKEN_FLAGS(c_p))); + ASSERT(is_pid(SEQ_TRACE_TOKEN_SENDER(c_p))); + c_p->seq_trace_lastcnt = unsigned_val(SEQ_TRACE_TOKEN_SERIAL(c_p)); + if (c_p->seq_trace_clock < unsigned_val(SEQ_TRACE_TOKEN_SERIAL(c_p))) { + c_p->seq_trace_clock = unsigned_val(SEQ_TRACE_TOKEN_SERIAL(c_p)); + } + msg = ERL_MESSAGE_TERM(msgp); + seq_trace_output(SEQ_TRACE_TOKEN(c_p), msg, SEQ_TRACE_RECEIVE, + c_p->id, c_p); + } + UNLINK_MESSAGE(c_p, msgp); + JOIN_MESSAGE(c_p); + CANCEL_TIMER(c_p); + free_message(msgp); + + PROCESS_MAIN_CHK_LOCKS(c_p); + + NextPF(0, next); + } + + /* + * Advance the save pointer to the next message (the current + * message didn't match), then jump to the loop_rec instruction. + */ + OpCase(loop_rec_end_f): { + SET_I((Eterm *) Arg(0)); + SAVE_MESSAGE(c_p); + goto loop_rec__; + } + /* + * Prepare to wait for a message or a timeout, whichever occurs first. + * + * Note: In order to keep the compatibility between 32 and 64 bits + * emulators, only timeout values that can be represented in 32 bits + * (unsigned) or less are allowed. + */ + + + OpCase(i_wait_timeout_fs): { + erts_smp_proc_lock(c_p, ERTS_PROC_LOCKS_MSG_RECEIVE); + + /* Fall through */ + } + OpCase(i_wait_timeout_locked_fs): { + Eterm timeout_value; + + /* + * If we have already set the timer, we must NOT set it again. Therefore, + * we must test the F_INSLPQUEUE flag as well as the F_TIMO flag. + */ + if (c_p->flags & (F_INSLPQUEUE | F_TIMO)) { + goto wait2; + } + GetArg1(1, timeout_value); + if (timeout_value != make_small(0)) { +#if !defined(ARCH_64) + Uint time_val; +#endif + + if (is_small(timeout_value) && signed_val(timeout_value) > 0 && +#if defined(ARCH_64) + ((unsigned_val(timeout_value) >> 32) == 0) +#else + 1 +#endif + ) { + /* + * The timer routiner will set c_p->i to the value in + * c_p->def_arg_reg[0]. Note that it is safe to use this + * location because there are no living x registers in + * a receive statement. + */ + c_p->def_arg_reg[0] = (Eterm) (I+3); + set_timer(c_p, unsigned_val(timeout_value)); + } else if (timeout_value == am_infinity) { + c_p->flags |= F_TIMO; +#if !defined(ARCH_64) + } else if (term_to_Uint(timeout_value, &time_val)) { + c_p->def_arg_reg[0] = (Eterm) (I+3); + set_timer(c_p, time_val); +#endif + } else { /* Wrong time */ + OpCase(i_wait_error_locked): { + erts_smp_proc_unlock(c_p, ERTS_PROC_LOCKS_MSG_RECEIVE); + /* Fall through */ + } + OpCase(i_wait_error): { + c_p->freason = EXC_TIMEOUT_VALUE; + goto find_func_info; + } + } + + /* + * Prepare to wait indefinitely for a new message to arrive + * (or the time set above if falling through from above). + * + * When a new message arrives, control will be transferred + * the loop_rec instruction (at label L1). In case of + * of timeout, control will be transferred to the timeout + * instruction following the wait_timeout instruction. + */ + + OpCase(wait_locked_f): + OpCase(wait_f): + + wait2: { + ASSERT(!ERTS_PROC_IS_EXITING(c_p)); + c_p->i = (Eterm *) Arg(0); /* L1 */ + SWAPOUT; + c_p->arity = 0; + c_p->status = P_WAITING; + erts_smp_proc_unlock(c_p, ERTS_PROC_LOCKS_MSG_RECEIVE); + c_p->current = NULL; + goto do_schedule; + } + OpCase(wait_unlocked_f): { + erts_smp_proc_lock(c_p, ERTS_PROC_LOCKS_MSG_RECEIVE); + goto wait2; + } + } + erts_smp_proc_unlock(c_p, ERTS_PROC_LOCKS_MSG_RECEIVE); + Next(2); + } + + OpCase(i_wait_timeout_fI): { + erts_smp_proc_lock(c_p, ERTS_PROC_LOCKS_MSG_RECEIVE); + } + + OpCase(i_wait_timeout_locked_fI): + { + /* + * If we have already set the timer, we must NOT set it again. Therefore, + * we must test the F_INSLPQUEUE flag as well as the F_TIMO flag. + */ + if ((c_p->flags & (F_INSLPQUEUE | F_TIMO)) == 0) { + c_p->def_arg_reg[0] = (Eterm) (I+3); + set_timer(c_p, Arg(1)); + } + goto wait2; + } + + /* + * A timeout has occurred. Reset the save pointer so that the next + * receive statement will examine the first message first. + */ + OpCase(timeout_locked): { + erts_smp_proc_unlock(c_p, ERTS_PROC_LOCKS_MSG_RECEIVE); + } + + OpCase(timeout): { + Eterm* next; + + PreFetch(0, next); + if (IS_TRACED_FL(c_p, F_TRACE_RECEIVE)) { + trace_receive(c_p, am_timeout); + } + if (ERTS_PROC_GET_SAVED_CALLS_BUF(c_p)) { + save_calls(c_p, &exp_timeout); + } + c_p->flags &= ~F_TIMO; + JOIN_MESSAGE(c_p); + NextPF(0, next); + } + + OpCase(i_select_val_sfI): + GetArg1(0, tmp_arg1); + + do_binary_search: + { + struct Pairs { + Eterm val; + Eterm* addr; + }; + struct Pairs* low; + struct Pairs* high; + struct Pairs* mid; + int bdiff; /* int not long because the arrays aren't that large */ + + low = (struct Pairs *) &Arg(3); + high = low + Arg(2); + + /* The pointer subtraction (high-low) below must produce + * a signed result, because high could be < low. That + * requires the compiler to insert quite a bit of code. + * + * However, high will be > low so the result will be + * positive. We can use that knowledge to optimise the + * entire sequence, from the initial comparison to the + * computation of mid. + * + * -- Mikael Pettersson, Acumem AB + * + * Original loop control code: + * + * while (low < high) { + * mid = low + (high-low) / 2; + * + */ + while ((bdiff = (int)((char*)high - (char*)low)) > 0) { + unsigned int boffset = ((unsigned int)bdiff >> 1) & ~(sizeof(struct Pairs)-1); + + mid = (struct Pairs*)((char*)low + boffset); + if (tmp_arg1 < mid->val) { + high = mid; + } else if (tmp_arg1 > mid->val) { + low = mid + 1; + } else { + SET_I(mid->addr); + Goto(*I); + } + } + SET_I((Eterm *) Arg(1)); + Goto(*I); + } + + OpCase(i_jump_on_val_zero_sfI): + { + Eterm index; + + GetArg1(0, index); + if (is_small(index)) { + index = signed_val(index); + if (index < Arg(2)) { + SET_I((Eterm *) (&Arg(3))[index]); + Goto(*I); + } + } + SET_I((Eterm *) Arg(1)); + Goto(*I); + } + + OpCase(i_jump_on_val_sfII): + { + Eterm index; + + GetArg1(0, index); + if (is_small(index)) { + index = (Uint) (signed_val(index) - Arg(3)); + if (index < Arg(2)) { + SET_I((Eterm *) (&Arg(4))[index]); + Goto(*I); + } + } + SET_I((Eterm *) Arg(1)); + Goto(*I); + } + + /* + * All guards with zero arguments have special instructions: + * self/0 + * node/0 + * + * All other guard BIFs take one or two arguments. + */ + + /* + * Guard BIF in head. On failure, ignore the error and jump + * to the code for the next clause. We don't support tracing + * of guard BIFs. + */ + + OpCase(bif1_fbsd): + { + Eterm (*bf)(Process*, Eterm); + Eterm arg; + Eterm result; + + GetArg1(2, arg); + bf = (BifFunction) Arg(1); + c_p->fcalls = FCALLS; + PROCESS_MAIN_CHK_LOCKS(c_p); + ASSERT(!ERTS_PROC_IS_EXITING(c_p)); + result = (*bf)(c_p, arg); + ASSERT(!ERTS_PROC_IS_EXITING(c_p) || is_non_value(result)); + PROCESS_MAIN_CHK_LOCKS(c_p); + ERTS_HOLE_CHECK(c_p); + FCALLS = c_p->fcalls; + if (is_value(result)) { + StoreBifResult(3, result); + } + SET_I((Eterm *) Arg(0)); + Goto(*I); + } + + /* + * Guard BIF in body. It can fail like any BIF. No trace support. + */ + + OpCase(bif1_body_bsd): + { + Eterm (*bf)(Process*, Eterm); + + Eterm arg; + Eterm result; + + GetArg1(1, arg); + bf = (BifFunction) Arg(0); + c_p->fcalls = FCALLS; + PROCESS_MAIN_CHK_LOCKS(c_p); + ASSERT(!ERTS_PROC_IS_EXITING(c_p)); + result = (*bf)(c_p, arg); + ASSERT(!ERTS_PROC_IS_EXITING(c_p) || is_non_value(result)); + PROCESS_MAIN_CHK_LOCKS(c_p); + ERTS_HOLE_CHECK(c_p); + FCALLS = c_p->fcalls; + if (is_value(result)) { + StoreBifResult(2, result); + } + reg[0] = arg; + SWAPOUT; + I = handle_error(c_p, I, reg, bf); + goto post_error_handling; + } + + OpCase(i_gc_bif1_jIsId): + { + typedef Eterm (*GcBifFunction)(Process*, Eterm*, Uint); + GcBifFunction bf; + Eterm arg; + Eterm result; + Uint live = Arg(3); + + GetArg1(2, arg); + reg[0] = r(0); + reg[live] = arg; + bf = (GcBifFunction) Arg(1); + c_p->fcalls = FCALLS; + SWAPOUT; + PROCESS_MAIN_CHK_LOCKS(c_p); + ERTS_SMP_UNREQ_PROC_MAIN_LOCK(c_p); + result = (*bf)(c_p, reg, live); + ERTS_SMP_REQ_PROC_MAIN_LOCK(c_p); + PROCESS_MAIN_CHK_LOCKS(c_p); + SWAPIN; + r(0) = reg[0]; + ERTS_HOLE_CHECK(c_p); + FCALLS = c_p->fcalls; + if (is_value(result)) { + StoreBifResult(4, result); + } + if (Arg(0) != 0) { + SET_I((Eterm *) Arg(0)); + Goto(*I); + } + reg[0] = arg; + I = handle_error(c_p, I, reg, translate_gc_bif((void *) bf)); + goto post_error_handling; + } + + /* + * Guards bifs and, or, xor in guards. + */ + OpCase(i_bif2_fbd): + { + Eterm (*bf)(Process*, Eterm, Eterm); + Eterm result; + + bf = (BifFunction) Arg(1); + c_p->fcalls = FCALLS; + PROCESS_MAIN_CHK_LOCKS(c_p); + ASSERT(!ERTS_PROC_IS_EXITING(c_p)); + result = (*bf)(c_p, tmp_arg1, tmp_arg2); + ASSERT(!ERTS_PROC_IS_EXITING(c_p) || is_non_value(result)); + PROCESS_MAIN_CHK_LOCKS(c_p); + ERTS_HOLE_CHECK(c_p); + FCALLS = c_p->fcalls; + if (is_value(result)) { + StoreBifResult(2, result); + } + SET_I((Eterm *) Arg(0)); + Goto(*I); + } + + /* + * Guards bifs and, or, xor, relational operators in body. + */ + OpCase(i_bif2_body_bd): + { + Eterm (*bf)(Process*, Eterm, Eterm); + Eterm result; + + bf = (BifFunction) Arg(0); + PROCESS_MAIN_CHK_LOCKS(c_p); + ASSERT(!ERTS_PROC_IS_EXITING(c_p)); + result = (*bf)(c_p, tmp_arg1, tmp_arg2); + ASSERT(!ERTS_PROC_IS_EXITING(c_p) || is_non_value(result)); + PROCESS_MAIN_CHK_LOCKS(c_p); + ERTS_HOLE_CHECK(c_p); + if (is_value(result)) { + ASSERT(!is_CP(result)); + StoreBifResult(1, result); + } + reg[0] = tmp_arg1; + reg[1] = tmp_arg2; + SWAPOUT; + I = handle_error(c_p, I, reg, bf); + goto post_error_handling; + } + + /* + * The most general BIF call. The BIF may build any amount of data + * on the heap. The result is always returned in r(0). + */ + OpCase(call_bif0_e): + { + Eterm (*bf)(Process*, Uint*) = GET_BIF_ADDRESS(Arg(0)); + + PRE_BIF_SWAPOUT(c_p); + c_p->fcalls = FCALLS - 1; + if (FCALLS <= 0) { + save_calls(c_p, (Export *) Arg(0)); + } + + ASSERT(!ERTS_PROC_IS_EXITING(c_p)); + r(0) = (*bf)(c_p, I); + ASSERT(!ERTS_PROC_IS_EXITING(c_p) || is_non_value(r(0))); + ERTS_HOLE_CHECK(c_p); + POST_BIF_GC_SWAPIN_0(c_p, r(0)); + FCALLS = c_p->fcalls; + if (is_value(r(0))) { + CHECK_TERM(r(0)); + Next(1); + } + else if (c_p->freason == TRAP) { + goto call_bif_trap3; + } + + /* + * Error handling. SWAPOUT is not needed because it was done above. + */ + ASSERT(c_p->stop == E); + reg[0] = r(0); + I = handle_error(c_p, I, reg, bf); + goto post_error_handling; + } + + OpCase(call_bif1_e): + { + Eterm (*bf)(Process*, Eterm, Uint*) = GET_BIF_ADDRESS(Arg(0)); + Eterm result; + Eterm* next; + + c_p->fcalls = FCALLS - 1; + if (FCALLS <= 0) { + save_calls(c_p, (Export *) Arg(0)); + } + PreFetch(1, next); + PRE_BIF_SWAPOUT(c_p); + ASSERT(!ERTS_PROC_IS_EXITING(c_p)); + result = (*bf)(c_p, r(0), I); + ASSERT(!ERTS_PROC_IS_EXITING(c_p) || is_non_value(result)); + ERTS_HOLE_CHECK(c_p); + POST_BIF_GC_SWAPIN(c_p, result, reg, 1); + FCALLS = c_p->fcalls; + if (is_value(result)) { + r(0) = result; + CHECK_TERM(r(0)); + NextPF(1, next); + } else if (c_p->freason == TRAP) { + goto call_bif_trap3; + } + + /* + * Error handling. SWAPOUT is not needed because it was done above. + */ + ASSERT(c_p->stop == E); + reg[0] = r(0); + I = handle_error(c_p, I, reg, bf); + goto post_error_handling; + } + + OpCase(call_bif2_e): + { + Eterm (*bf)(Process*, Eterm, Eterm, Uint*) = GET_BIF_ADDRESS(Arg(0)); + Eterm result; + Eterm* next; + + PRE_BIF_SWAPOUT(c_p); + c_p->fcalls = FCALLS - 1; + if (FCALLS <= 0) { + save_calls(c_p, (Export *) Arg(0)); + } + PreFetch(1, next); + CHECK_TERM(r(0)); + CHECK_TERM(x(1)); + ASSERT(!ERTS_PROC_IS_EXITING(c_p)); + result = (*bf)(c_p, r(0), x(1), I); + ASSERT(!ERTS_PROC_IS_EXITING(c_p) || is_non_value(result)); + ERTS_HOLE_CHECK(c_p); + POST_BIF_GC_SWAPIN(c_p, result, reg, 2); + FCALLS = c_p->fcalls; + if (is_value(result)) { + r(0) = result; + CHECK_TERM(r(0)); + NextPF(1, next); + } else if (c_p->freason == TRAP) { + goto call_bif_trap3; + } + + /* + * Error handling. SWAPOUT is not needed because it was done above. + */ + ASSERT(c_p->stop == E); + reg[0] = r(0); + I = handle_error(c_p, I, reg, bf); + goto post_error_handling; + } + + OpCase(call_bif3_e): + { + Eterm (*bf)(Process*, Eterm, Eterm, Eterm, Uint*) = GET_BIF_ADDRESS(Arg(0)); + Eterm result; + Eterm* next; + + PRE_BIF_SWAPOUT(c_p); + c_p->fcalls = FCALLS - 1; + if (FCALLS <= 0) { + save_calls(c_p, (Export *) Arg(0)); + } + PreFetch(1, next); + ASSERT(!ERTS_PROC_IS_EXITING(c_p)); + result = (*bf)(c_p, r(0), x(1), x(2), I); + ASSERT(!ERTS_PROC_IS_EXITING(c_p) || is_non_value(result)); + ERTS_HOLE_CHECK(c_p); + POST_BIF_GC_SWAPIN(c_p, result, reg, 3); + FCALLS = c_p->fcalls; + if (is_value(result)) { + r(0) = result; + CHECK_TERM(r(0)); + NextPF(1, next); + } else if (c_p->freason == TRAP) { + call_bif_trap3: + SET_CP(c_p, I+2); + SET_I((Eterm *)c_p->def_arg_reg[3]); + SWAPIN; + r(0) = c_p->def_arg_reg[0]; + x(1) = c_p->def_arg_reg[1]; + x(2) = c_p->def_arg_reg[2]; + Dispatch(); + } + + /* + * Error handling. SWAPOUT is not needed because it was done above. + */ + ASSERT(c_p->stop == E); + reg[0] = r(0); + I = handle_error(c_p, I, reg, bf); + goto post_error_handling; + } + + /* + * Arithmetic operations. + */ + + OpCase(i_times_jId): + { + arith_func = ARITH_FUNC(mixed_times); + goto do_big_arith2; + } + + OpCase(i_m_div_jId): + { + arith_func = ARITH_FUNC(mixed_div); + goto do_big_arith2; + } + + OpCase(i_int_div_jId): + { + Eterm result; + + if (tmp_arg2 == SMALL_ZERO) { + goto badarith; + } else if (is_both_small(tmp_arg1, tmp_arg2)) { + Sint ires = signed_val(tmp_arg1) / signed_val(tmp_arg2); + if (MY_IS_SSMALL(ires)) { + result = make_small(ires); + STORE_ARITH_RESULT(result); + } + } + arith_func = ARITH_FUNC(int_div); + goto do_big_arith2; + } + + OpCase(i_rem_jId): + { + Eterm result; + + if (tmp_arg2 == SMALL_ZERO) { + goto badarith; + } else if (is_both_small(tmp_arg1, tmp_arg2)) { + result = make_small(signed_val(tmp_arg1) % signed_val(tmp_arg2)); + STORE_ARITH_RESULT(result); + } else { + arith_func = ARITH_FUNC(int_rem); + goto do_big_arith2; + } + } + + OpCase(i_band_jId): + { + Eterm result; + + if (is_both_small(tmp_arg1, tmp_arg2)) { + /* + * No need to untag -- TAG & TAG == TAG. + */ + result = tmp_arg1 & tmp_arg2; + STORE_ARITH_RESULT(result); + } + arith_func = ARITH_FUNC(band); + goto do_big_arith2; + } + + do_big_arith2: + { + Eterm result; + Uint live = Arg(1); + + SWAPOUT; + reg[0] = r(0); + reg[live] = tmp_arg1; + reg[live+1] = tmp_arg2; + result = arith_func(c_p, reg, live); + r(0) = reg[0]; + SWAPIN; + ERTS_HOLE_CHECK(c_p); + if (is_value(result)) { + STORE_ARITH_RESULT(result); + } + goto lb_Cl_error; + } + + /* + * An error occured in an arithmetic operation or test that could + * appear either in a head or in a body. + * In a head, execution should continue at failure address in Arg(0). + * In a body, Arg(0) == 0 and an exception should be raised. + */ + lb_Cl_error: { + if (Arg(0) != 0) { + OpCase(jump_f): { + SET_I((Eterm *) Arg(0)); + Goto(*I); + } + } + ASSERT(c_p->freason != BADMATCH || is_value(c_p->fvalue)); + goto find_func_info; + } + + OpCase(i_bor_jId): + { + Eterm result; + + if (is_both_small(tmp_arg1, tmp_arg2)) { + /* + * No need to untag -- TAG | TAG == TAG. + */ + result = tmp_arg1 | tmp_arg2; + STORE_ARITH_RESULT(result); + } + arith_func = ARITH_FUNC(bor); + goto do_big_arith2; + } + + OpCase(i_bxor_jId): + { + Eterm result; + + if (is_both_small(tmp_arg1, tmp_arg2)) { + /* + * We could extract the tag from one argument, but a tag extraction + * could mean a shift. Therefore, play it safe here. + */ + result = make_small(signed_val(tmp_arg1) ^ signed_val(tmp_arg2)); + STORE_ARITH_RESULT(result); + } + arith_func = ARITH_FUNC(bxor); + goto do_big_arith2; + } + + { + Sint i; + Sint ires; + Eterm* bigp; + + OpCase(i_bsr_jId): + if (is_small(tmp_arg2)) { + i = -signed_val(tmp_arg2); + if (is_small(tmp_arg1)) { + goto small_shift; + } else if (is_big(tmp_arg1)) { + if (i == 0) { + StoreBifResult(2, tmp_arg1); + } + goto big_shift; + } + } else if (is_big(tmp_arg2)) { + /* + * N bsr NegativeBigNum == N bsl MAX_SMALL + * N bsr PositiveBigNum == N bsl MIN_SMALL + */ + tmp_arg2 = make_small(bignum_header_is_neg(*big_val(tmp_arg2)) ? + MAX_SMALL : MIN_SMALL); + goto do_bsl; + } + goto badarith; + + OpCase(i_bsl_jId): + do_bsl: + if (is_small(tmp_arg2)) { + i = signed_val(tmp_arg2); + + if (is_small(tmp_arg1)) { + small_shift: + ires = signed_val(tmp_arg1); + + if (i == 0 || ires == 0) { + StoreBifResult(2, tmp_arg1); + } else if (i < 0) { /* Right shift */ + i = -i; + if (i >= SMALL_BITS-1) { + tmp_arg1 = (ires < 0) ? SMALL_MINUS_ONE : SMALL_ZERO; + } else { + tmp_arg1 = make_small(ires >> i); + } + StoreBifResult(2, tmp_arg1); + } else if (i < SMALL_BITS-1) { /* Left shift */ + if ((ires > 0 && ((~(Uint)0 << ((SMALL_BITS-1)-i)) & ires) == 0) || + ((~(Uint)0 << ((SMALL_BITS-1)-i)) & ~ires) == 0) { + tmp_arg1 = make_small(ires << i); + StoreBifResult(2, tmp_arg1); + } + } + tmp_arg1 = small_to_big(ires, tmp_big); + + big_shift: + if (i > 0) { /* Left shift. */ + ires = big_size(tmp_arg1) + (i / D_EXP); + } else { /* Right shift. */ + ires = big_size(tmp_arg1); + if (ires <= (-i / D_EXP)) + ires = 3; /* ??? */ + else + ires -= (-i / D_EXP); + } + { + ires = BIG_NEED_SIZE(ires+1); + /* + * Slightly conservative check the size to avoid + * allocating huge amounts of memory for bignums that + * clearly would overflow the arity in the header + * word. + */ + if (ires-8 > BIG_ARITY_MAX) { + c_p->freason = SYSTEM_LIMIT; + goto lb_Cl_error; + } + TestHeapPreserve(ires+1, Arg(1), tmp_arg1); + bigp = HTOP; + tmp_arg1 = big_lshift(tmp_arg1, i, bigp); + if (is_big(tmp_arg1)) { + HTOP += bignum_header_arity(*HTOP) + 1; + } + if (is_nil(tmp_arg1)) { + /* + * This result must have been only slight larger + * than allowed since it wasn't caught by the + * previous test. + */ + c_p->freason = SYSTEM_LIMIT; + goto lb_Cl_error; + } + ERTS_HOLE_CHECK(c_p); + StoreBifResult(2, tmp_arg1); + } + } else if (is_big(tmp_arg1)) { + if (i == 0) { + StoreBifResult(2, tmp_arg1); + } + goto big_shift; + } + } else if (is_big(tmp_arg2)) { + if (bignum_header_is_neg(*big_val(tmp_arg2))) { + /* + * N bsl NegativeBigNum is either 0 or -1, depending on + * the sign of N. Since we don't believe this case + * is common, do the calculation with the minimum + * amount of code. + */ + tmp_arg2 = make_small(MIN_SMALL); + goto do_bsl; + } else if (is_small(tmp_arg1) || is_big(tmp_arg1)) { + /* + * N bsl PositiveBigNum is too large to represent. + */ + c_p->freason = SYSTEM_LIMIT; + goto lb_Cl_error; + } + /* Fall through if the left argument is not an integer. */ + } + /* + * One or more non-integer arguments. + */ + goto badarith; + } + + OpCase(i_int_bnot_jsId): + { + GetArg1(1, tmp_arg1); + if (is_small(tmp_arg1)) { + tmp_arg1 = make_small(~signed_val(tmp_arg1)); + } else { + Uint live = Arg(2); + SWAPOUT; + reg[0] = r(0); + reg[live] = tmp_arg1; + tmp_arg1 = erts_gc_bnot(c_p, reg, live); + r(0) = reg[0]; + SWAPIN; + ERTS_HOLE_CHECK(c_p); + if (is_nil(tmp_arg1)) { + goto lb_Cl_error; + } + } + StoreBifResult(3, tmp_arg1); + } + + badarith: + c_p->freason = BADARITH; + goto lb_Cl_error; + + OpCase(i_apply): { + Eterm* next; + SWAPOUT; + next = apply(c_p, r(0), x(1), x(2), reg); + SWAPIN; + if (next != NULL) { + r(0) = reg[0]; + SET_CP(c_p, I+1); + SET_I(next); + Dispatch(); + } + I = handle_error(c_p, I, reg, apply_3); + goto post_error_handling; + } + + OpCase(i_apply_last_P): { + Eterm* next; + SWAPOUT; + next = apply(c_p, r(0), x(1), x(2), reg); + SWAPIN; + if (next != NULL) { + r(0) = reg[0]; + SET_CP(c_p, (Eterm *) E[0]); + E = ADD_BYTE_OFFSET(E, Arg(0)); + SET_I(next); + Dispatch(); + } + I = handle_error(c_p, I, reg, apply_3); + goto post_error_handling; + } + + OpCase(i_apply_only): { + Eterm* next; + SWAPOUT; + next = apply(c_p, r(0), x(1), x(2), reg); + SWAPIN; + if (next != NULL) { + r(0) = reg[0]; + SET_I(next); + Dispatch(); + } + I = handle_error(c_p, I, reg, apply_3); + goto post_error_handling; + } + + OpCase(apply_I): { + Eterm* next; + + reg[0] = r(0); + SWAPOUT; + next = fixed_apply(c_p, reg, Arg(0)); + SWAPIN; + if (next != NULL) { + r(0) = reg[0]; + SET_CP(c_p, I+2); + SET_I(next); + Dispatch(); + } + I = handle_error(c_p, I, reg, apply_3); + goto post_error_handling; + } + + OpCase(apply_last_IP): { + Eterm* next; + + reg[0] = r(0); + SWAPOUT; + next = fixed_apply(c_p, reg, Arg(0)); + SWAPIN; + if (next != NULL) { + r(0) = reg[0]; + SET_CP(c_p, (Eterm *) E[0]); + E = ADD_BYTE_OFFSET(E, Arg(1)); + SET_I(next); + Dispatch(); + } + I = handle_error(c_p, I, reg, apply_3); + goto post_error_handling; + } + + OpCase(i_apply_fun): { + Eterm* next; + + SWAPOUT; + next = apply_fun(c_p, r(0), x(1), reg); + SWAPIN; + if (next != NULL) { + r(0) = reg[0]; + SET_CP(c_p, I+1); + SET_I(next); + Dispatchfun(); + } + goto find_func_info; + } + + OpCase(i_apply_fun_last_P): { + Eterm* next; + + SWAPOUT; + next = apply_fun(c_p, r(0), x(1), reg); + SWAPIN; + if (next != NULL) { + r(0) = reg[0]; + SET_CP(c_p, (Eterm *) E[0]); + E = ADD_BYTE_OFFSET(E, Arg(0)); + SET_I(next); + Dispatchfun(); + } + goto find_func_info; + } + + OpCase(i_apply_fun_only): { + Eterm* next; + + SWAPOUT; + next = apply_fun(c_p, r(0), x(1), reg); + SWAPIN; + if (next != NULL) { + r(0) = reg[0]; + SET_I(next); + Dispatchfun(); + } + goto find_func_info; + } + + OpCase(i_call_fun_I): { + Eterm* next; + + SWAPOUT; + reg[0] = r(0); + next = call_fun(c_p, Arg(0), reg, THE_NON_VALUE); + SWAPIN; + if (next != NULL) { + r(0) = reg[0]; + SET_CP(c_p, I+2); + SET_I(next); + Dispatchfun(); + } + goto find_func_info; + } + + OpCase(i_call_fun_last_IP): { + Eterm* next; + + SWAPOUT; + reg[0] = r(0); + next = call_fun(c_p, Arg(0), reg, THE_NON_VALUE); + SWAPIN; + if (next != NULL) { + r(0) = reg[0]; + SET_CP(c_p, (Eterm *) E[0]); + E = ADD_BYTE_OFFSET(E, Arg(1)); + SET_I(next); + Dispatchfun(); + } + goto find_func_info; + } + +#ifdef DEBUG + /* + * Set a breakpoint here to get control just after a call instruction. + * I points to the first instruction in the called function. + * + * In gdb, use 'call dis(I-5, 1)' to show the name of the function. + */ + do_dispatch: + DispatchMacro(); + + do_dispatchx: + DispatchMacrox(); + + do_dispatchfun: + DispatchMacroFun(); + +#endif + + /* + * Jumped to from the Dispatch() macro when the reductions are used up. + * + * Since the I register points just beyond the FuncBegin instruction, we + * can get the module, function, and arity for the function being + * called from I[-3], I[-2], and I[-1] respectively. + */ + context_switch_fun: + c_p->arity = I[-1] + 1; + goto context_switch2; + + context_switch: + c_p->arity = I[-1]; + + context_switch2: /* Entry for fun calls. */ + c_p->current = I-3; /* Pointer to Mod, Func, Arity */ + + { + Eterm* argp; + int i; + + /* + * Make sure that there is enough room for the argument registers to be saved. + */ + if (c_p->arity > c_p->max_arg_reg) { + /* + * Yes, this is an expensive operation, but you only pay it the first + * time you call a function with more than 6 arguments which is + * scheduled out. This is better than paying for 26 words of wasted + * space for most processes which never call functions with more than + * 6 arguments. + */ + Uint size = c_p->arity * sizeof(c_p->arg_reg[0]); + if (c_p->arg_reg != c_p->def_arg_reg) { + c_p->arg_reg = (Eterm *) erts_realloc(ERTS_ALC_T_ARG_REG, + (void *) c_p->arg_reg, + size); + } else { + c_p->arg_reg = (Eterm *) erts_alloc(ERTS_ALC_T_ARG_REG, size); + } + c_p->max_arg_reg = c_p->arity; + } + + /* + * Since REDS_IN(c_p) is stored in the save area (c_p->arg_reg) we must read it + * now before saving registers. + * + * The '+ 1' compensates for the last increment which was not done + * (beacuse the code for the Dispatch() macro becomes shorter that way). + */ + + reds_used = REDS_IN(c_p) - FCALLS + 1; + + /* + * Save the argument registers and everything else. + */ + + argp = c_p->arg_reg; + for (i = c_p->arity - 1; i > 0; i--) { + argp[i] = reg[i]; + } + c_p->arg_reg[0] = r(0); + SWAPOUT; + c_p->i = I; + erts_smp_proc_lock(c_p, ERTS_PROC_LOCK_STATUS); + if (c_p->status != P_SUSPENDED) + erts_add_to_runq(c_p); + erts_smp_proc_unlock(c_p, ERTS_PROC_LOCK_STATUS); + goto do_schedule1; + } + + OpCase(i_select_tuple_arity_sfI): + { + GetArg1(0, tmp_arg1); + + if (is_tuple(tmp_arg1)) { + tmp_arg1 = *tuple_val(tmp_arg1); + goto do_binary_search; + } + SET_I((Eterm *) Arg(1)); + Goto(*I); + } + + OpCase(i_select_big_sf): + { + Eterm* bigp; + Uint arity; + Eterm* given; + Uint given_arity; + Uint given_size; + + GetArg1(0, tmp_arg1); + if (is_big(tmp_arg1)) { + + /* + * The loader has sorted the bignumbers in descending order + * on the arity word. Therefore, we know that the search + * has failed as soon as we encounter an arity word less than + * the arity word of the given number. There is a zero word + * (less than any valid arity word) stored after the last bignumber. + */ + + given = big_val(tmp_arg1); + given_arity = given[0]; + given_size = thing_arityval(given_arity); + bigp = &Arg(2); + while ((arity = bigp[0]) > given_arity) { + bigp += thing_arityval(arity) + 2; + } + while (bigp[0] == given_arity) { + if (memcmp(bigp+1, given+1, sizeof(Eterm)*given_size) == 0) { + SET_I((Eterm *) bigp[given_size+1]); + Goto(*I); + } + bigp += thing_arityval(arity) + 2; + } + } + + /* + * Failed. + */ + + SET_I((Eterm *) Arg(1)); + Goto(*I); + } + +#ifdef ARCH_64 + OpCase(i_select_float_sfI): + { + Uint f; + int n; + struct ValLabel { + Uint f; + Eterm* addr; + }; + struct ValLabel* ptr; + + GetArg1(0, tmp_arg1); + ASSERT(is_float(tmp_arg1)); + f = float_val(tmp_arg1)[1]; + n = Arg(2); + ptr = (struct ValLabel *) &Arg(3); + while (n-- > 0) { + if (ptr->f == f) { + SET_I(ptr->addr); + Goto(*I); + } + ptr++; + } + SET_I((Eterm *) Arg(1)); + Goto(*I); + } +#else + OpCase(i_select_float_sfI): + { + Uint fpart1; + Uint fpart2; + int n; + struct ValLabel { + Uint fpart1; + Uint fpart2; + Eterm* addr; + }; + struct ValLabel* ptr; + + GetArg1(0, tmp_arg1); + ASSERT(is_float(tmp_arg1)); + fpart1 = float_val(tmp_arg1)[1]; + fpart2 = float_val(tmp_arg1)[2]; + + n = Arg(2); + ptr = (struct ValLabel *) &Arg(3); + while (n-- > 0) { + if (ptr->fpart1 == fpart1 && ptr->fpart2 == fpart2) { + SET_I(ptr->addr); + Goto(*I); + } + ptr++; + } + SET_I((Eterm *) Arg(1)); + Goto(*I); + } +#endif + + OpCase(set_tuple_element_sdP): { + Eterm element; + Eterm tuple; + Eterm* next; + Eterm* p; + + PreFetch(3, next); + GetArg2(0, element, tuple); + ASSERT(is_tuple(tuple)); + p = (Eterm *) ((unsigned char *) tuple_val(tuple) + Arg(2)); + *p = element; + NextPF(3, next); + } + + OpCase(i_is_ne_exact_f): + if (EQ(tmp_arg1, tmp_arg2)) { + ClauseFail(); + } + Next(1); + + OpCase(normal_exit): { + SWAPOUT; + c_p->freason = EXC_NORMAL; + c_p->arity = 0; /* In case this process will ever be garbed again. */ + ERTS_SMP_UNREQ_PROC_MAIN_LOCK(c_p); + erts_do_exit_process(c_p, am_normal); + ERTS_SMP_REQ_PROC_MAIN_LOCK(c_p); + goto do_schedule; + } + + OpCase(continue_exit): { + ERTS_SMP_UNREQ_PROC_MAIN_LOCK(c_p); + erts_continue_exit_process(c_p); + ERTS_SMP_REQ_PROC_MAIN_LOCK(c_p); + goto do_schedule; + } + + OpCase(raise_ss): { + /* This was not done very well in R10-0; then, we passed the tag in + the first argument and hoped that the existing c_p->ftrace was + still correct. But the ftrace-object already includes the tag + (or rather, the freason). Now, we pass the original ftrace in + the first argument. We also handle atom tags in the first + argument for backwards compatibility. + */ + GetArg2(0, tmp_arg1, tmp_arg2); + c_p->fvalue = tmp_arg2; + if (c_p->freason == EXC_NULL) { + /* a safety check for the R10-0 case; should not happen */ + c_p->ftrace = NIL; + c_p->freason = EXC_ERROR; + } + /* for R10-0 code, keep existing c_p->ftrace and hope it's correct */ + switch (tmp_arg1) { + case am_throw: + c_p->freason = EXC_THROWN & ~EXF_SAVETRACE; + break; + case am_error: + c_p->freason = EXC_ERROR & ~EXF_SAVETRACE; + break; + case am_exit: + c_p->freason = EXC_EXIT & ~EXF_SAVETRACE; + break; + default: + {/* R10-1 and later + XXX note: should do sanity check on given trace if it can be + passed from a user! Currently only expecting generated calls. + */ + struct StackTrace *s; + c_p->ftrace = tmp_arg1; + s = get_trace_from_exc(tmp_arg1); + if (s == NULL) { + c_p->freason = EXC_ERROR; + } else { + c_p->freason = PRIMARY_EXCEPTION(s->freason); + } + } + } + goto find_func_info; + } + + OpCase(badmatch_s): { + GetArg1(0, tmp_arg1); + c_p->fvalue = tmp_arg1; + c_p->freason = BADMATCH; + } + /* Fall through here */ + + find_func_info: { + reg[0] = r(0); + SWAPOUT; + I = handle_error(c_p, I, reg, NULL); + goto post_error_handling; + } + + OpCase(call_error_handler): + /* + * At this point, I points to the code[3] in the export entry for + * a function which is not loaded. + * + * code[0]: Module + * code[1]: Function + * code[2]: Arity + * code[3]: &&call_error_handler + * code[4]: Not used + */ + SWAPOUT; + reg[0] = r(0); + tmp_arg1 = call_error_handler(c_p, I-3, reg); + r(0) = reg[0]; + SWAPIN; + if (tmp_arg1) { + SET_I(c_p->i); + Dispatch(); + } + + /* Fall through */ + OpCase(error_action_code): { + no_error_handler: + reg[0] = r(0); + SWAPOUT; + I = handle_error(c_p, NULL, reg, NULL); + post_error_handling: + if (I == 0) { + goto do_schedule; + } else { + r(0) = reg[0]; + ASSERT(!is_value(r(0))); + if (c_p->mbuf) { + erts_garbage_collect(c_p, 0, reg+1, 3); + } + SWAPIN; + Goto(*I); + } + } + + OpCase(call_nif): + { + static void* const dispatchers[4] = { + nif_dispatcher_0, nif_dispatcher_1, nif_dispatcher_2, nif_dispatcher_3 + }; + BifFunction vbf = dispatchers[I[-1]]; + goto apply_bif_or_nif; + + OpCase(apply_bif): + /* + * At this point, I points to the code[3] in the export entry for + * the BIF: + * + * code[0]: Module + * code[1]: Function + * code[2]: Arity + * code[3]: &&apply_bif + * code[4]: Function pointer to BIF function + */ + vbf = (BifFunction) Arg(0); + + apply_bif_or_nif: + c_p->current = I-3; /* In case we apply process_info/1,2 or load_nif/1 */ + c_p->i = I; /* In case we apply check_process_code/2. */ + c_p->arity = 0; /* To allow garbage collection on ourselves + * (check_process_code/2). + */ + + SWAPOUT; + c_p->fcalls = FCALLS - 1; + PROCESS_MAIN_CHK_LOCKS(c_p); + tmp_arg2 = I[-1]; + ASSERT(tmp_arg2 <= 3); + ERTS_SMP_UNREQ_PROC_MAIN_LOCK(c_p); + switch (tmp_arg2) { + case 3: + { + Eterm (*bf)(Process*, Eterm, Eterm, Eterm, Uint*) = vbf; + ASSERT(!ERTS_PROC_IS_EXITING(c_p)); + tmp_arg1 = (*bf)(c_p, r(0), x(1), x(2), I); + ASSERT(!ERTS_PROC_IS_EXITING(c_p) || is_non_value(tmp_arg1)); + PROCESS_MAIN_CHK_LOCKS(c_p); + } + break; + case 2: + { + Eterm (*bf)(Process*, Eterm, Eterm, Uint*) = vbf; + ASSERT(!ERTS_PROC_IS_EXITING(c_p)); + tmp_arg1 = (*bf)(c_p, r(0), x(1), I); + ASSERT(!ERTS_PROC_IS_EXITING(c_p) || is_non_value(tmp_arg1)); + PROCESS_MAIN_CHK_LOCKS(c_p); + } + break; + case 1: + { + Eterm (*bf)(Process*, Eterm, Uint*) = vbf; + ASSERT(!ERTS_PROC_IS_EXITING(c_p)); + tmp_arg1 = (*bf)(c_p, r(0), I); + ASSERT(!ERTS_PROC_IS_EXITING(c_p) || is_non_value(tmp_arg1)); + PROCESS_MAIN_CHK_LOCKS(c_p); + } + break; + case 0: + { + Eterm (*bf)(Process*, Uint*) = vbf; + ASSERT(!ERTS_PROC_IS_EXITING(c_p)); + tmp_arg1 = (*bf)(c_p, I); + ASSERT(!ERTS_PROC_IS_EXITING(c_p) || is_non_value(tmp_arg1)); + PROCESS_MAIN_CHK_LOCKS(c_p); + break; + } + } + ERTS_SMP_REQ_PROC_MAIN_LOCK(c_p); + ERTS_HOLE_CHECK(c_p); + if (c_p->mbuf) { + reg[0] = r(0); + tmp_arg1 = erts_gc_after_bif_call(c_p, tmp_arg1, reg, tmp_arg2); + r(0) = reg[0]; + } + SWAPIN; /* There might have been a garbage collection. */ + FCALLS = c_p->fcalls; + if (is_value(tmp_arg1)) { + r(0) = tmp_arg1; + CHECK_TERM(r(0)); + SET_I(c_p->cp); + Goto(*I); + } else if (c_p->freason == TRAP) { + SET_I((Eterm *)c_p->def_arg_reg[3]); + r(0) = c_p->def_arg_reg[0]; + x(1) = c_p->def_arg_reg[1]; + x(2) = c_p->def_arg_reg[2]; + Dispatch(); + } + reg[0] = r(0); + I = handle_error(c_p, c_p->cp, reg, vbf); + goto post_error_handling; + } + + OpCase(i_get_sd): + { + Eterm arg; + Eterm result; + + GetArg1(0, arg); + result = erts_pd_hash_get(c_p, arg); + StoreBifResult(1, result); + } + + OpCase(i_put_tuple_only_Ad): { + tmp_arg1 = make_tuple(HTOP); + *HTOP++ = Arg(0); + StoreBifResult(1, tmp_arg1); + } + + OpCase(case_end_s): + GetArg1(0, tmp_arg1); + c_p->fvalue = tmp_arg1; + c_p->freason = EXC_CASE_CLAUSE; + goto find_func_info; + + OpCase(if_end): + c_p->freason = EXC_IF_CLAUSE; + goto find_func_info; + + OpCase(i_func_info_IaaI): { + c_p->freason = EXC_FUNCTION_CLAUSE; + c_p->current = I + 2; + goto lb_error_action_code; + } + + OpCase(try_case_end_s): + GetArg1(0, tmp_arg1); + c_p->fvalue = tmp_arg1; + c_p->freason = EXC_TRY_CLAUSE; + goto find_func_info; + + /* + * Construction of binaries using new instructions. + */ + { + Eterm new_binary; + Eterm num_bits_term; + Uint num_bits; + Uint alloc; + Uint num_bytes; + + OpCase(i_bs_init_bits_heap_IIId): { + num_bits = Arg(0); + alloc = Arg(1); + I++; + goto do_bs_init_bits_known; + } + + OpCase(i_bs_init_bits_IId): { + num_bits = Arg(0); + alloc = 0; + goto do_bs_init_bits_known; + } + + OpCase(i_bs_init_bits_fail_heap_IjId): { + /* tmp_arg1 was fetched by an i_fetch instruction */ + num_bits_term = tmp_arg1; + alloc = Arg(0); + I++; + goto do_bs_init_bits; + } + + OpCase(i_bs_init_bits_fail_rjId): { + num_bits_term = r(0); + alloc = 0; + goto do_bs_init_bits; + } + OpCase(i_bs_init_bits_fail_yjId): { + num_bits_term = yb(Arg(0)); + I++; + alloc = 0; + goto do_bs_init_bits; + } + OpCase(i_bs_init_bits_fail_xjId): { + num_bits_term = xb(Arg(0)); + I++; + alloc = 0; + /* FALL THROUGH */ + } + + /* num_bits_term = Term for number of bits to build (small/big) + * alloc = Number of words to allocate on heap + * Operands: Fail Live Dst + */ + + do_bs_init_bits: + if (is_small(num_bits_term)) { + Sint size = signed_val(num_bits_term); + if (size < 0) { + goto badarg; + } + num_bits = (Uint) size; + } else { + Uint bits; + + if (!term_to_Uint(num_bits_term, &bits)) { + c_p->freason = bits; + goto lb_Cl_error; + + } + num_bits = (Eterm) bits; + } + + /* num_bits = Number of bits to build + * alloc = Number of extra words to allocate on heap + * Operands: NotUsed Live Dst + */ + do_bs_init_bits_known: + num_bytes = (num_bits+7) >> 3; + if (num_bits & 7) { + alloc += ERL_SUB_BIN_SIZE; + } + if (num_bytes <= ERL_ONHEAP_BIN_LIMIT) { + alloc += heap_bin_size(num_bytes); + } else { + alloc += PROC_BIN_SIZE; + } + TestHeap(alloc, Arg(1)); + + /* num_bits = Number of bits to build + * num_bytes = Number of bytes to allocate in the binary + * alloc = Total number of words to allocate on heap + * Operands: NotUsed NotUsed Dst + */ + if (num_bytes <= ERL_ONHEAP_BIN_LIMIT) { + ErlHeapBin* hb; + + erts_bin_offset = 0; + erts_writable_bin = 0; + hb = (ErlHeapBin *) HTOP; + HTOP += heap_bin_size(num_bytes); + hb->thing_word = header_heap_bin(num_bytes); + hb->size = num_bytes; + erts_current_bin = (byte *) hb->data; + new_binary = make_binary(hb); + + do_bits_sub_bin: + if (num_bits & 7) { + ErlSubBin* sb; + + sb = (ErlSubBin *) HTOP; + HTOP += ERL_SUB_BIN_SIZE; + sb->thing_word = HEADER_SUB_BIN; + sb->size = num_bytes - 1; + sb->bitsize = num_bits & 7; + sb->offs = 0; + sb->bitoffs = 0; + sb->is_writable = 0; + sb->orig = new_binary; + new_binary = make_binary(sb); + } + StoreBifResult(2, new_binary); + } else { + Binary* bptr; + ProcBin* pb; + + erts_bin_offset = 0; + erts_writable_bin = 0; + + /* + * Allocate the binary struct itself. + */ + bptr = erts_bin_nrml_alloc(num_bytes); + bptr->flags = 0; + bptr->orig_size = num_bytes; + erts_refc_init(&bptr->refc, 1); + erts_current_bin = (byte *) bptr->orig_bytes; + + /* + * Now allocate the ProcBin on the heap. + */ + pb = (ProcBin *) HTOP; + HTOP += PROC_BIN_SIZE; + pb->thing_word = HEADER_PROC_BIN; + pb->size = num_bytes; + pb->next = MSO(c_p).mso; + MSO(c_p).mso = pb; + pb->val = bptr; + pb->bytes = (byte*) bptr->orig_bytes; + pb->flags = 0; + MSO(c_p).overhead += pb->size / sizeof(Eterm); + new_binary = make_binary(pb); + goto do_bits_sub_bin; + } + } + + { + OpCase(i_bs_init_fail_heap_IjId): { + /* tmp_arg1 was fetched by an i_fetch instruction */ + tmp_arg2 = Arg(0); + I++; + goto do_bs_init; + } + + OpCase(i_bs_init_fail_rjId): { + tmp_arg1 = r(0); + tmp_arg2 = 0; + goto do_bs_init; + } + + OpCase(i_bs_init_fail_yjId): { + tmp_arg1 = yb(Arg(0)); + tmp_arg2 = 0; + I++; + goto do_bs_init; + } + + OpCase(i_bs_init_fail_xjId): { + tmp_arg1 = xb(Arg(0)); + tmp_arg2 = 0; + I++; + } + /* FALL THROUGH */ + do_bs_init: + if (is_small(tmp_arg1)) { + Sint size = signed_val(tmp_arg1); + if (size < 0) { + goto badarg; + } + tmp_arg1 = (Eterm) size; + } else { + Uint bytes; + + if (!term_to_Uint(tmp_arg1, &bytes)) { + c_p->freason = bytes; + goto lb_Cl_error; + } + if ((bytes >> (8*sizeof(Uint)-3)) != 0) { + goto system_limit; + } + tmp_arg1 = (Eterm) bytes; + } + if (tmp_arg1 <= ERL_ONHEAP_BIN_LIMIT) { + goto do_heap_bin_alloc; + } else { + goto do_proc_bin_alloc; + } + + + OpCase(i_bs_init_heap_IIId): { + tmp_arg1 = Arg(0); + tmp_arg2 = Arg(1); + I++; + goto do_proc_bin_alloc; + } + + OpCase(i_bs_init_IId): { + tmp_arg1 = Arg(0); + tmp_arg2 = 0; + } + /* FALL THROUGH */ + do_proc_bin_alloc: { + Binary* bptr; + ProcBin* pb; + + erts_bin_offset = 0; + erts_writable_bin = 0; + TestBinVHeap(tmp_arg1 / sizeof(Eterm), + tmp_arg2 + PROC_BIN_SIZE + ERL_SUB_BIN_SIZE, Arg(1)); + + /* + * Allocate the binary struct itself. + */ + bptr = erts_bin_nrml_alloc(tmp_arg1); + bptr->flags = 0; + bptr->orig_size = tmp_arg1; + erts_refc_init(&bptr->refc, 1); + erts_current_bin = (byte *) bptr->orig_bytes; + + /* + * Now allocate the ProcBin on the heap. + */ + pb = (ProcBin *) HTOP; + HTOP += PROC_BIN_SIZE; + pb->thing_word = HEADER_PROC_BIN; + pb->size = tmp_arg1; + pb->next = MSO(c_p).mso; + MSO(c_p).mso = pb; + pb->val = bptr; + pb->bytes = (byte*) bptr->orig_bytes; + pb->flags = 0; + + MSO(c_p).overhead += tmp_arg1 / sizeof(Eterm); + + StoreBifResult(2, make_binary(pb)); + } + + OpCase(i_bs_init_heap_bin_heap_IIId): { + tmp_arg1 = Arg(0); + tmp_arg2 = Arg(1); + I++; + goto do_heap_bin_alloc; + } + + OpCase(i_bs_init_heap_bin_IId): { + tmp_arg1 = Arg(0); + tmp_arg2 = 0; + } + /* Fall through */ + do_heap_bin_alloc: + { + ErlHeapBin* hb; + Uint bin_need; + + bin_need = heap_bin_size(tmp_arg1); + erts_bin_offset = 0; + erts_writable_bin = 0; + TestHeap(bin_need+tmp_arg2+ERL_SUB_BIN_SIZE, Arg(1)); + hb = (ErlHeapBin *) HTOP; + HTOP += bin_need; + hb->thing_word = header_heap_bin(tmp_arg1); + hb->size = tmp_arg1; + erts_current_bin = (byte *) hb->data; + tmp_arg1 = make_binary(hb); + StoreBifResult(2, tmp_arg1); + } + } + + OpCase(i_bs_bits_to_bytes_rjd): { + tmp_arg1 = r(0); + goto do_bits_to_bytes; + } + + OpCase(i_bs_bits_to_bytes_yjd): { + tmp_arg1 = yb(Arg(0)); + I++; + goto do_bits_to_bytes; + + OpCase(i_bs_bits_to_bytes_xjd): { + tmp_arg1 = xb(Arg(0)); + I++; + } + + do_bits_to_bytes: + { + if (is_valid_bit_size(tmp_arg1)) { + tmp_arg1 = make_small(unsigned_val(tmp_arg1) >> 3); + } else { + Uint bytes; + if (!term_to_Uint(tmp_arg1, &bytes)) { + goto badarg; + } + tmp_arg1 = bytes; + if ((tmp_arg1 & 0x07) != 0) { + goto badarg; + } + SWAPOUT; + tmp_arg1 = erts_make_integer(tmp_arg1 >> 3, c_p); + HTOP = HEAP_TOP(c_p); + } + StoreBifResult(1, tmp_arg1); + } + } + + OpCase(i_bs_add_jId): { + Uint Unit = Arg(1); + if (is_both_small(tmp_arg1, tmp_arg2)) { + Sint Arg1 = signed_val(tmp_arg1); + Sint Arg2 = signed_val(tmp_arg2); + + if (Arg1 >= 0 && Arg2 >= 0) { + BsSafeMul(Arg2, Unit, goto system_limit, tmp_arg1); + tmp_arg1 += Arg1; + + store_bs_add_result: + if (MY_IS_SSMALL((Sint) tmp_arg1)) { + tmp_arg1 = make_small(tmp_arg1); + } else { + /* + * May generate a heap fragment, but in this + * particular case it is OK, since the value will be + * stored into an x register (the GC will scan x + * registers for references to heap fragments) and + * there is no risk that value can be stored into a + * location that is not scanned for heap-fragment + * references (such as the heap). + */ + SWAPOUT; + tmp_arg1 = erts_make_integer(tmp_arg1, c_p); + HTOP = HEAP_TOP(c_p); + } + StoreBifResult(2, tmp_arg1); + } + goto badarg; + } else { + Uint a; + Uint b; + Uint c; + + /* + * Now we know that one of the arguments is + * not at small. We must convert both arguments + * to Uints and check for errors at the same time. + * + * Error checking is tricky. + * + * If one of the arguments is not numeric or + * not positive, the error reason is BADARG. + * + * Otherwise if both arguments are numeric, + * but at least one argument does not fit in + * an Uint, the reason is SYSTEM_LIMIT. + */ + + if (!term_to_Uint(tmp_arg1, &a)) { + if (a == BADARG) { + goto badarg; + } + if (!term_to_Uint(tmp_arg2, &b)) { + c_p->freason = b; + goto lb_Cl_error; + } + goto system_limit; + } else if (!term_to_Uint(tmp_arg2, &b)) { + c_p->freason = b; + goto lb_Cl_error; + } + + /* + * The arguments are now correct and stored in a and b. + */ + + BsSafeMul(b, Unit, goto system_limit, c); + tmp_arg1 = a + c; + if (tmp_arg1 < a) { + /* + * If the result is less than one of the + * arguments, there must have been an overflow. + */ + goto system_limit; + } + goto store_bs_add_result; + } + /* No fallthrough */ + ASSERT(0); + } + + OpCase(bs_put_string_II): + { + Eterm* next; + PreFetch(2, next); + erts_new_bs_put_string(ERL_BITS_ARGS_2((byte *) Arg(1), Arg(0))); + NextPF(2, next); + } + + /* + * tmp_arg1 = Number of bytes to build + * tmp_arg2 = Source binary + * Operands: Fail ExtraHeap Live Unit Dst + */ + + OpCase(i_bs_append_jIIId): { + Uint live = Arg(2); + Uint res; + + SWAPOUT; + reg[0] = r(0); + reg[live] = tmp_arg2; + res = erts_bs_append(c_p, reg, live, tmp_arg1, Arg(1), Arg(3)); + r(0) = reg[0]; + SWAPIN; + if (is_non_value(res)) { + /* c_p->freason is already set (may be either BADARG or SYSTEM_LIMIT). */ + goto lb_Cl_error; + } + StoreBifResult(4, res); + } + + /* + * tmp_arg1 = Number of bytes to build + * tmp_arg2 = Source binary + * Operands: Fail Unit Dst + */ + OpCase(i_bs_private_append_jId): { + Eterm res; + + res = erts_bs_private_append(c_p, tmp_arg2, tmp_arg1, Arg(1)); + if (is_non_value(res)) { + /* c_p->freason is already set (may be either BADARG or SYSTEM_LIMIT). */ + goto lb_Cl_error; + } + StoreBifResult(2, res); + } + + /* + * tmp_arg1 = Initial size of writable binary + * Operands: Live Dst + */ + OpCase(bs_init_writable): { + SWAPOUT; + r(0) = erts_bs_init_writable(c_p, r(0)); + SWAPIN; + Next(0); + } + + /* + * Calculate the number of bytes needed to encode the source + * operarand to UTF-8. If the source operand is invalid (e.g. wrong + * type or range) we return a nonsense integer result (0 or 4). We + * can get away with that because we KNOW that bs_put_utf8 will do + * full error checking. + */ + OpCase(i_bs_utf8_size_sd): { + Eterm arg; + Eterm result; + + GetArg1(0, arg); + if (arg < make_small(0x80UL)) { + result = make_small(1); + } else if (arg < make_small(0x800UL)) { + result = make_small(2); + } else if (arg < make_small(0x10000UL)) { + result = make_small(3); + } else { + result = make_small(4); + } + StoreBifResult(1, result); + } + + OpCase(i_bs_put_utf8_js): { + Eterm arg; + + GetArg1(1, arg); + if (!erts_bs_put_utf8(ERL_BITS_ARGS_1(arg))) { + goto badarg; + } + Next(2); + } + + /* + * Calculate the number of bytes needed to encode the source + * operarand to UTF-8. If the source operand is invalid (e.g. wrong + * type or range) we return a nonsense integer result (2 or 4). We + * can get away with that because we KNOW that bs_put_utf16 will do + * full error checking. + */ + + OpCase(i_bs_utf16_size_sd): { + Eterm arg; + Eterm result = make_small(2); + + GetArg1(0, arg); + if (arg >= make_small(0x10000UL)) { + result = make_small(4); + } + StoreBifResult(1, result); + } + + OpCase(i_bs_put_utf16_jIs): { + Eterm arg; + + GetArg1(2, arg); + if (!erts_bs_put_utf16(ERL_BITS_ARGS_2(arg, Arg(1)))) { + goto badarg; + } + Next(3); + } + + /* + * Only used for validating a value about to be stored in a binary. + */ + OpCase(i_bs_validate_unicode_js): { + Eterm val; + + GetArg1(1, val); + + /* + * There is no need to untag the integer, but it IS necessary + * to make sure it is small (if the term is a bignum, it could + * slip through the test, and there is no further test that + * would catch it, since bit syntax construction silently masks + * too big numbers). + */ + if (is_not_small(val) || val > make_small(0x10FFFFUL) || + (make_small(0xD800UL) <= val && val <= make_small(0xDFFFUL)) || + val == make_small(0xFFFEUL) || val == make_small(0xFFFFUL)) { + goto badarg; + } + Next(2); + } + + /* + * Only used for validating a value matched out. + * + * tmp_arg1 = Integer to validate + * tmp_arg2 = Match context + */ + OpCase(i_bs_validate_unicode_retract_j): { + /* + * There is no need to untag the integer, but it IS necessary + * to make sure it is small (a bignum pointer could fall in + * the valid range). + */ + if (is_not_small(tmp_arg1) || tmp_arg1 > make_small(0x10FFFFUL) || + (make_small(0xD800UL) <= tmp_arg1 && tmp_arg1 <= make_small(0xDFFFUL)) || + tmp_arg1 == make_small(0xFFFEUL) || tmp_arg1 == make_small(0xFFFFUL)) { + ErlBinMatchBuffer *mb = ms_matchbuffer(tmp_arg2); + + mb->offset -= 32; + goto badarg; + } + Next(1); + } + + /* + * Matching of binaries. + */ + + { + Eterm header; + Eterm* next; + Uint slots; + + OpCase(i_bs_start_match2_rfIId): { + tmp_arg1 = r(0); + + do_start_match: + slots = Arg(2); + if (!is_boxed(tmp_arg1)) { + ClauseFail(); + } + PreFetch(4, next); + header = *boxed_val(tmp_arg1); + if (header_is_bin_matchstate(header)) { + ErlBinMatchState* ms = (ErlBinMatchState *) boxed_val(tmp_arg1); + Uint actual_slots = HEADER_NUM_SLOTS(header); + ms->save_offset[0] = ms->mb.offset; + if (actual_slots < slots) { + ErlBinMatchState* dst; + Uint live = Arg(1); + Uint wordsneeded = ERL_BIN_MATCHSTATE_SIZE(slots); + + TestHeapPreserve(wordsneeded, live, tmp_arg1); + ms = (ErlBinMatchState *) boxed_val(tmp_arg1); + dst = (ErlBinMatchState *) HTOP; + *dst = *ms; + *HTOP = HEADER_BIN_MATCHSTATE(slots); + HTOP += wordsneeded; + StoreResult(make_matchstate(dst), Arg(3)); + } + } else if (is_binary_header(header)) { + Eterm result; + Uint live = Arg(1); + Uint wordsneeded = ERL_BIN_MATCHSTATE_SIZE(slots); + TestHeapPreserve(wordsneeded, live, tmp_arg1); + HEAP_TOP(c_p) = HTOP; +#ifdef DEBUG + c_p->stop = E; /* Needed for checking in HeapOnlyAlloc(). */ +#endif + result = erts_bs_start_match_2(c_p, tmp_arg1, slots); + HTOP = HEAP_TOP(c_p); + if (is_non_value(result)) { + ClauseFail(); + } else { + StoreResult(result, Arg(3)); + } + } else { + ClauseFail(); + } + NextPF(4, next); + } + OpCase(i_bs_start_match2_xfIId): { + tmp_arg1 = xb(Arg(0)); + I++; + goto do_start_match; + } + OpCase(i_bs_start_match2_yfIId): { + tmp_arg1 = yb(Arg(0)); + I++; + goto do_start_match; + } + } + + OpCase(bs_test_zero_tail2_fr): { + Eterm* next; + ErlBinMatchBuffer *_mb; + + PreFetch(1, next); + _mb = (ErlBinMatchBuffer*) ms_matchbuffer(r(0)); + if (_mb->size != _mb->offset) { + ClauseFail(); + } + NextPF(1, next); + } + + OpCase(bs_test_zero_tail2_fx): { + Eterm* next; + ErlBinMatchBuffer *_mb; + + PreFetch(2, next); + _mb = (ErlBinMatchBuffer*) ms_matchbuffer(xb(Arg(1))); + if (_mb->size != _mb->offset) { + ClauseFail(); + } + NextPF(2, next); + } + + OpCase(bs_test_tail_imm2_frI): { + Eterm* next; + ErlBinMatchBuffer *_mb; + PreFetch(2, next); + _mb = ms_matchbuffer(r(0)); + if (_mb->size - _mb->offset != Arg(1)) { + ClauseFail(); + } + NextPF(2, next); + } + OpCase(bs_test_tail_imm2_fxI): { + Eterm* next; + ErlBinMatchBuffer *_mb; + PreFetch(3, next); + _mb = ms_matchbuffer(xb(Arg(1))); + if (_mb->size - _mb->offset != Arg(2)) { + ClauseFail(); + } + NextPF(3, next); + } + + OpCase(bs_test_unit_frI): { + Eterm* next; + ErlBinMatchBuffer *_mb; + PreFetch(2, next); + _mb = ms_matchbuffer(r(0)); + if ((_mb->size - _mb->offset) % Arg(1)) { + ClauseFail(); + } + NextPF(2, next); + } + OpCase(bs_test_unit_fxI): { + Eterm* next; + ErlBinMatchBuffer *_mb; + PreFetch(3, next); + _mb = ms_matchbuffer(xb(Arg(1))); + if ((_mb->size - _mb->offset) % Arg(2)) { + ClauseFail(); + } + NextPF(3, next); + } + + OpCase(bs_test_unit8_fr): { + Eterm* next; + ErlBinMatchBuffer *_mb; + PreFetch(1, next); + _mb = ms_matchbuffer(r(0)); + if ((_mb->size - _mb->offset) & 7) { + ClauseFail(); + } + NextPF(1, next); + } + OpCase(bs_test_unit8_fx): { + Eterm* next; + ErlBinMatchBuffer *_mb; + PreFetch(2, next); + _mb = ms_matchbuffer(xb(Arg(1))); + if ((_mb->size - _mb->offset) & 7) { + ClauseFail(); + } + NextPF(2, next); + } + + OpCase(i_bs_get_integer_8_rfd): { + tmp_arg1 = r(0); + goto do_bs_get_integer_8; + } + + OpCase(i_bs_get_integer_8_xfd): { + tmp_arg1 = xb(Arg(0)); + I++; + } + + do_bs_get_integer_8: { + ErlBinMatchBuffer *_mb; + Eterm _result; + _mb = ms_matchbuffer(tmp_arg1); + if (_mb->size - _mb->offset < 8) { + ClauseFail(); + } + if (BIT_OFFSET(_mb->offset) != 0) { + _result = erts_bs_get_integer_2(c_p, 8, 0, _mb); + } else { + _result = make_small(_mb->base[BYTE_OFFSET(_mb->offset)]); + _mb->offset += 8; + } + StoreBifResult(1, _result); + } + + OpCase(i_bs_get_integer_16_rfd): { + tmp_arg1 = r(0); + goto do_bs_get_integer_16; + } + + OpCase(i_bs_get_integer_16_xfd): { + tmp_arg1 = xb(Arg(0)); + I++; + } + + do_bs_get_integer_16: { + ErlBinMatchBuffer *_mb; + Eterm _result; + _mb = ms_matchbuffer(tmp_arg1); + if (_mb->size - _mb->offset < 16) { + ClauseFail(); + } + if (BIT_OFFSET(_mb->offset) != 0) { + _result = erts_bs_get_integer_2(c_p, 16, 0, _mb); + } else { + _result = make_small(get_int16(_mb->base+BYTE_OFFSET(_mb->offset))); + _mb->offset += 16; + } + StoreBifResult(1, _result); + } + + OpCase(i_bs_get_integer_32_rfId): { + tmp_arg1 = r(0); + goto do_bs_get_integer_32; + } + + OpCase(i_bs_get_integer_32_xfId): { + tmp_arg1 = xb(Arg(0)); + I++; + } + + do_bs_get_integer_32: { + ErlBinMatchBuffer *_mb; + Uint32 _integer; + Eterm _result; + _mb = ms_matchbuffer(tmp_arg1); + if (_mb->size - _mb->offset < 32) { ClauseFail(); } + if (BIT_OFFSET(_mb->offset) != 0) { + _integer = erts_bs_get_unaligned_uint32(_mb); + } else { + _integer = get_int32(_mb->base + _mb->offset/8); + } + _mb->offset += 32; +#ifndef ARCH_64 + if (IS_USMALL(0, _integer)) { +#endif + _result = make_small(_integer); +#ifndef ARCH_64 + } else { + TestHeap(BIG_UINT_HEAP_SIZE, Arg(1)); + _result = uint_to_big((Uint) _integer, HTOP); + HTOP += BIG_UINT_HEAP_SIZE; + } +#endif + StoreBifResult(2, _result); + } + + /* Operands: Size Live Fail Flags Dst */ + OpCase(i_bs_get_integer_imm_rIIfId): { + tmp_arg1 = r(0); + /* Operands: Size Live Fail Flags Dst */ + goto do_bs_get_integer_imm_test_heap; + } + + /* Operands: x(Reg) Size Live Fail Flags Dst */ + OpCase(i_bs_get_integer_imm_xIIfId): { + tmp_arg1 = xb(Arg(0)); + I++; + /* Operands: Size Live Fail Flags Dst */ + goto do_bs_get_integer_imm_test_heap; + } + + /* + * tmp_arg1 = match context + * Operands: Size Live Fail Flags Dst + */ + do_bs_get_integer_imm_test_heap: { + Uint wordsneeded; + tmp_arg2 = Arg(0); + wordsneeded = 1+WSIZE(NBYTES(tmp_arg2)); + TestHeapPreserve(wordsneeded, Arg(1), tmp_arg1); + I += 2; + /* Operands: Fail Flags Dst */ + goto do_bs_get_integer_imm; + } + + /* Operands: Size Fail Flags Dst */ + OpCase(i_bs_get_integer_small_imm_rIfId): { + tmp_arg1 = r(0); + tmp_arg2 = Arg(0); + I++; + /* Operands: Fail Flags Dst */ + goto do_bs_get_integer_imm; + } + + /* Operands: x(Reg) Size Fail Flags Dst */ + OpCase(i_bs_get_integer_small_imm_xIfId): { + tmp_arg1 = xb(Arg(0)); + tmp_arg2 = Arg(1); + I += 2; + /* Operands: Fail Flags Dst */ + goto do_bs_get_integer_imm; + } + + /* + * tmp_arg1 = match context + * tmp_arg2 = size of field + * Operands: Fail Flags Dst + */ + do_bs_get_integer_imm: { + ErlBinMatchBuffer* mb; + Eterm result; + + mb = ms_matchbuffer(tmp_arg1); + LIGHT_SWAPOUT; + result = erts_bs_get_integer_2(c_p, tmp_arg2, Arg(1), mb); + LIGHT_SWAPIN; + if (is_non_value(result)) { + ClauseFail(); + } + StoreBifResult(2, result); + } + + /* + * tmp_arg1 = Match context + * tmp_arg2 = Size field + * Operands: Fail Live FlagsAndUnit Dst + */ + OpCase(i_bs_get_integer_fIId): { + Uint flags; + Uint size; + ErlBinMatchBuffer* mb; + Eterm result; + + flags = Arg(2); + BsGetFieldSize(tmp_arg2, (flags >> 3), ClauseFail(), size); + if (size >= SMALL_BITS) { + Uint wordsneeded = 1+WSIZE(NBYTES((Uint) size)); + TestHeapPreserve(wordsneeded, Arg(1), tmp_arg1); + } + mb = ms_matchbuffer(tmp_arg1); + LIGHT_SWAPOUT; + result = erts_bs_get_integer_2(c_p, size, flags, mb); + LIGHT_SWAPIN; + if (is_non_value(result)) { + ClauseFail(); + } + StoreBifResult(3, result); + } + + /* Operands: MatchContext Fail Dst */ + OpCase(i_bs_get_utf8_rfd): { + tmp_arg1 = r(0); + goto do_bs_get_utf8; + } + + OpCase(i_bs_get_utf8_xfd): { + tmp_arg1 = xb(Arg(0)); + I++; + } + + /* + * tmp_arg1 = match_context + * Operands: Fail Dst + */ + + do_bs_get_utf8: { + Eterm result = erts_bs_get_utf8(ms_matchbuffer(tmp_arg1)); + if (is_non_value(result)) { + ClauseFail(); + } + StoreBifResult(1, result); + } + + /* Operands: MatchContext Fail Flags Dst */ + OpCase(i_bs_get_utf16_rfId): { + tmp_arg1 = r(0); + goto do_bs_get_utf16; + } + + OpCase(i_bs_get_utf16_xfId): { + tmp_arg1 = xb(Arg(0)); + I++; + } + + /* + * tmp_arg1 = match_context + * Operands: Fail Flags Dst + */ + do_bs_get_utf16: { + Eterm result = erts_bs_get_utf16(ms_matchbuffer(tmp_arg1), Arg(1)); + if (is_non_value(result)) { + ClauseFail(); + } + StoreBifResult(2, result); + } + + { + ErlBinMatchBuffer* mb; + ErlSubBin* sb; + Uint size; + Uint offs; + Uint orig; + Uint hole_size; + + OpCase(bs_context_to_binary_r): { + tmp_arg1 = x0; + I -= 2; + goto do_context_to_binary; + } + + /* Unfortunately, inlining can generate this instruction. */ + OpCase(bs_context_to_binary_y): { + tmp_arg1 = yb(Arg(0)); + goto do_context_to_binary0; + } + + OpCase(bs_context_to_binary_x): { + tmp_arg1 = xb(Arg(0)); + + do_context_to_binary0: + I--; + } + + do_context_to_binary: + if (is_boxed(tmp_arg1) && header_is_bin_matchstate(*boxed_val(tmp_arg1))) { + ErlBinMatchState* ms = (ErlBinMatchState *) boxed_val(tmp_arg1); + mb = &ms->mb; + offs = ms->save_offset[0]; + size = mb->size - offs; + goto do_bs_get_binary_all_reuse_common; + } + Next(2); + + OpCase(i_bs_get_binary_all_reuse_rfI): { + tmp_arg1 = x0; + goto do_bs_get_binary_all_reuse; + } + + OpCase(i_bs_get_binary_all_reuse_xfI): { + tmp_arg1 = xb(Arg(0)); + I++; + } + + do_bs_get_binary_all_reuse: + mb = ms_matchbuffer(tmp_arg1); + size = mb->size - mb->offset; + if (size % Arg(1) != 0) { + ClauseFail(); + } + offs = mb->offset; + + do_bs_get_binary_all_reuse_common: + orig = mb->orig; + sb = (ErlSubBin *) boxed_val(tmp_arg1); + hole_size = 1 + header_arity(sb->thing_word) - ERL_SUB_BIN_SIZE; + sb->thing_word = HEADER_SUB_BIN; + sb->size = BYTE_OFFSET(size); + sb->bitsize = BIT_OFFSET(size); + sb->offs = BYTE_OFFSET(offs); + sb->bitoffs = BIT_OFFSET(offs); + sb->is_writable = 0; + sb->orig = orig; + if (hole_size) { + sb[1].thing_word = make_pos_bignum_header(hole_size-1); + } + Next(2); + } + + { + OpCase(i_bs_match_string_rfII): { + tmp_arg1 = r(0); + goto do_bs_match_string; + } + OpCase(i_bs_match_string_xfII): { + tmp_arg1 = xb(Arg(0)); + I++; + } + + do_bs_match_string: + { + Eterm* next; + byte* bytes; + Uint bits; + ErlBinMatchBuffer* mb; + Uint offs; + + PreFetch(3, next); + bits = Arg(1); + bytes = (byte *) Arg(2); + mb = ms_matchbuffer(tmp_arg1); + if (mb->size - mb->offset < bits) { + ClauseFail(); + } + offs = mb->offset & 7; + if (offs == 0 && (bits & 7) == 0) { + if (sys_memcmp(bytes, mb->base+(mb->offset>>3), bits>>3)) { + ClauseFail(); + } + } else if (erts_cmp_bits(bytes, 0, mb->base+(mb->offset>>3), mb->offset & 7, bits)) { + ClauseFail(); + } + mb->offset += bits; + NextPF(3, next); + } + } + + OpCase(i_bs_save2_rI): { + Eterm* next; + ErlBinMatchState *_ms; + PreFetch(1, next); + _ms = (ErlBinMatchState*) boxed_val((Eterm) r(0)); + _ms->save_offset[Arg(0)] = _ms->mb.offset; + NextPF(1, next); + } + OpCase(i_bs_save2_xI): { + Eterm* next; + ErlBinMatchState *_ms; + PreFetch(2, next); + _ms = (ErlBinMatchState*) boxed_val((Eterm) xb(Arg(0))); + _ms->save_offset[Arg(1)] = _ms->mb.offset; + NextPF(2, next); + } + + OpCase(i_bs_restore2_rI): { + Eterm* next; + ErlBinMatchState *_ms; + PreFetch(1, next); + _ms = (ErlBinMatchState*) boxed_val((Eterm) r(0)); + _ms->mb.offset = _ms->save_offset[Arg(0)]; + NextPF(1, next); + } + OpCase(i_bs_restore2_xI): { + Eterm* next; + ErlBinMatchState *_ms; + PreFetch(2, next); + _ms = (ErlBinMatchState*) boxed_val((Eterm) xb(Arg(0))); + _ms->mb.offset = _ms->save_offset[Arg(1)]; + NextPF(2, next); + } + +#include "beam_cold.h" + + + /* + * This instruction is probably never used (because it is combined with a + * a return). However, a future compiler might for some reason emit a + * deallocate not followed by a return, and that should work. + */ + OpCase(deallocate_I): { + Eterm* next; + + PreFetch(1, next); + D(Arg(0)); + NextPF(1, next); + } + + /* + * Trace and debugging support. + */ + + /* + * At this point, I points to the code[3] in the export entry for + * a trace-enabled function. + * + * code[0]: Module + * code[1]: Function + * code[2]: Arity + * code[3]: &&call_traced_function + * code[4]: Address of function. + */ + OpCase(call_traced_function): { + if (IS_TRACED_FL(c_p, F_TRACE_CALLS)) { + unsigned offset = offsetof(Export, code) + 3*sizeof(Eterm); + Export* ep = (Export *) (((char *)I)-offset); + Uint32 flags; + + SWAPOUT; + reg[0] = r(0); + PROCESS_MAIN_CHK_LOCKS(c_p); + ERTS_SMP_UNREQ_PROC_MAIN_LOCK(c_p); + flags = erts_call_trace(c_p, ep->code, ep->match_prog_set, reg, + 0, &c_p->tracer_proc); + ERTS_SMP_REQ_PROC_MAIN_LOCK(c_p); + PROCESS_MAIN_CHK_LOCKS(c_p); + ASSERT(!ERTS_PROC_IS_EXITING(c_p)); + SWAPIN; + + if (flags & MATCH_SET_RX_TRACE) { + ASSERT(c_p->htop <= E && E <= c_p->hend); + if (E - 3 < HTOP) { + /* SWAPOUT, SWAPIN was done and r(0) was saved above */ + PROCESS_MAIN_CHK_LOCKS(c_p); + FCALLS -= erts_garbage_collect(c_p, 3, reg, ep->code[2]); + PROCESS_MAIN_CHK_LOCKS(c_p); + r(0) = reg[0]; + SWAPIN; + } + E -= 3; + ASSERT(c_p->htop <= E && E <= c_p->hend); + ASSERT(is_CP((Eterm)(ep->code))); + ASSERT(is_internal_pid(c_p->tracer_proc) || + is_internal_port(c_p->tracer_proc)); + E[2] = make_cp(c_p->cp); + E[1] = am_true; /* Process tracer */ + E[0] = make_cp(ep->code); + c_p->cp = (Eterm*) + make_cp(flags & MATCH_SET_EXCEPTION_TRACE + ? beam_exception_trace : beam_return_trace); + erts_smp_proc_lock(c_p, ERTS_PROC_LOCKS_ALL_MINOR); + c_p->trace_flags |= F_EXCEPTION_TRACE; + erts_smp_proc_unlock(c_p, ERTS_PROC_LOCKS_ALL_MINOR); + } + } + SET_I((Uint *) Arg(0)); + Dispatch(); + } + + OpCase(return_trace): { + Uint* code = (Uint *) E[0]; + + SWAPOUT; /* Needed for shared heap */ + ERTS_SMP_UNREQ_PROC_MAIN_LOCK(c_p); + erts_trace_return(c_p, code, r(0), E+1/*Process tracer*/); + ERTS_SMP_REQ_PROC_MAIN_LOCK(c_p); + SWAPIN; + c_p->cp = NULL; + SET_I((Eterm *) E[2]); + E += 3; + Goto(*I); + } + + OpCase(i_count_breakpoint): { + Uint real_I; + + ErtsCountBreak((Uint *) I, &real_I); + ASSERT(VALID_INSTR(real_I)); + Goto(real_I); + } + + OpCase(i_trace_breakpoint): + if (! IS_TRACED_FL(c_p, F_TRACE_CALLS)) { + Uint real_I; + + ErtsBreakSkip((Uint *) I, &real_I); + Goto(real_I); + } + /* Fall through to next case */ + OpCase(i_mtrace_breakpoint): { + Uint real_I; + Uint32 flags; + Eterm tracer_pid; + Uint *cpp; + int return_to_trace = 0, need = 0; + flags = 0; + SWAPOUT; + reg[0] = r(0); + + if (*cp_val((Eterm)c_p->cp) + == (Uint) OpCode(return_trace)) { + cpp = (Uint*)&E[2]; + } else if (*cp_val((Eterm)c_p->cp) + == (Uint) OpCode(i_return_to_trace)) { + return_to_trace = !0; + cpp = (Uint*)&E[0]; + } else { + cpp = NULL; + } + if (cpp) { + /* This _IS_ a tail recursive call, if there are + * return_trace and/or i_return_to_trace stackframes + * on the stack, they are not intermixed with y registers + */ + Eterm *cp_save = c_p->cp; + for (;;) { + ASSERT(is_CP(*cpp)); + if (*cp_val(*cpp) == (Uint) OpCode(return_trace)) { + cpp += 3; + } else if (*cp_val(*cpp) == (Uint) OpCode(i_return_to_trace)) { + return_to_trace = !0; + cpp += 1; + } else + break; + } + c_p->cp = (Eterm *) *cpp; + ASSERT(is_CP((Eterm)c_p->cp)); + ERTS_SMP_UNREQ_PROC_MAIN_LOCK(c_p); + real_I = erts_trace_break(c_p, I, reg, &flags, &tracer_pid); + ERTS_SMP_REQ_PROC_MAIN_LOCK(c_p); + SWAPIN; /* Needed by shared heap. */ + c_p->cp = cp_save; + } else { + ERTS_SMP_UNREQ_PROC_MAIN_LOCK(c_p); + real_I = erts_trace_break(c_p, I, reg, &flags, &tracer_pid); + ERTS_SMP_REQ_PROC_MAIN_LOCK(c_p); + SWAPIN; /* Needed by shared heap. */ + } + + ASSERT(!ERTS_PROC_IS_EXITING(c_p)); + + if ((flags & MATCH_SET_RETURN_TO_TRACE) && !return_to_trace) { + need += 1; + } + if (flags & MATCH_SET_RX_TRACE) { + need += 3; + } + if (need) { + ASSERT(c_p->htop <= E && E <= c_p->hend); + if (E - need < HTOP) { + /* SWAPOUT was done and r(0) was saved above */ + PROCESS_MAIN_CHK_LOCKS(c_p); + FCALLS -= erts_garbage_collect(c_p, need, reg, I[-1]); + PROCESS_MAIN_CHK_LOCKS(c_p); + r(0) = reg[0]; + SWAPIN; + } + } + if ((flags & MATCH_SET_RETURN_TO_TRACE) && !return_to_trace) { + E -= 1; + ASSERT(c_p->htop <= E && E <= c_p->hend); + E[0] = make_cp(c_p->cp); + c_p->cp = (Eterm *) make_cp(beam_return_to_trace); + } + if (flags & MATCH_SET_RX_TRACE) { + E -= 3; + ASSERT(c_p->htop <= E && E <= c_p->hend); + ASSERT(is_CP((Eterm) (I - 3))); + ASSERT(am_true == tracer_pid || + is_internal_pid(tracer_pid) || is_internal_port(tracer_pid)); + E[2] = make_cp(c_p->cp); + E[1] = tracer_pid; + E[0] = make_cp(I - 3); /* We ARE at the beginning of an + instruction, + the funcinfo is above i. */ + c_p->cp = (Eterm*) + make_cp(flags & MATCH_SET_EXCEPTION_TRACE + ? beam_exception_trace : beam_return_trace); + erts_smp_proc_lock(c_p, ERTS_PROC_LOCKS_ALL_MINOR); + c_p->trace_flags |= F_EXCEPTION_TRACE; + erts_smp_proc_unlock(c_p, ERTS_PROC_LOCKS_ALL_MINOR); + } + Goto(real_I); + } + + OpCase(i_return_to_trace): { + if (IS_TRACED_FL(c_p, F_TRACE_RETURN_TO)) { + Uint *cpp = (Uint*) E; + for(;;) { + ASSERT(is_CP(*cpp)); + if (*cp_val(*cpp) == (Uint) OpCode(return_trace)) { + do ++cpp; while(is_not_CP(*cpp)); + cpp += 2; + } else if (*cp_val(*cpp) == (Uint) OpCode(i_return_to_trace)) { + do ++cpp; while(is_not_CP(*cpp)); + } else break; + } + SWAPOUT; /* Needed for shared heap */ + ERTS_SMP_UNREQ_PROC_MAIN_LOCK(c_p); + erts_trace_return_to(c_p, cp_val(*cpp)); + ERTS_SMP_REQ_PROC_MAIN_LOCK(c_p); + SWAPIN; + } + c_p->cp = NULL; + SET_I((Eterm *) E[0]); + E += 1; + Goto(*I); + } + + /* + * Instructions for allocating on the message area. + */ + + OpCase(i_global_cons): + { + Eterm *next; +#ifdef HYBRID + Eterm *hp; + + PreFetch(0,next); + TestGlobalHeap(2,2,hp); + hp[0] = r(0); + hp[1] = x(1); + r(0) = make_list(hp); +#ifndef INCREMENTAL + global_htop += 2; +#endif + NextPF(0,next); +#else + PreFetch(0,next); + c_p->freason = EXC_INTERNAL_ERROR; + goto find_func_info; +#endif + } + + OpCase(i_global_tuple): + { + Eterm *next; + int len; +#ifdef HYBRID + Eterm list; + Eterm *hp; +#endif + + if ((len = list_length(r(0))) < 0) { + goto badarg; + } + + PreFetch(0,next); +#ifdef HYBRID + TestGlobalHeap(len + 1,1,hp); + list = r(0); + r(0) = make_tuple(hp); + *hp++ = make_arityval(len); + while(is_list(list)) + { + Eterm* cons = list_val(list); + *hp++ = CAR(cons); + list = CDR(cons); + } +#ifndef INCREMENTAL + global_htop += len + 1; +#endif + NextPF(0,next); +#else + c_p->freason = EXC_INTERNAL_ERROR; + goto find_func_info; +#endif + } + + OpCase(i_global_copy): + { + Eterm *next; + PreFetch(0,next); +#ifdef HYBRID + if (!IS_CONST(r(0))) + { + BM_SWAP_TIMER(system,copy); + SWAPOUT; + reg[0] = r(0); + reg[1] = NIL; + r(0) = copy_struct_lazy(c_p,r(0),0); + ASSERT(ma_src_top == 0); + ASSERT(ma_dst_top == 0); + ASSERT(ma_offset_top == 0); + SWAPIN; + BM_SWAP_TIMER(copy,system); + } + NextPF(0,next); +#else + c_p->freason = EXC_INTERNAL_ERROR; + goto find_func_info; +#endif + } + + /* + * New floating point instructions. + */ + + OpCase(fmove_ql): { + Eterm fr = Arg(1); + Eterm* next; + + PreFetch(2, next); + GET_DOUBLE(Arg(0), *(FloatDef*)ADD_BYTE_OFFSET(freg, fr)); + NextPF(2, next); + } + + OpCase(fmove_dl): { + Eterm targ1; + Eterm fr = Arg(1); + Eterm* next; + + PreFetch(2, next); + GetR(0, targ1); + /* Arg(0) == HEADER_FLONUM */ + GET_DOUBLE(targ1, *(FloatDef*)ADD_BYTE_OFFSET(freg, fr)); + NextPF(2, next); + } + + OpCase(fmove_new_ld): { + Eterm fr = Arg(0); + Eterm dest = make_float(HTOP); + + PUT_DOUBLE(*(FloatDef*)ADD_BYTE_OFFSET(freg, fr), HTOP); + HTOP += FLOAT_SIZE_OBJECT; + StoreBifResult(1, dest); + } + + OpCase(fconv_dl): { + Eterm targ1; + Eterm fr = Arg(1); + Eterm* next; + + GetR(0, targ1); + PreFetch(2, next); + if (is_small(targ1)) { + fb(fr) = (double) signed_val(targ1); + } else if (is_big(targ1)) { + if (big_to_double(targ1, &fb(fr)) < 0) { + goto fbadarith; + } + } else if (is_float(targ1)) { + GET_DOUBLE(targ1, *(FloatDef*)ADD_BYTE_OFFSET(freg, fr)); + } else { + goto fbadarith; + } + NextPF(2, next); + } + + /* + * Old allocating fmove. + */ + + +#ifdef NO_FPE_SIGNALS + OpCase(fclearerror): + OpCase(i_fcheckerror): + erl_exit(1, "fclearerror/i_fcheckerror without fpe signals (beam_emu)"); +#else + OpCase(fclearerror): { + Eterm* next; + + PreFetch(0, next); + ERTS_FP_CHECK_INIT(c_p); + NextPF(0, next); + } + + OpCase(i_fcheckerror): { + Eterm* next; + + PreFetch(0, next); + ERTS_FP_ERROR(c_p, freg[0].fd, goto fbadarith); + NextPF(0, next); + } +# undef ERTS_FP_CHECK_INIT +# undef ERTS_FP_ERROR +# define ERTS_FP_CHECK_INIT(p) +# define ERTS_FP_ERROR(p, a, b) +#endif + + + OpCase(i_fadd_lll): { + Eterm* next; + + PreFetch(3, next); + ERTS_FP_CHECK_INIT(c_p); + fb(Arg(2)) = fb(Arg(0)) + fb(Arg(1)); + ERTS_FP_ERROR(c_p, fb(Arg(2)), goto fbadarith); + NextPF(3, next); + } + OpCase(i_fsub_lll): { + Eterm* next; + + PreFetch(3, next); + ERTS_FP_CHECK_INIT(c_p); + fb(Arg(2)) = fb(Arg(0)) - fb(Arg(1)); + ERTS_FP_ERROR(c_p, fb(Arg(2)), goto fbadarith); + NextPF(3, next); + } + OpCase(i_fmul_lll): { + Eterm* next; + + PreFetch(3, next); + ERTS_FP_CHECK_INIT(c_p); + fb(Arg(2)) = fb(Arg(0)) * fb(Arg(1)); + ERTS_FP_ERROR(c_p, fb(Arg(2)), goto fbadarith); + NextPF(3, next); + } + OpCase(i_fdiv_lll): { + Eterm* next; + + PreFetch(3, next); + ERTS_FP_CHECK_INIT(c_p); + fb(Arg(2)) = fb(Arg(0)) / fb(Arg(1)); + ERTS_FP_ERROR(c_p, fb(Arg(2)), goto fbadarith); + NextPF(3, next); + } + OpCase(i_fnegate_ll): { + Eterm* next; + + PreFetch(2, next); + ERTS_FP_CHECK_INIT(c_p); + fb(Arg(1)) = -fb(Arg(0)); + ERTS_FP_ERROR(c_p, fb(Arg(1)), goto fbadarith); + NextPF(2, next); + + fbadarith: + c_p->freason = BADARITH; + goto find_func_info; + } + +#ifdef HIPE + { + unsigned cmd; + + OpCase(hipe_trap_call): { + /* + * I[-5]: &&lb_i_func_info_IaaI + * I[-4]: Native code callee (inserted by HiPE) + * I[-3]: Module (tagged atom) + * I[-2]: Function (tagged atom) + * I[-1]: Arity (untagged integer) + * I[ 0]: &&lb_hipe_trap_call + * ... remainder of original BEAM code + */ + ASSERT(I[-5] == (Uint) OpCode(i_func_info_IaaI)); + c_p->hipe.ncallee = (void(*)(void)) I[-4]; + cmd = HIPE_MODE_SWITCH_CMD_CALL | (I[-1] << 8); + ++hipe_trap_count; + goto L_hipe_mode_switch; + } + OpCase(hipe_trap_call_closure): { + ASSERT(I[-5] == (Uint) OpCode(i_func_info_IaaI)); + c_p->hipe.ncallee = (void(*)(void)) I[-4]; + cmd = HIPE_MODE_SWITCH_CMD_CALL_CLOSURE | (I[-1] << 8); + ++hipe_trap_count; + goto L_hipe_mode_switch; + } + OpCase(hipe_trap_return): { + cmd = HIPE_MODE_SWITCH_CMD_RETURN; + goto L_hipe_mode_switch; + } + OpCase(hipe_trap_throw): { + cmd = HIPE_MODE_SWITCH_CMD_THROW; + goto L_hipe_mode_switch; + } + OpCase(hipe_trap_resume): { + cmd = HIPE_MODE_SWITCH_CMD_RESUME; + goto L_hipe_mode_switch; + } + L_hipe_mode_switch: + /* XXX: this abuse of def_arg_reg[] is horrid! */ + SWAPOUT; + c_p->fcalls = FCALLS; + c_p->def_arg_reg[4] = -neg_o_reds; + reg[0] = r(0); + c_p = hipe_mode_switch(c_p, cmd, reg); +#ifdef ERTS_SMP + reg = c_p->scheduler_data->save_reg; + freg = c_p->scheduler_data->freg; +#endif + ERL_BITS_RELOAD_STATEP(c_p); + neg_o_reds = -c_p->def_arg_reg[4]; + FCALLS = c_p->fcalls; + SWAPIN; + switch( c_p->def_arg_reg[3] ) { + case HIPE_MODE_SWITCH_RES_RETURN: + ASSERT(is_value(reg[0])); + MoveReturn(reg[0], r(0)); + case HIPE_MODE_SWITCH_RES_CALL: + SET_I(c_p->i); + r(0) = reg[0]; + Dispatch(); + case HIPE_MODE_SWITCH_RES_CALL_CLOSURE: + /* This can be used to call any function value, but currently it's + only used to call closures referring to unloaded modules. */ + { + Eterm *next; + + next = call_fun(c_p, c_p->arity - 1, reg, THE_NON_VALUE); + SWAPIN; + if (next != NULL) { + r(0) = reg[0]; + SET_I(next); + Dispatchfun(); + } + goto find_func_info; + } + case HIPE_MODE_SWITCH_RES_THROW: + c_p->cp = NULL; + I = handle_error(c_p, I, reg, NULL); + goto post_error_handling; + default: + erl_exit(1, "hipe_mode_switch: result %u\n", c_p->def_arg_reg[3]); + } + } + OpCase(hipe_call_count): { + /* + * I[-5]: &&lb_i_func_info_IaaI + * I[-4]: pointer to struct hipe_call_count (inserted by HiPE) + * I[-3]: Module (tagged atom) + * I[-2]: Function (tagged atom) + * I[-1]: Arity (untagged integer) + * I[ 0]: &&lb_hipe_call_count + * ... remainder of original BEAM code + */ + struct hipe_call_count *hcc = (struct hipe_call_count*)I[-4]; + ASSERT(I[-5] == (Uint) OpCode(i_func_info_IaaI)); + ASSERT(hcc != NULL); + ASSERT(VALID_INSTR(hcc->opcode)); + ++(hcc->count); + Goto(hcc->opcode); + } +#endif /* HIPE */ + + OpCase(i_yield): + { + /* This is safe as long as REDS_IN(c_p) is never stored + * in c_p->arg_reg[0]. It is currently stored in c_p->def_arg_reg[5], + * which may be c_p->arg_reg[5], which is close, but no banana. + */ + c_p->arg_reg[0] = am_true; + c_p->arity = 1; /* One living register (the 'true' return value) */ + SWAPOUT; + c_p->i = I + 1; /* Next instruction */ + erts_smp_proc_lock(c_p, ERTS_PROC_LOCK_STATUS); + erts_add_to_runq(c_p); + erts_smp_proc_unlock(c_p, ERTS_PROC_LOCK_STATUS); + c_p->current = NULL; + goto do_schedule; + } + + OpCase(i_hibernate): { + SWAPOUT; + if (hibernate(c_p, r(0), x(1), x(2), reg)) { + goto do_schedule; + } else { + I = handle_error(c_p, I, reg, hibernate_3); + goto post_error_handling; + } + } + + OpCase(i_debug_breakpoint): { + SWAPOUT; + reg[0] = r(0); + tmp_arg1 = call_breakpoint_handler(c_p, I-3, reg); + r(0) = reg[0]; + SWAPIN; + if (tmp_arg1) { + SET_I(c_p->i); + Dispatch(); + } + goto no_error_handler; + } + + + OpCase(system_limit_j): + system_limit: + c_p->freason = SYSTEM_LIMIT; + goto lb_Cl_error; + + +#ifdef ERTS_OPCODE_COUNTER_SUPPORT + DEFINE_COUNTING_LABELS; +#endif + +#ifndef NO_JUMP_TABLE +#ifdef DEBUG + end_emulator_loop: +#endif +#endif + + OpCase(int_code_end): + OpCase(label_L): + OpCase(too_old_compiler): + OpCase(on_load): + erl_exit(1, "meta op\n"); + + /* + * One-time initialization of Beam emulator. + */ + + init_emulator: + { + int i; + Export* ep; + +#ifndef NO_JUMP_TABLE +#ifdef ERTS_OPCODE_COUNTER_SUPPORT + + /* Are tables correctly generated by beam_makeops? */ + ASSERT(sizeof(counting_opcodes) == sizeof(opcodes)); + + if (count_instructions) { +#ifdef DEBUG + counting_opcodes[op_catch_end_y] = LabelAddr(lb_catch_end_y); +#endif + counting_opcodes[op_i_func_info_IaaI] = LabelAddr(lb_i_func_info_IaaI); + beam_ops = counting_opcodes; + } + else +#endif /* #ifndef ERTS_OPCODE_COUNTER_SUPPORT */ + { + beam_ops = opcodes; + } +#endif /* NO_JUMP_TABLE */ + + em_call_error_handler = OpCode(call_error_handler); + em_call_traced_function = OpCode(call_traced_function); + em_apply_bif = OpCode(apply_bif); + beam_apply[0] = (Eterm) OpCode(i_apply); + beam_apply[1] = (Eterm) OpCode(normal_exit); + beam_exit[0] = (Eterm) OpCode(error_action_code); + beam_continue_exit[0] = (Eterm) OpCode(continue_exit); + beam_return_to_trace[0] = (Eterm) OpCode(i_return_to_trace); + beam_return_trace[0] = (Eterm) OpCode(return_trace); + beam_exception_trace[0] = (Eterm) OpCode(return_trace); /* UGLY */ + + /* + * Enter all BIFs into the export table. + */ + for (i = 0; i < BIF_SIZE; i++) { + ep = erts_export_put(bif_table[i].module, + bif_table[i].name, + bif_table[i].arity); + bif_export[i] = ep; + ep->code[3] = (Eterm) OpCode(apply_bif); + ep->code[4] = (Eterm) bif_table[i].f; + } + + return; + } +#ifdef NO_JUMP_TABLE + default: + erl_exit(1, "unexpected op code %d\n",Go); + } +#endif + return; /* Never executed */ + + save_calls1: + { + Eterm* dis_next; + + save_calls(c_p, (Export *) Arg(0)); + + SET_I(((Export *) Arg(0))->address); + + dis_next = (Eterm *) *I; + FCALLS--; + Goto(dis_next); + } +} + +static BifFunction +translate_gc_bif(void* gcf) +{ + if (gcf == erts_gc_length_1) { + return length_1; + } else if (gcf == erts_gc_size_1) { + return size_1; + } else if (gcf == erts_gc_bit_size_1) { + return bit_size_1; + } else if (gcf == erts_gc_byte_size_1) { + return byte_size_1; + } else if (gcf == erts_gc_abs_1) { + return abs_1; + } else if (gcf == erts_gc_float_1) { + return float_1; + } else if (gcf == erts_gc_round_1) { + return round_1; + } else if (gcf == erts_gc_trunc_1) { + return round_1; + } else { + erl_exit(1, "bad gc bif"); + } +} + +/* + * Mapping from the error code 'class tag' to atoms. + */ +Eterm exception_tag[NUMBER_EXC_TAGS] = { + am_error, /* 0 */ + am_exit, /* 1 */ + am_throw, /* 2 */ +}; + +/* + * Mapping from error code 'index' to atoms. + */ +Eterm error_atom[NUMBER_EXIT_CODES] = { + am_internal_error, /* 0 */ + am_normal, /* 1 */ + am_internal_error, /* 2 */ + am_badarg, /* 3 */ + am_badarith, /* 4 */ + am_badmatch, /* 5 */ + am_function_clause, /* 6 */ + am_case_clause, /* 7 */ + am_if_clause, /* 8 */ + am_undef, /* 9 */ + am_badfun, /* 10 */ + am_badarity, /* 11 */ + am_timeout_value, /* 12 */ + am_noproc, /* 13 */ + am_notalive, /* 14 */ + am_system_limit, /* 15 */ + am_try_clause, /* 16 */ + am_notsup /* 17 */ +}; + +/* + * To fully understand the error handling, one must keep in mind that + * when an exception is thrown, the search for a handler can jump back + * and forth between Beam and native code. Upon each mode switch, a + * dummy handler is inserted so that if an exception reaches that point, + * the handler is invoked (like any handler) and transfers control so + * that the search for a real handler is continued in the other mode. + * Therefore, c_p->freason and c_p->fvalue must still hold the exception + * info when the handler is executed, but normalized so that creation of + * error terms and saving of the stack trace is only done once, even if + * we pass through the error handling code several times. + * + * When a new exception is raised, the current stack trace information + * is quick-saved in a small structure allocated on the heap. Depending + * on how the exception is eventually caught (perhaps by causing the + * current process to terminate), the saved information may be used to + * create a symbolic (human-readable) representation of the stack trace + * at the point of the original exception. + */ + +static Eterm* +handle_error(Process* c_p, Eterm* pc, Eterm* reg, BifFunction bf) +{ + Eterm* hp; + Eterm Value = c_p->fvalue; + Eterm Args = am_true; + c_p->i = pc; /* In case we call erl_exit(). */ + + ASSERT(c_p->freason != TRAP); /* Should have been handled earlier. */ + + /* + * Check if we have an arglist for the top level call. If so, this + * is encoded in Value, so we have to dig out the real Value as well + * as the Arglist. + */ + if (c_p->freason & EXF_ARGLIST) { + Eterm* tp; + ASSERT(is_tuple(Value)); + tp = tuple_val(Value); + Value = tp[1]; + Args = tp[2]; + } + + /* + * Save the stack trace info if the EXF_SAVETRACE flag is set. The + * main reason for doing this separately is to allow throws to later + * become promoted to errors without losing the original stack + * trace, even if they have passed through one or more catch and + * rethrow. It also makes the creation of symbolic stack traces much + * more modular. + */ + if (c_p->freason & EXF_SAVETRACE) { + save_stacktrace(c_p, pc, reg, bf, Args); + } + + /* + * Throws that are not caught are turned into 'nocatch' errors + */ + if ((c_p->freason & EXF_THROWN) && (c_p->catches <= 0) ) { + hp = HAlloc(c_p, 3); + Value = TUPLE2(hp, am_nocatch, Value); + c_p->freason = EXC_ERROR; + } + + /* Get the fully expanded error term */ + Value = expand_error_value(c_p, c_p->freason, Value); + + /* Save final error term and stabilize the exception flags so no + further expansion is done. */ + c_p->fvalue = Value; + c_p->freason = PRIMARY_EXCEPTION(c_p->freason); + + /* Find a handler or die */ + if ((c_p->catches > 0 || IS_TRACED_FL(c_p, F_EXCEPTION_TRACE)) + && !(c_p->freason & EXF_PANIC)) { + Eterm *new_pc; + /* The Beam handler code (catch_end or try_end) checks reg[0] + for THE_NON_VALUE to see if the previous code finished + abnormally. If so, reg[1], reg[2] and reg[3] should hold the + exception class, term and trace, respectively. (If the + handler is just a trap to native code, these registers will + be ignored.) */ + reg[0] = THE_NON_VALUE; + reg[1] = exception_tag[GET_EXC_CLASS(c_p->freason)]; + reg[2] = Value; + reg[3] = c_p->ftrace; + if ((new_pc = next_catch(c_p, reg))) { + c_p->cp = 0; /* To avoid keeping stale references. */ + return new_pc; + } + if (c_p->catches > 0) erl_exit(1, "Catch not found"); + } + ERTS_SMP_UNREQ_PROC_MAIN_LOCK(c_p); + terminate_proc(c_p, Value); + ERTS_SMP_REQ_PROC_MAIN_LOCK(c_p); + return NULL; +} + +/* + * Find the nearest catch handler + */ +static Eterm* +next_catch(Process* c_p, Eterm *reg) { + int active_catches = c_p->catches > 0; + int have_return_to_trace = 0; + Eterm *ptr, *prev, *return_to_trace_ptr = NULL; + Uint i_return_trace = beam_return_trace[0]; + Uint i_return_to_trace = beam_return_to_trace[0]; + ptr = prev = c_p->stop; + ASSERT(is_CP(*ptr)); + ASSERT(ptr <= STACK_START(c_p)); + if (ptr == STACK_START(c_p)) return NULL; + if ((is_not_CP(*ptr) || (*cp_val(*ptr) != i_return_trace && + *cp_val(*ptr) != i_return_to_trace)) + && c_p->cp) { + /* Can not follow cp here - code may be unloaded */ + Uint *cpp = cp_val((Eterm) c_p->cp); + if (cpp == beam_exception_trace) { + erts_trace_exception(c_p, (Eterm*) ptr[0], + reg[1], reg[2], ptr+1); + /* Skip return_trace parameters */ + ptr += 2; + } else if (cpp == beam_return_trace) { + /* Skip return_trace parameters */ + ptr += 2; + } else if (cpp == beam_return_to_trace) { + have_return_to_trace = !0; /* Record next cp */ + } + } + while (ptr < STACK_START(c_p)) { + if (is_catch(*ptr)) { + if (active_catches) goto found_catch; + ptr++; + } + else if (is_CP(*ptr)) { + prev = ptr; + if (*cp_val(*prev) == i_return_trace) { + /* Skip stack frame variables */ + while (++ptr, ptr < STACK_START(c_p) && is_not_CP(*ptr)) { + if (is_catch(*ptr) && active_catches) goto found_catch; + } + if (cp_val(*prev) == beam_exception_trace) { + erts_trace_exception(c_p, (Eterm*) ptr[0], + reg[1], reg[2], ptr+1); + } + /* Skip return_trace parameters */ + ptr += 2; + } else if (*cp_val(*prev) == i_return_to_trace) { + /* Skip stack frame variables */ + while (++ptr, ptr < STACK_START(c_p) && is_not_CP(*ptr)) { + if (is_catch(*ptr) && active_catches) goto found_catch; + } + have_return_to_trace = !0; /* Record next cp */ + return_to_trace_ptr = NULL; + } else { + if (have_return_to_trace) { + /* Record this cp as possible return_to trace cp */ + have_return_to_trace = 0; + return_to_trace_ptr = ptr; + } else return_to_trace_ptr = NULL; + ptr++; + } + } else ptr++; + } + return NULL; + + found_catch: + ASSERT(ptr < STACK_START(c_p)); + c_p->stop = prev; + if (IS_TRACED_FL(c_p, F_TRACE_RETURN_TO) && return_to_trace_ptr) { + /* The stackframe closest to the catch contained an + * return_to_trace entry, so since the execution now + * continues after the catch, a return_to trace message + * would be appropriate. + */ + erts_trace_return_to(c_p, cp_val(*return_to_trace_ptr)); + } + return catch_pc(*ptr); +} + +/* + * Terminating the process when an exception is not caught + */ +static void +terminate_proc(Process* c_p, Eterm Value) +{ + /* Add a stacktrace if this is an error. */ + if (GET_EXC_CLASS(c_p->freason) == EXTAG_ERROR) { + Value = add_stacktrace(c_p, Value, c_p->ftrace); + } + /* EXF_LOG is a primary exception flag */ + if (c_p->freason & EXF_LOG) { + erts_dsprintf_buf_t *dsbufp = erts_create_logger_dsbuf(); + erts_dsprintf(dsbufp, "Error in process %T ", c_p->id); + if (erts_is_alive) + erts_dsprintf(dsbufp, "on node %T ", erts_this_node->sysname); + erts_dsprintf(dsbufp,"with exit value: %0.*T\n", display_items, Value); + erts_send_error_to_logger(c_p->group_leader, dsbufp); + } + /* + * If we use a shared heap, the process will be garbage-collected. + * Must zero c_p->arity to indicate that there are no live registers. + */ + c_p->arity = 0; + erts_do_exit_process(c_p, Value); +} + +/* + * Build and add a symbolic stack trace to the error value. + */ +static Eterm +add_stacktrace(Process* c_p, Eterm Value, Eterm exc) { + Eterm Where = build_stacktrace(c_p, exc); + Eterm* hp = HAlloc(c_p, 3); + return TUPLE2(hp, Value, Where); +} + +/* + * Forming the correct error value from the internal error code. + * This does not update c_p->fvalue or c_p->freason. + */ +Eterm +expand_error_value(Process* c_p, Uint freason, Eterm Value) { + Eterm* hp; + Uint r; + + r = GET_EXC_INDEX(freason); + ASSERT(r < NUMBER_EXIT_CODES); /* range check */ + ASSERT(is_value(Value)); + + switch (r) { + case (GET_EXC_INDEX(EXC_PRIMARY)): + /* Primary exceptions use fvalue as it is */ + break; + case (GET_EXC_INDEX(EXC_BADMATCH)): + case (GET_EXC_INDEX(EXC_CASE_CLAUSE)): + case (GET_EXC_INDEX(EXC_TRY_CLAUSE)): + case (GET_EXC_INDEX(EXC_BADFUN)): + case (GET_EXC_INDEX(EXC_BADARITY)): + /* Some common exceptions: value -> {atom, value} */ + ASSERT(is_value(Value)); + hp = HAlloc(c_p, 3); + Value = TUPLE2(hp, error_atom[r], Value); + break; + default: + /* Other exceptions just use an atom as descriptor */ + Value = error_atom[r]; + break; + } +#ifdef DEBUG + ASSERT(Value != am_internal_error); +#endif + return Value; +} + +/* + * Quick-saving the stack trace in an internal form on the heap. Note + * that c_p->ftrace will point to a cons cell which holds the given args + * and the saved data (encoded as a bignum). + * + * (It would be much better to put the arglist - when it exists - in the + * error value instead of in the actual trace; e.g. '{badarg, Args}' + * instead of using 'badarg' with Args in the trace. The arglist may + * contain very large values, and right now they will be kept alive as + * long as the stack trace is live. Preferably, the stack trace should + * always be small, so that it does not matter if it is long-lived. + * However, it is probably not possible to ever change the format of + * error terms.) + */ + +static void +save_stacktrace(Process* c_p, Eterm* pc, Eterm* reg, BifFunction bf, + Eterm args) { + struct StackTrace* s; + int sz; + int depth = erts_backtrace_depth; /* max depth (never negative) */ + if (depth > 0) { + /* There will always be a current function */ + depth --; + } + + /* Create a container for the exception data */ + sz = (offsetof(struct StackTrace, trace) + sizeof(Eterm)*depth + + sizeof(Eterm) - 1) / sizeof(Eterm); + s = (struct StackTrace *) HAlloc(c_p, 1 + sz); + /* The following fields are inside the bignum */ + s->header = make_pos_bignum_header(sz); + s->freason = c_p->freason; + s->depth = 0; + + /* + * If the failure was in a BIF other than 'error', 'exit' or + * 'throw', find the bif-table index and save the argument + * registers by consing up an arglist. + */ + if (bf != NULL && bf != error_1 && bf != error_2 && + bf != exit_1 && bf != throw_1) { + int i; + int a = 0; + for (i = 0; i < BIF_SIZE; i++) { + if (bf == bif_table[i].f || bf == bif_table[i].traced) { + Export *ep = bif_export[i]; + s->current = ep->code; + a = bif_table[i].arity; + break; + } + } + if (i >= BIF_SIZE) { + /* + * The Bif does not really exist (no BIF entry). It is a + * TRAP and traps are called through apply_bif, which also + * sets c_p->current (luckily). + */ + ASSERT(c_p->current); + s->current = c_p->current; + a = s->current[2]; + ASSERT(s->current[2] <= 3); + } + /* Save first stack entry */ + ASSERT(pc); + if (depth > 0) { + s->trace[s->depth++] = pc; + depth--; + } + /* Save second stack entry if CP is valid and different from pc */ + if (depth > 0 && c_p->cp != 0 && c_p->cp != pc) { + s->trace[s->depth++] = c_p->cp; + depth--; + } + s->pc = NULL; + args = make_arglist(c_p, reg, a); /* Overwrite CAR(c_p->ftrace) */ + } else { + s->current = c_p->current; + /* + * For a function_clause error, the arguments are in the beam + * registers, c_p->cp is valid, and c_p->current is set. + */ + if ( (GET_EXC_INDEX(s->freason)) == + (GET_EXC_INDEX(EXC_FUNCTION_CLAUSE)) ) { + int a; + ASSERT(s->current); + a = s->current[2]; + args = make_arglist(c_p, reg, a); /* Overwrite CAR(c_p->ftrace) */ + /* Save first stack entry */ + ASSERT(c_p->cp); + if (depth > 0) { + s->trace[s->depth++] = c_p->cp; + depth--; + } + s->pc = NULL; /* Ignore pc */ + } else { + if (depth > 0 && c_p->cp != 0 && c_p->cp != pc) { + s->trace[s->depth++] = c_p->cp; + depth--; + } + s->pc = pc; + } + } + + /* Package args and stack trace */ + { + Eterm *hp; + hp = HAlloc(c_p, 2); + c_p->ftrace = CONS(hp, args, make_big((Eterm *) s)); + } + + /* Save the actual stack trace */ + if (depth > 0) { + Eterm *ptr, *prev = s->depth ? s->trace[s->depth-1] : NULL; + Uint i_return_trace = beam_return_trace[0]; + Uint i_return_to_trace = beam_return_to_trace[0]; + /* + * Traverse the stack backwards and add all unique continuation + * pointers to the buffer, up to the maximum stack trace size. + * + * Skip trace stack frames. + */ + ptr = c_p->stop; + if (ptr < STACK_START(c_p) + && (is_not_CP(*ptr)|| (*cp_val(*ptr) != i_return_trace && + *cp_val(*ptr) != i_return_to_trace)) + && c_p->cp) { + /* Can not follow cp here - code may be unloaded */ + Uint *cpp = cp_val((Eterm) c_p->cp); + if (cpp == beam_exception_trace || cpp == beam_return_trace) { + /* Skip return_trace parameters */ + ptr += 2; + } else if (cpp == beam_return_to_trace) { + /* Skip return_to_trace parameters */ + ptr += 1; + } + } + while (ptr < STACK_START(c_p) && depth > 0) { + if (is_CP(*ptr)) { + if (*cp_val(*ptr) == i_return_trace) { + /* Skip stack frame variables */ + do ++ptr; while (is_not_CP(*ptr)); + /* Skip return_trace parameters */ + ptr += 2; + } else if (*cp_val(*ptr) == i_return_to_trace) { + /* Skip stack frame variables */ + do ++ptr; while (is_not_CP(*ptr)); + } else { + Eterm *cp = (Eterm *)(*ptr); + if (cp != prev) { + /* Record non-duplicates only */ + prev = cp; + s->trace[s->depth++] = cp; + depth--; + } + ptr++; + } + } else ptr++; + } + } +} + +/* + * Getting the relevant fields from the term pointed to by ftrace + */ + +static struct StackTrace *get_trace_from_exc(Eterm exc) { + if (exc == NIL) { + return NULL; + } else { + ASSERT(is_list(exc)); + return (struct StackTrace *) big_val(CDR(list_val(exc))); + } +} + +static Eterm get_args_from_exc(Eterm exc) { + if (exc == NIL) { + return NIL; + } else { + ASSERT(is_list(exc)); + return CAR(list_val(exc)); + } +} + +static int is_raised_exc(Eterm exc) { + if (exc == NIL) { + return 0; + } else { + ASSERT(is_list(exc)); + return bignum_header_is_neg(*big_val(CDR(list_val(exc)))); + } +} + +/* + * Creating a list with the argument registers + */ +static Eterm +make_arglist(Process* c_p, Eterm* reg, int a) { + Eterm args = NIL; + Eterm* hp = HAlloc(c_p, 2*a); + while (a > 0) { + args = CONS(hp, reg[a-1], args); + hp += 2; + a--; + } + return args; +} + +/* + * Building a symbolic representation of a saved stack trace. Note that + * the exception object 'exc', unless NIL, points to a cons cell which + * holds the given args and the quick-saved data (encoded as a bignum). + * + * If the bignum is negative, the given args is a complete stacktrace. + */ +Eterm +build_stacktrace(Process* c_p, Eterm exc) { + struct StackTrace* s; + Eterm args; + int depth; + Eterm* current; + Eterm Where = NIL; + Eterm* next_p = &Where; + + if (! (s = get_trace_from_exc(exc))) { + return NIL; + } +#ifdef HIPE + if (s->freason & EXF_NATIVE) { + return hipe_build_stacktrace(c_p, s); + } +#endif + if (is_raised_exc(exc)) { + return get_args_from_exc(exc); + } + + /* + * Find the current function. If the saved s->pc is null, then the + * saved s->current should already contain the proper value. + */ + if (s->pc != NULL) { + current = find_function_from_pc(s->pc); + } else { + current = s->current; + } + /* + * If current is still NULL, default to the initial function + * (e.g. spawn_link(erlang, abs, [1])). + */ + if (current == NULL) { + current = c_p->initial; + args = am_true; /* Just in case */ + } else { + args = get_args_from_exc(exc); + } + + depth = s->depth; + + /* + * Add the {M,F,A} for the current function + * (where A is arity or [Argument]). + */ + { + int i; + Eterm mfa; + Uint heap_size = 6*(depth+1); + Eterm* hp = HAlloc(c_p, heap_size); + Eterm* hp_end = hp + heap_size; + + if (args != am_true) { + /* We have an arglist - use it */ + mfa = TUPLE3(hp, current[0], current[1], args); + } else { + Eterm arity = make_small(current[2]); + mfa = TUPLE3(hp, current[0], current[1], arity); + } + hp += 4; + ASSERT(*next_p == NIL); + *next_p = CONS(hp, mfa, NIL); + next_p = &CDR(list_val(*next_p)); + hp += 2; + + /* + * Finally, we go through the saved continuation pointers. + */ + for (i = 0; i < depth; i++) { + Eterm *fi = find_function_from_pc((Eterm *) s->trace[i]); + if (fi == NULL) continue; + mfa = TUPLE3(hp, fi[0], fi[1], make_small(fi[2])); + hp += 4; + ASSERT(*next_p == NIL); + *next_p = CONS(hp, mfa, NIL); + next_p = &CDR(list_val(*next_p)); + hp += 2; + } + ASSERT(hp <= hp_end); + HRelease(c_p, hp_end, hp); + } + return Where; +} + + +static Eterm +call_error_handler(Process* p, Eterm* fi, Eterm* reg) +{ + Eterm* hp; + Export* ep; + int arity; + Eterm args; + Uint sz; + int i; + + /* + * Search for the error_handler module. + */ + ep = erts_find_function(erts_proc_get_error_handler(p), + am_undefined_function, 3); + if (ep == NULL) { /* No error handler */ + p->current = fi; + p->freason = EXC_UNDEF; + return 0; + } + p->i = ep->address; + + /* + * Create a list with all arguments in the x registers. + */ + + arity = fi[2]; + sz = 2 * arity; + if (HeapWordsLeft(p) < sz) { + erts_garbage_collect(p, sz, reg, arity); + } + hp = HEAP_TOP(p); + HEAP_TOP(p) += sz; + args = NIL; + for (i = arity-1; i >= 0; i--) { + args = CONS(hp, reg[i], args); + hp += 2; + } + + /* + * Set up registers for call to error_handler:undefined_function/3. + */ + reg[0] = fi[0]; + reg[1] = fi[1]; + reg[2] = args; + return 1; +} + +static Eterm +call_breakpoint_handler(Process* p, Eterm* fi, Eterm* reg) +{ + Eterm* hp; + Export* ep; + int arity; + Eterm args; + Uint sz; + int i; + + /* + * Search for error handler module. + */ + ep = erts_find_function(erts_proc_get_error_handler(p), + am_breakpoint, 3); + if (ep == NULL) { /* No error handler */ + p->current = fi; + p->freason = EXC_UNDEF; + return 0; + } + p->i = ep->address; + + /* + * Create a list with all arguments in the x registers. + */ + + arity = fi[2]; + sz = 2 * arity; + if (HeapWordsLeft(p) < sz) { + erts_garbage_collect(p, sz, reg, arity); + } + hp = HEAP_TOP(p); + HEAP_TOP(p) += sz; + args = NIL; + for (i = arity-1; i >= 0; i--) { + args = CONS(hp, reg[i], args); + hp += 2; + } + + /* + * Set up registers for call to error_handler:breakpoint/3. + */ + reg[0] = fi[0]; + reg[1] = fi[1]; + reg[2] = args; + return 1; +} + + + +static Export* +apply_setup_error_handler(Process* p, Eterm module, Eterm function, Uint arity, Eterm* reg) +{ + Export* ep; + + /* + * Find the export table index for the error handler. Return NULL if + * there is no error handler module. + */ + + if ((ep = erts_find_export_entry(erts_proc_get_error_handler(p), + am_undefined_function, 3)) == NULL) { + return NULL; + } else { + int i; + Uint sz = 2*arity; + Eterm* hp; + Eterm args = NIL; + + /* + * Always copy args from registers to a new list; this ensures + * that we have the same behaviour whether or not this was + * called from apply or fixed_apply (any additional last + * THIS-argument will be included, assuming that arity has been + * properly adjusted). + */ + + if (HeapWordsLeft(p) < sz) { + erts_garbage_collect(p, sz, reg, arity); + } + hp = HEAP_TOP(p); + HEAP_TOP(p) += sz; + for (i = arity-1; i >= 0; i--) { + args = CONS(hp, reg[i], args); + hp += 2; + } + reg[0] = module; + reg[1] = function; + reg[2] = args; + } + + return ep; +} + +static Uint* +apply(Process* p, Eterm module, Eterm function, Eterm args, Eterm* reg) +{ + int arity; + Export* ep; + Eterm tmp, this; + + /* + * Check the arguments which should be of the form apply(Module, + * Function, Arguments) where Function is an atom and + * Arguments is an arity long list of terms. + */ + if (is_not_atom(function)) { + /* + * No need to test args here -- done below. + */ + error: + p->freason = BADARG; + + error2: + reg[0] = module; + reg[1] = function; + reg[2] = args; + return 0; + } + + /* The module argument may be either an atom or an abstract module + * (currently implemented using tuples, but this might change). + */ + this = THE_NON_VALUE; + if (is_not_atom(module)) { + Eterm* tp; + + if (is_not_tuple(module)) goto error; + tp = tuple_val(module); + if (arityval(tp[0]) < 1) goto error; + this = module; + module = tp[1]; + if (is_not_atom(module)) goto error; + } + + /* + * Walk down the 3rd parameter of apply (the argument list) and copy + * the parameters to the x registers (reg[]). If the module argument + * was an abstract module, add 1 to the function arity and put the + * module argument in the n+1st x register as a THIS reference. + */ + + tmp = args; + arity = 0; + while (is_list(tmp)) { + if (arity < (MAX_REG - 1)) { + reg[arity++] = CAR(list_val(tmp)); + tmp = CDR(list_val(tmp)); + } else { + p->freason = SYSTEM_LIMIT; + goto error2; + } + } + if (is_not_nil(tmp)) { /* Must be well-formed list */ + goto error; + } + if (this != THE_NON_VALUE) { + reg[arity++] = this; + } + + /* + * Get the index into the export table, or failing that the export + * entry for the error handler. + * + * Note: All BIFs have export entries; thus, no special case is needed. + */ + + if ((ep = erts_find_export_entry(module, function, arity)) == NULL) { + if ((ep = apply_setup_error_handler(p, module, function, arity, reg)) == NULL) goto error; + } else if (ERTS_PROC_GET_SAVED_CALLS_BUF(p)) { + save_calls(p, ep); + } + + return ep->address; +} + +static Uint* +fixed_apply(Process* p, Eterm* reg, Uint arity) +{ + Export* ep; + Eterm module; + Eterm function; + + module = reg[arity]; /* The THIS pointer already in place */ + function = reg[arity+1]; + + if (is_not_atom(function)) { + error: + p->freason = BADARG; + reg[0] = module; + reg[1] = function; + reg[2] = NIL; + return 0; + } + + /* The module argument may be either an atom or an abstract module + * (currently implemented using tuples, but this might change). + */ + if (is_not_atom(module)) { + Eterm* tp; + if (is_not_tuple(module)) goto error; + tp = tuple_val(module); + if (arityval(tp[0]) < 1) goto error; + module = tp[1]; + if (is_not_atom(module)) goto error; + ++arity; + } + + /* + * Get the index into the export table, or failing that the export + * entry for the error handler module. + * + * Note: All BIFs have export entries; thus, no special case is needed. + */ + + if ((ep = erts_find_export_entry(module, function, arity)) == NULL) { + if ((ep = apply_setup_error_handler(p, module, function, arity, reg)) == NULL) + goto error; + } else if (ERTS_PROC_GET_SAVED_CALLS_BUF(p)) { + save_calls(p, ep); + } + + return ep->address; +} + +static int +hibernate(Process* c_p, Eterm module, Eterm function, Eterm args, Eterm* reg) +{ + int arity; + Eterm tmp; + + if (is_not_atom(module) || is_not_atom(function)) { + /* + * No need to test args here -- done below. + */ + error: + c_p->freason = BADARG; + + error2: + reg[0] = module; + reg[1] = function; + reg[2] = args; + return 0; + } + + arity = 0; + tmp = args; + while (is_list(tmp)) { + if (arity < MAX_REG) { + tmp = CDR(list_val(tmp)); + arity++; + } else { + c_p->freason = SYSTEM_LIMIT; + goto error2; + } + } + if (is_not_nil(tmp)) { /* Must be well-formed list */ + goto error; + } + + /* + * At this point, arguments are known to be good. + */ + + if (c_p->arg_reg != c_p->def_arg_reg) { + /* Save some memory */ + erts_free(ERTS_ALC_T_ARG_REG, c_p->arg_reg); + c_p->arg_reg = c_p->def_arg_reg; + c_p->max_arg_reg = sizeof(c_p->def_arg_reg)/sizeof(c_p->def_arg_reg[0]); + } + + /* + * Arrange for the process to be resumed at the given MFA with + * the stack cleared. + */ + c_p->arity = 3; + c_p->arg_reg[0] = module; + c_p->arg_reg[1] = function; + c_p->arg_reg[2] = args; + c_p->stop = STACK_START(c_p); + c_p->catches = 0; + c_p->i = beam_apply; + c_p->cp = (Eterm *) beam_apply+1; + + /* + * If there are no waiting messages, garbage collect and + * shrink the heap. + */ + erts_smp_proc_lock(c_p, ERTS_PROC_LOCK_MSGQ|ERTS_PROC_LOCK_STATUS); + ERTS_SMP_MSGQ_MV_INQ2PRIVQ(c_p); + if (c_p->msg.len > 0) { + erts_add_to_runq(c_p); + } else { + erts_smp_proc_unlock(c_p, ERTS_PROC_LOCK_MSGQ|ERTS_PROC_LOCK_STATUS); + c_p->fvalue = NIL; + PROCESS_MAIN_CHK_LOCKS(c_p); + erts_garbage_collect_hibernate(c_p); + PROCESS_MAIN_CHK_LOCKS(c_p); + erts_smp_proc_lock(c_p, ERTS_PROC_LOCK_MSGQ|ERTS_PROC_LOCK_STATUS); + ASSERT(!ERTS_PROC_IS_EXITING(c_p)); + c_p->status = P_WAITING; +#ifdef ERTS_SMP + ERTS_SMP_MSGQ_MV_INQ2PRIVQ(c_p); + if (c_p->msg.len > 0) + erts_add_to_runq(c_p); +#endif + } + erts_smp_proc_unlock(c_p, ERTS_PROC_LOCK_MSGQ|ERTS_PROC_LOCK_STATUS); + c_p->current = bif_export[BIF_hibernate_3]->code; + return 1; +} + +static Uint* +call_fun(Process* p, /* Current process. */ + int arity, /* Number of arguments for Fun. */ + Eterm* reg, /* Contents of registers. */ + Eterm args) /* THE_NON_VALUE or pre-built list of arguments. */ +{ + Eterm fun = reg[arity]; + Eterm hdr; + int i; + Eterm function; + Eterm* hp; + + if (!is_boxed(fun)) { + goto badfun; + } + hdr = *boxed_val(fun); + + if (is_fun_header(hdr)) { + ErlFunThing* funp = (ErlFunThing *) fun_val(fun); + ErlFunEntry* fe; + Eterm* code_ptr; + Eterm* var_ptr; + int actual_arity; + unsigned num_free; + + fe = funp->fe; + num_free = funp->num_free; + code_ptr = fe->address; + actual_arity = (int) code_ptr[-1]; + + if (actual_arity == arity+num_free) { + if (num_free == 0) { + return code_ptr; + } else { + var_ptr = funp->env; + reg += arity; + i = 0; + do { + reg[i] = var_ptr[i]; + i++; + } while (i < num_free); + reg[i] = fun; + return code_ptr; + } + return code_ptr; + } else { + /* + * Something wrong here. First build a list of the arguments. + */ + + if (is_non_value(args)) { + Uint sz = 2 * arity; + args = NIL; + if (HeapWordsLeft(p) < sz) { + erts_garbage_collect(p, sz, reg, arity+1); + fun = reg[arity]; + } + hp = HEAP_TOP(p); + HEAP_TOP(p) += sz; + for (i = arity-1; i >= 0; i--) { + args = CONS(hp, reg[i], args); + hp += 2; + } + } + + if (actual_arity >= 0) { + /* + * There is a fun defined, but the call has the wrong arity. + */ + hp = HAlloc(p, 3); + p->freason = EXC_BADARITY; + p->fvalue = TUPLE2(hp, fun, args); + return NULL; + } else { + Export* ep; + Module* modp; + Eterm module; + + + /* + * No arity. There is no module loaded that defines the fun, + * either because the fun is newly created from the external + * representation (the module has never been loaded), + * or the module defining the fun has been unloaded. + */ + + module = fe->module; + if ((modp = erts_get_module(module)) != NULL && modp->code != NULL) { + /* + * There is a module loaded, but obviously the fun is not + * defined in it. We must not call the error_handler + * (or we will get into an infinite loop). + */ + goto badfun; + } + + /* + * No current code for this module. Call the error_handler module + * to attempt loading the module. + */ + + ep = erts_find_function(erts_proc_get_error_handler(p), + am_undefined_lambda, 3); + if (ep == NULL) { /* No error handler */ + p->current = NULL; + p->freason = EXC_UNDEF; + return NULL; + } + reg[0] = module; + reg[1] = fun; + reg[2] = args; + return ep->address; + } + } + } else if (is_export_header(hdr)) { + Export* ep = (Export *) (export_val(fun))[1]; + int actual_arity = (int) ep->code[2]; + if (arity == actual_arity) { + return ep->address; + } else { + /* + * Wrong arity. First build a list of the arguments. + */ + + if (is_non_value(args)) { + args = NIL; + hp = HAlloc(p, arity*2); + for (i = arity-1; i >= 0; i--) { + args = CONS(hp, reg[i], args); + hp += 2; + } + } + + hp = HAlloc(p, 3); + p->freason = EXC_BADARITY; + p->fvalue = TUPLE2(hp, fun, args); + return NULL; + } + } else if (hdr == make_arityval(2)) { + Eterm* tp; + Export* ep; + Eterm module; + + tp = tuple_val(fun); + module = tp[1]; + function = tp[2]; + if (!is_atom(module) || !is_atom(function)) { + goto badfun; + } + if ((ep = erts_find_export_entry(module, function, arity)) == NULL) { + ep = erts_find_export_entry(erts_proc_get_error_handler(p), + am_undefined_function, 3); + if (ep == NULL) { + p->freason = EXC_UNDEF; + return 0; + } + if (is_non_value(args)) { + Uint sz = 2 * arity; + if (HeapWordsLeft(p) < sz) { + erts_garbage_collect(p, sz, reg, arity); + } + hp = HEAP_TOP(p); + HEAP_TOP(p) += sz; + args = NIL; + while (arity-- > 0) { + args = CONS(hp, reg[arity], args); + hp += 2; + } + } + reg[0] = module; + reg[1] = function; + reg[2] = args; + } + return ep->address; + } else { + badfun: + p->current = NULL; + p->freason = EXC_BADFUN; + p->fvalue = fun; + return NULL; + } +} + +static Eterm* +apply_fun(Process* p, Eterm fun, Eterm args, Eterm* reg) +{ + int arity; + Eterm tmp; + + /* + * Walk down the 3rd parameter of apply (the argument list) and copy + * the parameters to the x registers (reg[]). + */ + + tmp = args; + arity = 0; + while (is_list(tmp)) { + if (arity < MAX_REG-1) { + reg[arity++] = CAR(list_val(tmp)); + tmp = CDR(list_val(tmp)); + } else { + p->freason = SYSTEM_LIMIT; + return NULL; + } + } + + if (is_not_nil(tmp)) { /* Must be well-formed list */ + p->freason = EXC_UNDEF; + return NULL; + } + reg[arity] = fun; + return call_fun(p, arity, reg, args); +} + + +static Eterm +new_fun(Process* p, Eterm* reg, ErlFunEntry* fe, int num_free) +{ + unsigned needed = ERL_FUN_SIZE + num_free; + ErlFunThing* funp; + Eterm* hp; + int i; + + if (HEAP_LIMIT(p) - HEAP_TOP(p) <= needed) { + PROCESS_MAIN_CHK_LOCKS(p); + erts_garbage_collect(p, needed, reg, num_free); + PROCESS_MAIN_CHK_LOCKS(p); + } + hp = p->htop; + p->htop = hp + needed; + funp = (ErlFunThing *) hp; + hp = funp->env; + erts_refc_inc(&fe->refc, 2); + funp->thing_word = HEADER_FUN; +#ifndef HYBRID /* FIND ME! */ + funp->next = MSO(p).funs; + MSO(p).funs = funp; +#endif + funp->fe = fe; + funp->num_free = num_free; + funp->creator = p->id; +#ifdef HIPE + funp->native_address = fe->native_address; +#endif + funp->arity = (int)fe->address[-1] - num_free; + for (i = 0; i < num_free; i++) { + *hp++ = reg[i]; + } + return make_fun(funp); +} + + + +int catchlevel(Process *p) +{ + return p->catches; +} + +/* + * Check if the given function is built-in (i.e. a BIF implemented in C). + * + * Returns 0 if not built-in, and a non-zero value if built-in. + */ + +int +erts_is_builtin(Eterm Mod, Eterm Name, int arity) +{ + Export e; + Export* ep; + + e.code[0] = Mod; + e.code[1] = Name; + e.code[2] = arity; + + if ((ep = export_get(&e)) == NULL) { + return 0; + } + return ep->address == ep->code+3 && (ep->code[3] == (Uint) em_apply_bif); +} + + +/* + * Return the current number of reductions for the given process. + * To get the total number of reductions, p->reds must be added. + */ + +Uint +erts_current_reductions(Process *current, Process *p) +{ + if (current != p) { + return 0; + } else if (current->fcalls < 0 && ERTS_PROC_GET_SAVED_CALLS_BUF(current)) { + return -current->fcalls; + } else { + return REDS_IN(current) - current->fcalls; + } +} + +static BIF_RETTYPE nif_dispatcher_0(Process* p, Uint* I) +{ + typedef Eterm NifF(struct enif_environment_t*); + NifF* fp = (NifF*) I[1]; + struct enif_environment_t env; + Eterm ret; + erts_pre_nif(&env, p, (void*)I[2]); + ret = (*fp)(&env); + erts_post_nif(&env); + return ret; +} + +static BIF_RETTYPE nif_dispatcher_1(Process* p, Eterm arg1, Uint* I) +{ + typedef Eterm NifF(struct enif_environment_t*, Eterm); + NifF* fp = (NifF*) I[1]; + struct enif_environment_t env; + Eterm ret; + erts_pre_nif(&env, p, (void*)I[2]); + ret = (*fp)(&env, arg1); + erts_post_nif(&env); + return ret; +} + +static BIF_RETTYPE nif_dispatcher_2(Process* p, Eterm arg1, Eterm arg2, Uint* I) +{ + typedef Eterm NifF(struct enif_environment_t*, Eterm, Eterm); + NifF* fp = (NifF*) I[1]; + struct enif_environment_t env; + Eterm ret; + erts_pre_nif(&env, p, (void*)I[2]); + ret = (*fp)(&env, arg1, arg2); + erts_post_nif(&env); + return ret; +} + +static BIF_RETTYPE nif_dispatcher_3(Process* p, Eterm arg1, Eterm arg2, Eterm arg3, Uint* I) +{ + typedef Eterm NifF(struct enif_environment_t*, Eterm, Eterm, Eterm); + NifF* fp = (NifF*) I[1]; + struct enif_environment_t env; + Eterm ret; + erts_pre_nif(&env, p, (void*)I[2]); + ret = (*fp)(&env, arg1, arg2, arg3); + erts_post_nif(&env); + return ret; +} + diff --git a/erts/emulator/beam/beam_load.c b/erts/emulator/beam/beam_load.c new file mode 100644 index 0000000000..47dd98117d --- /dev/null +++ b/erts/emulator/beam/beam_load.c @@ -0,0 +1,5234 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "erl_version.h" +#include "erl_process.h" +#include "error.h" +#include "erl_driver.h" +#include "bif.h" +#include "external.h" +#include "beam_load.h" +#include "big.h" +#include "erl_bits.h" +#include "beam_catches.h" +#include "erl_binary.h" +#include "erl_zlib.h" + +#ifdef HIPE +#include "hipe_bif0.h" +#include "hipe_mode_switch.h" +#include "hipe_arch.h" +#endif + +ErlDrvBinary* erts_gzinflate_buffer(char*, int); + +#define MAX_OPARGS 8 +#define CALLED 0 +#define DEFINED 1 +#define EXPORTED 2 + +#ifdef NO_JUMP_TABLE +# define BeamOpCode(Op) ((Uint)(Op)) +#else +# define BeamOpCode(Op) ((Eterm)beam_ops[Op]) +#endif + +#if defined(WORDS_BIGENDIAN) +# define NATIVE_ENDIAN(F) \ + if ((F).val & BSF_NATIVE) { \ + (F).val &= ~(BSF_LITTLE|BSF_NATIVE); \ + } else {} +#else +# define NATIVE_ENDIAN(F) \ + if ((F).val & BSF_NATIVE) { \ + (F).val &= ~BSF_NATIVE; \ + (F).val |= BSF_LITTLE; \ + } else {} +#endif + +/* + * Errors returned from tranform_engine(). + */ +#define TE_OK 0 +#define TE_FAIL (-1) +#define TE_SHORT_WINDOW (-2) + +typedef struct { + Uint value; /* Value of label (NULL if not known yet). */ + Uint patches; /* Index (into code buffer) to first location + * which must be patched with the value of this label. + */ +#ifdef ERTS_SMP + Uint looprec_targeted; /* Non-zero if this label is the target of a loop_rec + * instruction. + */ +#endif +} Label; + +/* + * Type for a operand for a generic instruction. + */ + +typedef struct { + unsigned type; /* Type of operand. */ + Uint val; /* Value of operand. */ + Uint bigarity; /* Arity for bignumbers (only). */ +} GenOpArg; + +/* + * A generic operation. + */ + +typedef struct genop { + int op; /* Opcode. */ + int arity; /* Number of arguments. */ + GenOpArg def_args[MAX_OPARGS]; /* Default buffer for arguments. */ + GenOpArg* a; /* The arguments. */ + struct genop* next; /* Next genop. */ +} GenOp; + +/* + * The allocation unit for generic blocks. + */ + +typedef struct genop_block { + GenOp genop[32]; + struct genop_block* next; +} GenOpBlock; + +/* + * This structure contains information for an imported function or BIF. + */ +typedef struct { + Eterm module; /* Tagged atom for module. */ + Eterm function; /* Tagged atom for function. */ + int arity; /* Arity. */ + Uint patches; /* Index to locations in code to + * eventually patch with a pointer into + * the export entry. + */ + BifFunction bf; /* Pointer to BIF function if BIF; + * NULL otherwise. + */ +} ImportEntry; + +/* + * This structure contains information for a function exported from a module. + */ + +typedef struct { + Eterm function; /* Tagged atom for function. */ + int arity; /* Arity. */ + Eterm* address; /* Address to function in code. */ +} ExportEntry; + +#define MakeIffId(a, b, c, d) \ + (((Uint) (a) << 24) | ((Uint) (b) << 16) | ((Uint) (c) << 8) | (Uint) (d)) + +#define ATOM_CHUNK 0 +#define CODE_CHUNK 1 +#define STR_CHUNK 2 +#define IMP_CHUNK 3 +#define EXP_CHUNK 4 +#define NUM_MANDATORY 5 + +#define LAMBDA_CHUNK 5 +#define LITERAL_CHUNK 6 +#define ATTR_CHUNK 7 +#define COMPILE_CHUNK 8 + +#define NUM_CHUNK_TYPES (sizeof(chunk_types)/sizeof(chunk_types[0])) + +/* + * An array with all chunk types recognized by the loader. + */ + +static Uint chunk_types[] = { + /* + * Mandatory chunk types -- these MUST be present. + */ + MakeIffId('A', 't', 'o', 'm'), /* 0 */ + MakeIffId('C', 'o', 'd', 'e'), /* 1 */ + MakeIffId('S', 't', 'r', 'T'), /* 2 */ + MakeIffId('I', 'm', 'p', 'T'), /* 3 */ + MakeIffId('E', 'x', 'p', 'T'), /* 4 */ + + /* + * Optional chunk types -- the loader will use them if present. + */ + MakeIffId('F', 'u', 'n', 'T'), /* 5 */ + MakeIffId('L', 'i', 't', 'T'), /* 6 */ + MakeIffId('A', 't', 't', 'r'), /* 7 */ + MakeIffId('C', 'I', 'n', 'f'), /* 8 */ +}; + +/* + * This structure keeps load-time information about a lambda. + */ + +typedef struct { + ErlFunEntry* fe; /* Entry in fun table. */ + unsigned label; /* Label of function entry. */ + Uint32 num_free; /* Number of free variables. */ + Eterm function; /* Name of local function. */ + int arity; /* Arity (including free variables). */ +} Lambda; + +/* + * This structure keeps load-time information about a literal. + */ + +typedef struct { + Eterm term; /* The tagged term (in the heap). */ + Uint heap_size; /* (Exact) size on the heap. */ + Uint offset; /* Offset from temporary location to final. */ + Eterm* heap; /* Heap for term. */ +} Literal; + +/* + * This structure keeps information about an operand that needs to be + * patched to contain the correct address of a literal when the code is + * frozen. + */ + +typedef struct literal_patch LiteralPatch; +struct literal_patch { + int pos; /* Position in code */ + LiteralPatch* next; +}; + +/* + * This structure keeps information about an operand that needs to be + * patched to contain the correct address for an address into the string table. + */ + +typedef struct string_patch StringPatch; +struct string_patch { + int pos; /* Position in code */ + StringPatch* next; +}; + +/* + * This structure contains all information about the module being loaded. + */ + +typedef struct { + /* + * The current logical file within the binary. + */ + + char* file_name; /* Name of file we are reading (usually chunk name). */ + byte* file_p; /* Current pointer within file. */ + unsigned file_left; /* Number of bytes left in file. */ + + /* + * The following are used mainly for diagnostics. + */ + + Eterm group_leader; /* Group leader (for diagnostics). */ + Eterm module; /* Tagged atom for module name. */ + Eterm function; /* Tagged atom for current function + * (or 0 if none). + */ + unsigned arity; /* Arity for current function. */ + + /* + * All found chunks. + */ + + struct { + byte* start; /* Start of chunk (in binary). */ + unsigned size; /* Size of chunk. */ + } chunks[NUM_CHUNK_TYPES]; + + /* + * Used for code loading (mainly). + */ + + byte* code_start; /* Start of code file. */ + unsigned code_size; /* Size of code file. */ + int specific_op; /* Specific opcode (-1 if not found). */ + int num_functions; /* Number of functions in module. */ + int num_labels; /* Number of labels. */ + int code_buffer_size; /* Size of code buffer in words. */ + Eterm* code; /* Loaded code. */ + int ci; /* Current index into loaded code. */ + Label* labels; + Uint put_strings; /* Linked list of put_string instructions. */ + Uint new_bs_put_strings; /* Linked list of i_new_bs_put_string instructions. */ + StringPatch* string_patches; /* Linked list of position into string table to patch. */ + Uint catches; /* Linked list of catch_yf instructions. */ + unsigned loaded_size; /* Final size of code when loaded. */ + byte mod_md5[16]; /* MD5 for module code. */ + int may_load_nif; /* true if NIFs may later be loaded for this module */ + int on_load; /* Index in the code for the on_load function + * (or 0 if there is no on_load function) + */ + + /* + * Atom table. + */ + + int num_atoms; /* Number of atoms in atom table. */ + Eterm* atom; /* Atom table. */ + + int num_exps; /* Number of exports. */ + ExportEntry* export; /* Pointer to export table. */ + + int num_imports; /* Number of imports. */ + ImportEntry* import; /* Import entry (translated information). */ + + /* + * Generic instructions. + */ + GenOp* genop; /* The last generic instruction seen. */ + GenOp* free_genop; /* List of free genops. */ + GenOpBlock* genop_blocks; /* List of all block of allocated genops. */ + + /* + * Lambda table. + */ + + int num_lambdas; /* Number of lambdas in table. */ + int lambdas_allocated; /* Size of allocated lambda table. */ + Lambda* lambdas; /* Pointer to lambdas. */ + Lambda def_lambdas[16]; /* Default storage for lambda table. */ + char* lambda_error; /* Delayed missing 'FunT' error. */ + + /* + * Literals (constant pool). + */ + + int num_literals; /* Number of literals in table. */ + int allocated_literals; /* Number of literal entries allocated. */ + Literal* literals; /* Array of literals. */ + LiteralPatch* literal_patches; /* Operands that need to be patched. */ + Uint total_literal_size; /* Total heap size for all literals. */ + + /* + * Floating point. + */ + int new_float_instructions; /* New allocation scheme for floating point. */ +} LoaderState; + +typedef struct { + unsigned num_functions; /* Number of functions. */ + Eterm* func_tab[1]; /* Pointers to each function. */ +} LoadedCode; + +#define GetTagAndValue(Stp, Tag, Val) \ + do { \ + Uint __w; \ + GetByte(Stp, __w); \ + Tag = __w & 0x07; \ + if ((__w & 0x08) == 0) { \ + Val = __w >> 4; \ + } else if ((__w & 0x10) == 0) { \ + Val = ((__w >> 5) << 8); \ + GetByte(Stp, __w); \ + Val |= __w; \ + } else { \ + if (!get_int_val(Stp, __w, &(Val))) goto load_error; \ + } \ + } while (0) + + +#define LoadError0(Stp, Fmt) \ + do { \ + load_printf(__LINE__, Stp, Fmt); \ + goto load_error; \ + } while (0) + +#define LoadError1(Stp, Fmt, Arg1) \ + do { \ + load_printf(__LINE__, stp, Fmt, Arg1); \ + goto load_error; \ + } while (0) + +#define LoadError2(Stp, Fmt, Arg1, Arg2) \ + do { \ + load_printf(__LINE__, Stp, Fmt, Arg1, Arg2); \ + goto load_error; \ + } while (0) + +#define LoadError3(Stp, Fmt, Arg1, Arg2, Arg3) \ + do { \ + load_printf(__LINE__, stp, Fmt, Arg1, Arg2, Arg3); \ + goto load_error; \ + } while (0) + +#define EndOfFile(Stp) (stp->file_left == 0) + +#define GetInt(Stp, N, Dest) \ + if (Stp->file_left < (N)) { \ + short_file(__LINE__, Stp, (N)); \ + goto load_error; \ + } else { \ + int __n = (N); \ + Uint __result = 0; \ + Stp->file_left -= (unsigned) __n; \ + while (__n-- > 0) { \ + __result = __result << 8 | *Stp->file_p++; \ + } \ + Dest = __result; \ + } while (0) + +#define GetByte(Stp, Dest) \ + if ((Stp)->file_left < 1) { \ + short_file(__LINE__, (Stp), 1); \ + goto load_error; \ + } else { \ + Dest = *(Stp)->file_p++; \ + (Stp)->file_left--; \ + } + +#define GetString(Stp, Dest, N) \ + if (Stp->file_left < (N)) { \ + short_file(__LINE__, Stp, (N)); \ + goto load_error; \ + } else { \ + Dest = (Stp)->file_p; \ + (Stp)->file_p += (N); \ + (Stp)->file_left -= (N); \ + } + +#define GetAtom(Stp, Index, Dest) \ + if ((Index) == 0) { \ + LoadError1((Stp), "bad atom index 0 ([]) in %s", stp->file_name); \ + } else if ((Index) < (Stp)->num_atoms) { \ + Dest = (Stp)->atom[(Index)]; \ + } else { \ + LoadError2((Stp), "bad atom index %d in %s", (Index), stp->file_name); \ + } + +#ifdef DEBUG +# define GARBAGE 0xCC +# define DEBUG_INIT_GENOP(Dst) memset(Dst, GARBAGE, sizeof(GenOp)) +#else +# define DEBUG_INIT_GENOP(Dst) +#endif + +#define NEW_GENOP(Stp, Dst) \ + do { \ + if ((Stp)->free_genop == NULL) { \ + new_genop((Stp)); \ + } \ + Dst = (Stp)->free_genop; \ + (Stp)->free_genop = (Stp)->free_genop->next; \ + DEBUG_INIT_GENOP(Dst); \ + (Dst)->a = (Dst)->def_args; \ + } while (0) + +#define FREE_GENOP(Stp, Genop) \ + do { \ + if ((Genop)->a != (Genop)->def_args) { \ + erts_free(ERTS_ALC_T_LOADER_TMP, (Genop)->a); \ + } \ + (Genop)->next = (Stp)->free_genop; \ + (Stp)->free_genop = (Genop); \ + } while (0) + +#define GENOP_ARITY(Genop, Arity) \ + do { \ + ASSERT((Genop)->a == (Genop)->def_args); \ + (Genop)->arity = (Arity); \ + (Genop)->a = erts_alloc(ERTS_ALC_T_LOADER_TMP, \ + (Genop)->arity * sizeof(GenOpArg)); \ + } while (0) + + +static int bin_load(Process *c_p, ErtsProcLocks c_p_locks, + Eterm group_leader, Eterm* modp, byte* bytes, int unloaded_size); +static void init_state(LoaderState* stp); +static int insert_new_code(Process *c_p, ErtsProcLocks c_p_locks, + Eterm group_leader, Eterm module, + Eterm* code, Uint size, Uint catches); +static int scan_iff_file(LoaderState* stp, Uint* chunk_types, + Uint num_types, Uint num_mandatory); +static int load_atom_table(LoaderState* stp); +static int load_import_table(LoaderState* stp); +static int read_export_table(LoaderState* stp); +static int read_lambda_table(LoaderState* stp); +static int read_literal_table(LoaderState* stp); +static int read_code_header(LoaderState* stp); +static int load_code(LoaderState* stp); +static GenOp* gen_element(LoaderState* stp, GenOpArg Fail, GenOpArg Index, + GenOpArg Tuple, GenOpArg Dst); +static GenOp* gen_split_values(LoaderState* stp, GenOpArg S, GenOpArg Fail, + GenOpArg Size, GenOpArg* Rest); +static GenOp* gen_select_val(LoaderState* stp, GenOpArg S, GenOpArg Fail, + GenOpArg Size, GenOpArg* Rest); +static GenOp* gen_select_big(LoaderState* stp, GenOpArg S, GenOpArg Fail, + GenOpArg Size, GenOpArg* Rest); +static GenOp* const_select_val(LoaderState* stp, GenOpArg S, GenOpArg Fail, + GenOpArg Size, GenOpArg* Rest); +static GenOp* gen_func_info(LoaderState* stp, GenOpArg mod, GenOpArg Func, + GenOpArg arity, GenOpArg label); +static GenOp* +gen_guard_bif(LoaderState* stp, GenOpArg Fail, GenOpArg Live, GenOpArg Bif, + GenOpArg Src, GenOpArg Dst); + +static int freeze_code(LoaderState* stp); + +static void final_touch(LoaderState* stp); +static void short_file(int line, LoaderState* stp, unsigned needed); +static void load_printf(int line, LoaderState* context, char *fmt, ...); +static int transform_engine(LoaderState* st); +static void id_to_string(Uint id, char* s); +static void new_genop(LoaderState* stp); +static int get_int_val(LoaderState* stp, Uint len_code, Uint* result); +static int get_erlang_integer(LoaderState* stp, Uint len_code, Uint* result); +static int new_label(LoaderState* stp); +static void new_literal_patch(LoaderState* stp, int pos); +static void new_string_patch(LoaderState* stp, int pos); +static Uint new_literal(LoaderState* stp, Eterm** hpp, Uint heap_size); +static int genopargcompare(GenOpArg* a, GenOpArg* b); +static Eterm exported_from_module(Process* p, Eterm mod); +static Eterm functions_in_module(Process* p, Eterm mod); +static Eterm attributes_for_module(Process* p, Eterm mod); +static Eterm compilation_info_for_module(Process* p, Eterm mod); +static Eterm native_addresses(Process* p, Eterm mod); +int patch_funentries(Eterm Patchlist); +int patch(Eterm Addresses, Uint fe); +static int safe_mul(Uint a, Uint b, Uint* resp); + + +static int must_swap_floats; + +/* + * The following variables keep a sorted list of address ranges for + * each module. It allows us to quickly find a function given an + * instruction pointer. + */ +Range* modules = NULL; /* Sorted lists of module addresses. */ +int num_loaded_modules; /* Number of loaded modules. */ +int allocated_modules; /* Number of slots allocated. */ +Range* mid_module = NULL; /* Cached search start point */ + +Uint erts_total_code_size; +/**********************************************************************/ + + +void init_load(void) +{ + FloatDef f; + + erts_total_code_size = 0; + + beam_catches_init(); + + f.fd = 1.0; + must_swap_floats = (f.fw[0] == 0); + + allocated_modules = 128; + modules = (Range *) erts_alloc(ERTS_ALC_T_MODULE_REFS, + allocated_modules*sizeof(Range)); + mid_module = modules; + num_loaded_modules = 0; +} + +static void +define_file(LoaderState* stp, char* name, int idx) +{ + stp->file_name = name; + stp->file_p = stp->chunks[idx].start; + stp->file_left = stp->chunks[idx].size; +} + +int +erts_load_module(Process *c_p, + ErtsProcLocks c_p_locks, + Eterm group_leader, /* Group leader or NIL if none. */ + Eterm* modp, /* + * Module name as an atom (NIL to not check). + * On return, contains the actual module name. + */ + byte* code, /* Points to the code to load */ + int size) /* Size of code to load. */ +{ + ErlDrvBinary* bin; + int result; + + if (size >= 4 && code[0] == 'F' && code[1] == 'O' && + code[2] == 'R' && code[3] == '1') { + /* + * The BEAM module is not compressed. + */ + result = bin_load(c_p, c_p_locks, group_leader, modp, code, size); + } else { + /* + * The BEAM module is compressed (or possibly invalid/corrupted). + */ + if ((bin = (ErlDrvBinary *) erts_gzinflate_buffer((char*)code, size)) == NULL) { + return -1; + } + result = bin_load(c_p, c_p_locks, group_leader, modp, + (byte*)bin->orig_bytes, bin->orig_size); + driver_free_binary(bin); + } + return result; +} + + +static int +bin_load(Process *c_p, ErtsProcLocks c_p_locks, + Eterm group_leader, Eterm* modp, byte* bytes, int unloaded_size) +{ + LoaderState state; + int rval = -1; + + init_state(&state); + state.module = *modp; + state.group_leader = group_leader; + + /* + * Scan the IFF file. + */ + + state.file_name = "IFF header for Beam file"; + state.file_p = bytes; + state.file_left = unloaded_size; + if (!scan_iff_file(&state, chunk_types, NUM_CHUNK_TYPES, NUM_MANDATORY)) { + goto load_error; + } + + /* + * Read the header for the code chunk. + */ + + define_file(&state, "code chunk header", CODE_CHUNK); + if (!read_code_header(&state)) { + goto load_error; + } + + /* + * Read the atom table. + */ + + define_file(&state, "atom table", ATOM_CHUNK); + if (!load_atom_table(&state)) { + goto load_error; + } + + /* + * Read the import table. + */ + + define_file(&state, "import table", IMP_CHUNK); + if (!load_import_table(&state)) { + goto load_error; + } + + /* + * Read the lambda (fun) table. + */ + + if (state.chunks[LAMBDA_CHUNK].size > 0) { + define_file(&state, "lambda (fun) table", LAMBDA_CHUNK); + if (!read_lambda_table(&state)) { + goto load_error; + } + } + + /* + * Read the literal table. + */ + + if (state.chunks[LITERAL_CHUNK].size > 0) { + define_file(&state, "literals table (constant pool)", LITERAL_CHUNK); + if (!read_literal_table(&state)) { + goto load_error; + } + } + + /* + * Load the code chunk. + */ + + state.file_name = "code chunk"; + state.file_p = state.code_start; + state.file_left = state.code_size; + if (!load_code(&state) || !freeze_code(&state)) { + goto load_error; + } + + /* + * Read and validate the export table. (This must be done after + * loading the code, because it contains labels.) + */ + + define_file(&state, "export table", EXP_CHUNK); + if (!read_export_table(&state)) { + goto load_error; + } + + /* + * Ready for the final touch: fixing the export table entries for + * exported and imported functions. This can't fail. + */ + + rval = insert_new_code(c_p, c_p_locks, state.group_leader, state.module, + state.code, state.loaded_size, state.catches); + if (rval < 0) { + goto load_error; + } + final_touch(&state); + + /* + * Loading succeded. + */ + rval = 0; + state.code = NULL; /* Prevent code from being freed. */ + *modp = state.module; + + /* + * If there is an on_load function, signal an error to + * indicate that the on_load function must be run. + */ + if (state.on_load) { + rval = -5; + } + + load_error: + if (state.code != 0) { + erts_free(ERTS_ALC_T_CODE, state.code); + } + if (state.labels != NULL) { + erts_free(ERTS_ALC_T_LOADER_TMP, (void *) state.labels); + } + if (state.atom != NULL) { + erts_free(ERTS_ALC_T_LOADER_TMP, (void *) state.atom); + } + if (state.import != NULL) { + erts_free(ERTS_ALC_T_LOADER_TMP, (void *) state.import); + } + if (state.export != NULL) { + erts_free(ERTS_ALC_T_LOADER_TMP, (void *) state.export); + } + if (state.lambdas != state.def_lambdas) { + erts_free(ERTS_ALC_T_LOADER_TMP, (void *) state.lambdas); + } + if (state.literals != NULL) { + int i; + for (i = 0; i < state.num_literals; i++) { + if (state.literals[i].heap != NULL) { + erts_free(ERTS_ALC_T_LOADER_TMP, (void *) state.literals[i].heap); + } + } + erts_free(ERTS_ALC_T_LOADER_TMP, (void *) state.literals); + } + while (state.literal_patches != NULL) { + LiteralPatch* next = state.literal_patches->next; + erts_free(ERTS_ALC_T_LOADER_TMP, (void *) state.literal_patches); + state.literal_patches = next; + } + while (state.string_patches != NULL) { + StringPatch* next = state.string_patches->next; + erts_free(ERTS_ALC_T_LOADER_TMP, (void *) state.string_patches); + state.string_patches = next; + } + while (state.genop_blocks) { + GenOpBlock* next = state.genop_blocks->next; + erts_free(ERTS_ALC_T_LOADER_TMP, (void *) state.genop_blocks); + state.genop_blocks = next; + } + + return rval; +} + + +static void +init_state(LoaderState* stp) +{ + stp->function = THE_NON_VALUE; /* Function not known yet */ + stp->arity = 0; + stp->specific_op = -1; + stp->genop = NULL; + stp->atom = NULL; + stp->code = NULL; + stp->labels = NULL; + stp->import = NULL; + stp->export = NULL; + stp->free_genop = NULL; + stp->genop_blocks = NULL; + stp->num_lambdas = 0; + stp->lambdas_allocated = sizeof(stp->def_lambdas)/sizeof(Lambda); + stp->lambdas = stp->def_lambdas; + stp->lambda_error = NULL; + stp->num_literals = 0; + stp->allocated_literals = 0; + stp->literals = 0; + stp->total_literal_size = 0; + stp->literal_patches = 0; + stp->string_patches = 0; + stp->new_float_instructions = 0; + stp->may_load_nif = 0; + stp->on_load = 0; +} + +static int +insert_new_code(Process *c_p, ErtsProcLocks c_p_locks, + Eterm group_leader, Eterm module, Eterm* code, Uint size, Uint catches) +{ + Module* modp; + int rval; + int i; + + if ((rval = beam_make_current_old(c_p, c_p_locks, module)) < 0) { + erts_dsprintf_buf_t *dsbufp = erts_create_logger_dsbuf(); + erts_dsprintf(dsbufp, + "Module %T must be purged before loading\n", + module); + erts_send_error_to_logger(group_leader, dsbufp); + return rval; + } + + /* + * Update module table. + */ + + erts_total_code_size += size; + modp = erts_put_module(module); + modp->code = code; + modp->code_length = size; + modp->catches = catches; + + /* + * Update address table (used for finding a function from a PC value). + */ + + if (num_loaded_modules == allocated_modules) { + allocated_modules *= 2; + modules = (Range *) erts_realloc(ERTS_ALC_T_MODULE_REFS, + (void *) modules, + allocated_modules * sizeof(Range)); + } + for (i = num_loaded_modules; i > 0; i--) { + if (code > modules[i-1].start) { + break; + } + modules[i] = modules[i-1]; + } + modules[i].start = code; + modules[i].end = (Eterm *) (((byte *)code) + size); + num_loaded_modules++; + mid_module = &modules[num_loaded_modules/2]; + return 0; +} + +static int +scan_iff_file(LoaderState* stp, Uint* chunk_types, Uint num_types, Uint num_mandatory) +{ + MD5_CTX context; + Uint id; + Uint count; + int i; + + /* + * The binary must start with an IFF 'FOR1' chunk. + */ + + GetInt(stp, 4, id); + if (id != MakeIffId('F', 'O', 'R', '1')) { + LoadError0(stp, "not a BEAM file: no IFF 'FOR1' chunk"); + } + + /* + * Retrieve the chunk size and verify it. If the size is equal to + * or less than the size of the binary, it is ok and we will use it + * as the limit for the logical file size. + */ + + GetInt(stp, 4, count); + if (count > stp->file_left) { + LoadError2(stp, "form size %ld greater than size %ld of binary", + count, stp->file_left); + } + stp->file_left = count; + + /* + * Verify that this is a BEAM file. + */ + + GetInt(stp, 4, id); + if (id != MakeIffId('B', 'E', 'A', 'M')) { + LoadError0(stp, "not a BEAM file: IFF form type is not 'BEAM'"); + } + + /* + * Initialize the chunks[] array in the state. + */ + + for (i = 0; i < num_types; i++) { + stp->chunks[i].start = NULL; + stp->chunks[i].size = 0; + } + + /* + * Now we can go ahead and read all chunks in the BEAM form. + */ + + while (!EndOfFile(stp)) { + + /* + * Read the chunk id and verify that it contains ASCII characters. + */ + GetInt(stp, 4, id); + for (i = 0; i < 4; i++) { + unsigned c = (id >> i*8) & 0xff; + if (c < ' ' || c > 0x7E) { + LoadError1(stp, "non-ascii garbage '%lx' instead of chunk type id", + id); + } + } + + /* + * Read the count and verify it. + */ + + GetInt(stp, 4, count); + if (count > stp->file_left) { + LoadError2(stp, "chunk size %ld for '%lx' greater than size %ld of binary", + count, stp->file_left); + } + + /* + * See if the chunk is useful for the loader. + */ + for (i = 0; i < num_types; i++) { + if (chunk_types[i] == id) { + stp->chunks[i].start = stp->file_p; + stp->chunks[i].size = count; + break; + } + } + + /* + * Go on to the next chunk. + */ + count = 4*((count+3)/4); + stp->file_p += count; + stp->file_left -= count; + } + + /* + * At this point, we have read the entire IFF file, and we + * know that it is syntactically correct. + * + * Now check that it contains all mandatory chunks. At the + * same time calculate the MD5 for the module. + */ + + MD5Init(&context); + for (i = 0; i < num_mandatory; i++) { + if (stp->chunks[i].start != NULL) { + MD5Update(&context, stp->chunks[i].start, stp->chunks[i].size); + } else { + char sbuf[5]; + + id_to_string(chunk_types[i], sbuf); + LoadError1(stp, "mandatory chunk of type '%s' not found\n", sbuf); + } + } + if (LITERAL_CHUNK < num_types) { + if (stp->chunks[LAMBDA_CHUNK].start != 0) { + byte* start = stp->chunks[LAMBDA_CHUNK].start; + Uint left = stp->chunks[LAMBDA_CHUNK].size; + + /* + * The idea here is to ignore the OldUniq field for the fun; it is + * based on the old broken hash function, which can be different + * on little endian and big endian machines. + */ + if (left >= 4) { + static byte zero[4]; + MD5Update(&context, start, 4); + start += 4; + left -= 4; + + while (left >= 24) { + /* Include: Function Arity Index NumFree */ + MD5Update(&context, start, 20); + /* Set to zero: OldUniq */ + MD5Update(&context, zero, 4); + start += 24; + left -= 24; + } + } + /* Can't happen for a correct 'FunT' chunk */ + if (left > 0) { + MD5Update(&context, start, left); + } + } + if (stp->chunks[LITERAL_CHUNK].start != 0) { + MD5Update(&context, stp->chunks[LITERAL_CHUNK].start, + stp->chunks[LITERAL_CHUNK].size); + } + } + MD5Final(stp->mod_md5, &context); + return 1; + + load_error: + return 0; +} + + +static int +load_atom_table(LoaderState* stp) +{ + int i; + + GetInt(stp, 4, stp->num_atoms); + stp->num_atoms++; + stp->atom = erts_alloc(ERTS_ALC_T_LOADER_TMP, + erts_next_heap_size((stp->num_atoms*sizeof(Eterm)), + 0)); + + /* + * Read all atoms. + */ + + for (i = 1; i < stp->num_atoms; i++) { + byte* atom; + Uint n; + + GetByte(stp, n); + GetString(stp, atom, n); + stp->atom[i] = am_atom_put((char*)atom, n); + } + + /* + * Check the module name if a module name was given. + */ + + if (is_nil(stp->module)) { + stp->module = stp->atom[1]; + } else if (stp->atom[1] != stp->module) { + char sbuf[256]; + Atom* ap; + + ap = atom_tab(atom_val(stp->atom[1])); + memcpy(sbuf, ap->name, ap->len); + sbuf[ap->len] = '\0'; + LoadError1(stp, "module name in object code is %s", sbuf); + } + + return 1; + + load_error: + return 0; +} + + +static int +load_import_table(LoaderState* stp) +{ + int i; + + GetInt(stp, 4, stp->num_imports); + stp->import = erts_alloc(ERTS_ALC_T_LOADER_TMP, + erts_next_heap_size((stp->num_imports * + sizeof(ImportEntry)), + 0)); + for (i = 0; i < stp->num_imports; i++) { + int n; + Eterm mod; + Eterm func; + Uint arity; + Export* e; + + GetInt(stp, 4, n); + if (n >= stp->num_atoms) { + LoadError2(stp, "import entry %d: invalid atom number %d", i, n); + } + mod = stp->import[i].module = stp->atom[n]; + GetInt(stp, 4, n); + if (n >= stp->num_atoms) { + LoadError2(stp, "import entry %d: invalid atom number %d", i, n); + } + func = stp->import[i].function = stp->atom[n]; + GetInt(stp, 4, arity); + if (arity > MAX_REG) { + LoadError2(stp, "import entry %d: invalid arity %d", i, arity); + } + stp->import[i].arity = arity; + stp->import[i].patches = 0; + stp->import[i].bf = NULL; + + /* + * If the export entry refers to a BIF, get the pointer to + * the BIF function. + */ + if ((e = erts_find_export_entry(mod, func, arity)) != NULL) { + if (e->code[3] == (Uint) em_apply_bif) { + stp->import[i].bf = (BifFunction) e->code[4]; + if (func == am_load_nif && mod == am_erlang && arity == 2) { + stp->may_load_nif = 1; + } + } + } + } + return 1; + + load_error: + return 0; +} + + +static int +read_export_table(LoaderState* stp) +{ + static struct { + Eterm mod; + Eterm func; + int arity; + } allow_redef[] = { + /* The BIFs that are allowed to be redefined by Erlang code */ + {am_erlang,am_apply,2}, + {am_erlang,am_apply,3}, + }; + int i; + + GetInt(stp, 4, stp->num_exps); + if (stp->num_exps > stp->num_functions) { + LoadError2(stp, "%d functions exported; only %d functions defined", + stp->num_exps, stp->num_functions); + } + stp->export + = (ExportEntry *) erts_alloc(ERTS_ALC_T_LOADER_TMP, + (stp->num_exps * sizeof(ExportEntry))); + + for (i = 0; i < stp->num_exps; i++) { + Uint n; + Uint value; + Eterm func; + Uint arity; + Export* e; + + GetInt(stp, 4, n); + GetAtom(stp, n, func); + stp->export[i].function = func; + GetInt(stp, 4, arity); + if (arity > MAX_REG) { + LoadError2(stp, "export table entry %d: absurdly high arity %d", i, arity); + } + stp->export[i].arity = arity; + GetInt(stp, 4, n); + if (n >= stp->num_labels) { + LoadError3(stp, "export table entry %d: invalid label %d (highest defined label is %d)", i, n, stp->num_labels); + } + value = stp->labels[n].value; + if (value == 0) { + LoadError2(stp, "export table entry %d: label %d not resolved", i, n); + } + stp->export[i].address = stp->code + value; + + /* + * Check that we are not redefining a BIF (except the ones allowed to + * redefine). + */ + if ((e = erts_find_export_entry(stp->module, func, arity)) != NULL) { + if (e->code[3] == (Uint) em_apply_bif) { + int j; + + for (j = 0; j < sizeof(allow_redef)/sizeof(allow_redef[0]); j++) { + if (stp->module == allow_redef[j].mod && + func == allow_redef[j].func && + arity == allow_redef[j].arity) { + break; + } + } + if (j == sizeof(allow_redef)/sizeof(allow_redef[0])) { + LoadError2(stp, "exported function %T/%d redefines BIF", + func, arity); + } + } + } + } + return 1; + + load_error: + return 0; +} + +static int +read_lambda_table(LoaderState* stp) +{ + int i; + + GetInt(stp, 4, stp->num_lambdas); + stp->lambdas_allocated = stp->num_lambdas; + stp->lambdas = (Lambda *) erts_alloc(ERTS_ALC_T_LOADER_TMP, + stp->num_lambdas * sizeof(Lambda)); + for (i = 0; i < stp->num_lambdas; i++) { + Uint n; + Uint32 Index; + Uint32 OldUniq; + ErlFunEntry* fe; + Uint arity; + + GetInt(stp, 4, n); /* Function. */ + GetAtom(stp, n, stp->lambdas[i].function); + GetInt(stp, 4, arity); + if (arity > MAX_REG) { + LoadError2(stp, "lambda entry %d: absurdly high arity %d", i, arity); + } + stp->lambdas[i].arity = arity; + GetInt(stp, 4, n); + if (n >= stp->num_labels) { + LoadError3(stp, "lambda entry %d: invalid label %d (highest defined label is %d)", + i, n, stp->num_labels); + } + stp->lambdas[i].label = n; + GetInt(stp, 4, Index); + GetInt(stp, 4, stp->lambdas[i].num_free); + GetInt(stp, 4, OldUniq); + fe = erts_put_fun_entry2(stp->module, OldUniq, i, stp->mod_md5, + Index, arity-stp->lambdas[i].num_free); + stp->lambdas[i].fe = fe; + } + return 1; + + load_error: + return 0; +} + +static int +read_literal_table(LoaderState* stp) +{ + int i; + Uint uncompressed_sz; + byte* uncompressed = 0; + + GetInt(stp, 4, uncompressed_sz); + uncompressed = erts_alloc(ERTS_ALC_T_TMP, uncompressed_sz); + if (erl_zlib_uncompress(uncompressed, &uncompressed_sz, + stp->file_p, stp->file_left) != Z_OK) { + LoadError0(stp, "failed to uncompress literal table (constant pool)"); + } + stp->file_p = uncompressed; + stp->file_left = uncompressed_sz; + GetInt(stp, 4, stp->num_literals); + stp->literals = (Literal *) erts_alloc(ERTS_ALC_T_LOADER_TMP, + stp->num_literals * sizeof(Literal)); + stp->allocated_literals = stp->num_literals; + + for (i = 0; i < stp->num_literals; i++) { + stp->literals[i].heap = 0; + } + + for (i = 0; i < stp->num_literals; i++) { + int sz; + Sint heap_size; + byte* p; + Eterm val; + Eterm* hp; + + GetInt(stp, 4, sz); /* Size of external term format. */ + GetString(stp, p, sz); + if ((heap_size = erts_decode_ext_size(p, sz, 1)) < 0) { + LoadError1(stp, "literal %d: bad external format", i); + } + hp = stp->literals[i].heap = erts_alloc(ERTS_ALC_T_LOADER_TMP, + heap_size*sizeof(Eterm)); + val = erts_decode_ext(&hp, NULL, &p); + stp->literals[i].heap_size = hp - stp->literals[i].heap; + if (stp->literals[i].heap_size > heap_size) { + erl_exit(1, "overrun by %d word(s) for literal heap, term %d", + stp->literals[i].heap_size - heap_size, i); + } + if (is_non_value(val)) { + LoadError1(stp, "literal %d: bad external format", i); + } + stp->literals[i].term = val; + stp->total_literal_size += stp->literals[i].heap_size; + } + erts_free(ERTS_ALC_T_TMP, uncompressed); + return 1; + + load_error: + if (uncompressed) { + erts_free(ERTS_ALC_T_TMP, uncompressed); + } + return 0; +} + + +static int +read_code_header(LoaderState* stp) +{ + unsigned head_size; + unsigned version; + unsigned opcode_max; + int i; + + /* + * Read size of sub-header for code information and from it calculate + * where the code begins. Also, use the size to limit the file size + * for header reading, so that we automatically get an error if the + * size is set too small. + */ + + GetInt(stp, 4, head_size); + stp->code_start = stp->file_p + head_size; + stp->code_size = stp->file_left - head_size; + stp->file_left = head_size; + + /* + * Get and verify version of instruction set. + */ + + GetInt(stp, 4, version); + if (version != BEAM_FORMAT_NUMBER) { + LoadError2(stp, "wrong instruction set %d; expected %d", + version, BEAM_FORMAT_NUMBER); + } + + /* + * Verify the number of the highest opcode used. + */ + + GetInt(stp, 4, opcode_max); + if (opcode_max > MAX_GENERIC_OPCODE) { + LoadError2(stp, "use of opcode %d; this emulator supports only up to %d", + opcode_max, MAX_GENERIC_OPCODE); + } + + GetInt(stp, 4, stp->num_labels); + GetInt(stp, 4, stp->num_functions); + + /* + * Initialize label table. + */ + + stp->labels = (Label *) erts_alloc(ERTS_ALC_T_LOADER_TMP, + stp->num_labels * sizeof(Label)); + for (i = 0; i < stp->num_labels; i++) { + stp->labels[i].value = 0; + stp->labels[i].patches = 0; +#ifdef ERTS_SMP + stp->labels[i].looprec_targeted = 0; +#endif + } + + /* + * Initialize code area. + */ + stp->code_buffer_size = erts_next_heap_size(2048 + stp->num_functions, 0); + stp->code = (Eterm*) erts_alloc(ERTS_ALC_T_CODE, + sizeof(Eterm) * stp->code_buffer_size); + + stp->code[MI_NUM_FUNCTIONS] = stp->num_functions; + stp->ci = MI_FUNCTIONS + stp->num_functions + 1; + + stp->code[MI_ATTR_PTR] = 0; + stp->code[MI_ATTR_SIZE_ON_HEAP] = 0; + stp->code[MI_COMPILE_PTR] = 0; + stp->code[MI_COMPILE_SIZE_ON_HEAP] = 0; + stp->code[MI_NUM_BREAKPOINTS] = 0; + + stp->put_strings = 0; + stp->new_bs_put_strings = 0; + stp->catches = 0; + return 1; + + load_error: + return 0; +} + + +#define VerifyTag(Stp, Actual, Expected) \ + if (Actual != Expected) { \ + LoadError2(Stp, "bad tag %d; expected %d", Actual, Expected); \ + } else {} + +#define Need(w) \ + ASSERT(ci <= code_buffer_size); \ + if (code_buffer_size < ci+(w)) { \ + code_buffer_size = erts_next_heap_size(ci+(w), 0); \ + stp->code = code \ + = (Eterm *) erts_realloc(ERTS_ALC_T_CODE, \ + (void *) code, \ + code_buffer_size * sizeof(Eterm)); \ + } + + + +static int +load_code(LoaderState* stp) +{ + int i; + int tmp; + int ci; + int last_func_start = 0; + char* sign; + int arg; /* Number of current argument. */ + int num_specific; /* Number of specific ops for current. */ + Eterm* code; + int code_buffer_size; + int specific; + Uint last_label = 0; /* Number of last label. */ + Uint function_number = 0; + GenOp* last_op = NULL; + GenOp** last_op_next = NULL; + int arity; + + code = stp->code; + code_buffer_size = stp->code_buffer_size; + ci = stp->ci; + + for (;;) { + int new_op; + GenOp* tmp_op; + + ASSERT(ci <= code_buffer_size); + + get_next_instr: + GetByte(stp, new_op); + if (new_op >= NUM_GENERIC_OPS) { + LoadError1(stp, "invalid opcode %d", new_op); + } + if (gen_opc[new_op].name[0] == '\0') { + LoadError1(stp, "invalid opcode %d", new_op); + } + + + /* + * Create a new generic operation and put it last in the chain. + */ + if (last_op_next == NULL) { + last_op_next = &(stp->genop); + while (*last_op_next != NULL) { + last_op_next = &(*last_op_next)->next; + } + } + + NEW_GENOP(stp, last_op); + last_op->next = NULL; + last_op->op = new_op; + *last_op_next = last_op; + last_op_next = &(last_op->next); + stp->specific_op = -1; + + /* + * Read all arguments for the current operation. + */ + + arity = gen_opc[last_op->op].arity; + last_op->arity = 0; + ASSERT(arity <= MAX_OPARGS); + +#define GetValue(Stp, First, Val) \ + do { \ + if (((First) & 0x08) == 0) { \ + Val = (First) >> 4; \ + } else if (((First) & 0x10) == 0) { \ + Uint __w; \ + GetByte(Stp, __w); \ + Val = (((First) >> 5) << 8) | __w; \ + } else { \ + if (!get_int_val(Stp, (First), &(Val))) goto load_error; \ + } \ + } while (0) + + for (arg = 0; arg < arity; arg++) { + Uint first; + + GetByte(stp, first); + last_op->a[arg].type = first & 0x07; + switch (last_op->a[arg].type) { + case TAG_i: + if ((first & 0x08) == 0) { + last_op->a[arg].val = first >> 4; + } else if ((first & 0x10) == 0) { + Uint w; + GetByte(stp, w); + ASSERT(first < 0x800); + last_op->a[arg].val = ((first >> 5) << 8) | w; + } else { + int i = get_erlang_integer(stp, first, &(last_op->a[arg].val)); + if (i < 0) { + goto load_error; + } + last_op->a[arg].type = i; + } + break; + case TAG_u: + GetValue(stp, first, last_op->a[arg].val); + break; + case TAG_x: + GetValue(stp, first, last_op->a[arg].val); + if (last_op->a[arg].val == 0) { + last_op->a[arg].type = TAG_r; + } else if (last_op->a[arg].val >= MAX_REG) { + LoadError1(stp, "invalid x register number: %u", + last_op->a[arg].val); + } + break; + case TAG_y: + GetValue(stp, first, last_op->a[arg].val); + if (last_op->a[arg].val >= MAX_REG) { + LoadError1(stp, "invalid y register number: %u", + last_op->a[arg].val); + } + last_op->a[arg].val += CP_SIZE; + break; + case TAG_a: + GetValue(stp, first, last_op->a[arg].val); + if (last_op->a[arg].val == 0) { + last_op->a[arg].type = TAG_n; + } else if (last_op->a[arg].val >= stp->num_atoms) { + LoadError1(stp, "bad atom index: %d", last_op->a[arg].val); + } else { + last_op->a[arg].val = stp->atom[last_op->a[arg].val]; + } + break; + case TAG_f: + GetValue(stp, first, last_op->a[arg].val); + if (last_op->a[arg].val == 0) { + last_op->a[arg].type = TAG_p; + } else if (last_op->a[arg].val >= stp->num_labels) { + LoadError1(stp, "bad label: %d", last_op->a[arg].val); + } + break; + case TAG_h: + GetValue(stp, first, last_op->a[arg].val); + if (last_op->a[arg].val > 65535) { + LoadError1(stp, "invalid range for character data type: %u", + last_op->a[arg].val); + } + break; + case TAG_z: + { + Uint ext_tag; + unsigned tag; + + GetValue(stp, first, ext_tag); + switch (ext_tag) { + case 0: /* Floating point number */ + { + Eterm* hp; +# ifndef ARCH_64 + Uint high, low; +# endif + last_op->a[arg].val = new_literal(stp, &hp, + FLOAT_SIZE_OBJECT); + hp[0] = HEADER_FLONUM; + last_op->a[arg].type = TAG_q; +# ifdef ARCH_64 + GetInt(stp, 8, hp[1]); +# else + GetInt(stp, 4, high); + GetInt(stp, 4, low); + if (must_swap_floats) { + Uint t = high; + high = low; + low = t; + } + hp[1] = high; + hp[2] = low; +# endif + } + break; + case 1: /* List. */ + if (arg+1 != arity) { + LoadError0(stp, "list argument must be the last argument"); + } + GetTagAndValue(stp, tag, last_op->a[arg].val); + VerifyTag(stp, tag, TAG_u); + last_op->a[arg].type = TAG_u; + last_op->a = + erts_alloc(ERTS_ALC_T_LOADER_TMP, + (arity+last_op->a[arg].val) + *sizeof(GenOpArg)); + memcpy(last_op->a, last_op->def_args, + arity*sizeof(GenOpArg)); + arity += last_op->a[arg].val; + break; + case 2: /* Float register. */ + GetTagAndValue(stp, tag, last_op->a[arg].val); + VerifyTag(stp, tag, TAG_u); + last_op->a[arg].type = TAG_l; + break; + case 3: /* Allocation list. */ + { + Uint n; + Uint type; + Uint val; + Uint words = 0; + + stp->new_float_instructions = 1; + GetTagAndValue(stp, tag, n); + VerifyTag(stp, tag, TAG_u); + while (n-- > 0) { + GetTagAndValue(stp, tag, type); + VerifyTag(stp, tag, TAG_u); + GetTagAndValue(stp, tag, val); + VerifyTag(stp, tag, TAG_u); + switch (type) { + case 0: /* Heap words */ + words += val; + break; + case 1: + words += FLOAT_SIZE_OBJECT*val; + break; + default: + LoadError1(stp, "alloc list: bad allocation " + "descriptor %d", type); + break; + } + } + last_op->a[arg].type = TAG_u; + last_op->a[arg].val = words; + break; + } + case 4: /* Literal. */ + { + Uint val; + + GetTagAndValue(stp, tag, val); + VerifyTag(stp, tag, TAG_u); + if (val >= stp->num_literals) { + LoadError1(stp, "bad literal index %d", val); + } + last_op->a[arg].type = TAG_q; + last_op->a[arg].val = val; + break; + } + default: + LoadError1(stp, "invalid extended tag %d", ext_tag); + break; + } + } + break; + default: + LoadError1(stp, "bad tag %d", last_op->a[arg].type); + break; + } + last_op->arity++; + } +#undef GetValue + + ASSERT(arity == last_op->arity); + + do_transform: + if (stp->genop == NULL) { + last_op_next = NULL; + goto get_next_instr; + } + + if (gen_opc[stp->genop->op].transform != -1) { + int need; + tmp_op = stp->genop; + + for (need = gen_opc[stp->genop->op].min_window-1; need > 0; need--) { + if (tmp_op == NULL) { + goto get_next_instr; + } + tmp_op = tmp_op->next; + } + switch (transform_engine(stp)) { + case TE_FAIL: + last_op_next = NULL; + last_op = NULL; + break; + case TE_OK: + last_op_next = NULL; + last_op = NULL; + goto do_transform; + case TE_SHORT_WINDOW: + last_op_next = NULL; + last_op = NULL; + goto get_next_instr; + } + } + + if (stp->genop == NULL) { + last_op_next = NULL; + goto get_next_instr; + } + + /* + * Special error message instruction. + */ + if (stp->genop->op == genop_too_old_compiler_0) { + LoadError0(stp, "please re-compile this module with an " + ERLANG_OTP_RELEASE " compiler"); + } + + /* + * From the collected generic instruction, find the specific + * instruction. + */ + + { + Uint32 mask[3] = {0, 0, 0}; + + tmp_op = stp->genop; + arity = gen_opc[tmp_op->op].arity; + if (arity > 6) { + LoadError0(stp, "no specific operation found (arity > 6)"); + } + for (arg = 0; arg < arity; arg++) { + mask[arg/2] |= ((Uint32)1 << (tmp_op->a[arg].type)) << ((arg%2)*16); + } + specific = gen_opc[tmp_op->op].specific; + num_specific = gen_opc[tmp_op->op].num_specific; + for (i = 0; i < num_specific; i++) { + if (((opc[specific].mask[0] & mask[0]) == mask[0]) && + ((opc[specific].mask[1] & mask[1]) == mask[1]) && + ((opc[specific].mask[2] & mask[2]) == mask[2])) { + break; + } + specific++; + } + + /* + * No specific operation found. + */ + if (i == num_specific) { + stp->specific_op = -1; + for (arg = 0; arg < tmp_op->arity; arg++) { + /* + * We'll give the error message here (instead of earlier) + * to get a printout of the offending operation. + */ + if (tmp_op->a[arg].type == TAG_h) { + LoadError0(stp, "the character data type not supported"); + } + } + + /* + * No specific operations and no transformations means that + * the instruction is obsolete. + */ + if (num_specific == 0 && gen_opc[tmp_op->op].transform == -1) { + LoadError0(stp, "please re-compile this module with an " + ERLANG_OTP_RELEASE " compiler "); + } + + LoadError0(stp, "no specific operation found"); + } + + stp->specific_op = specific; + Need(opc[stp->specific_op].sz+2); /* Extra margin for packing */ + code[ci++] = BeamOpCode(stp->specific_op); + } + + /* + * Load the found specific operation. + */ + + sign = opc[stp->specific_op].sign; + ASSERT(sign != NULL); + arg = 0; + while (*sign) { + Uint tag; + + ASSERT(arg < stp->genop->arity); + tag = stp->genop->a[arg].type; + switch (*sign) { + case 'r': /* x(0) */ + case 'n': /* Nil */ + VerifyTag(stp, tag_to_letter[tag], *sign); + break; + case 'x': /* x(N) */ + case 'y': /* y(N) */ + VerifyTag(stp, tag_to_letter[tag], *sign); + code[ci++] = tmp_op->a[arg].val * sizeof(Eterm); + break; + case 'a': /* Tagged atom */ + VerifyTag(stp, tag_to_letter[tag], *sign); + code[ci++] = tmp_op->a[arg].val; + break; + case 'i': /* Tagged integer */ + ASSERT(is_small(tmp_op->a[arg].val)); + VerifyTag(stp, tag_to_letter[tag], *sign); + code[ci++] = tmp_op->a[arg].val; + break; + case 'c': /* Tagged constant */ + switch (tag) { + case TAG_i: + code[ci++] = make_small(tmp_op->a[arg].val); + break; + case TAG_a: + code[ci++] = tmp_op->a[arg].val; + break; + case TAG_n: + code[ci++] = NIL; + break; + case TAG_q: + new_literal_patch(stp, ci); + code[ci++] = tmp_op->a[arg].val; + break; + default: + LoadError1(stp, "bad tag %d for tagged constant", + tmp_op->a[arg].type); + break; + } + break; + case 's': /* Any source (tagged constant or register) */ + switch (tag) { + case TAG_r: + code[ci++] = make_rreg(); + break; + case TAG_x: + code[ci++] = make_xreg(tmp_op->a[arg].val); + break; + case TAG_y: + code[ci++] = make_yreg(tmp_op->a[arg].val); + break; + case TAG_i: + code[ci++] = make_small(tmp_op->a[arg].val); + break; + case TAG_a: + code[ci++] = tmp_op->a[arg].val; + break; + case TAG_n: + code[ci++] = NIL; + break; + default: + LoadError1(stp, "bad tag %d for general source", + tmp_op->a[arg].type); + break; + } + break; + case 'd': /* Destination (x(0), x(N), y(N) */ + switch (tag) { + case TAG_r: + code[ci++] = make_rreg(); + break; + case TAG_x: + code[ci++] = make_xreg(tmp_op->a[arg].val); + break; + case TAG_y: + code[ci++] = make_yreg(tmp_op->a[arg].val); + break; + default: + LoadError1(stp, "bad tag %d for destination", + tmp_op->a[arg].type); + break; + } + break; + case 'I': /* Untagged integer (or pointer). */ + VerifyTag(stp, tag, TAG_u); + code[ci++] = tmp_op->a[arg].val; + break; + case 't': /* Small untagged integer -- can be packed. */ + VerifyTag(stp, tag, TAG_u); + code[ci++] = tmp_op->a[arg].val; + break; + case 'A': /* Arity value. */ + VerifyTag(stp, tag, TAG_u); + code[ci++] = make_arityval(tmp_op->a[arg].val); + break; + case 'f': /* Destination label */ + VerifyTag(stp, tag_to_letter[tag], *sign); + code[ci] = stp->labels[tmp_op->a[arg].val].patches; + stp->labels[tmp_op->a[arg].val].patches = ci; + ci++; + break; + case 'j': /* 'f' or 'p' */ + if (tag == TAG_p) { + code[ci] = 0; + } else if (tag == TAG_f) { + code[ci] = stp->labels[tmp_op->a[arg].val].patches; + stp->labels[tmp_op->a[arg].val].patches = ci; + } else { + LoadError3(stp, "bad tag %d; expected %d or %d", + tag, TAG_f, TAG_p); + } + ci++; + break; + case 'L': /* Define label */ + ci--; /* Remove label from loaded code */ + ASSERT(stp->specific_op == op_label_L); + VerifyTag(stp, tag, TAG_u); + last_label = tmp_op->a[arg].val; + if (!(0 < last_label && last_label < stp->num_labels)) { + LoadError2(stp, "invalid label num %d (0 < label < %d)", + tmp_op->a[arg].val, stp->num_labels); + } + if (stp->labels[last_label].value != 0) { + LoadError1(stp, "label %d defined more than once", last_label); + } + stp->labels[last_label].value = ci; + ASSERT(stp->labels[last_label].patches < ci); + break; + case 'e': /* Export entry */ + VerifyTag(stp, tag, TAG_u); + if (tmp_op->a[arg].val >= stp->num_imports) { + LoadError1(stp, "invalid import table index %d", tmp_op->a[arg].val); + } + code[ci] = stp->import[tmp_op->a[arg].val].patches; + stp->import[tmp_op->a[arg].val].patches = ci; + ci++; + break; + case 'b': + VerifyTag(stp, tag, TAG_u); + i = tmp_op->a[arg].val; + if (i >= stp->num_imports) { + LoadError1(stp, "invalid import table index %d", i); + } + if (stp->import[i].bf == NULL) { + LoadError1(stp, "not a BIF: import table index %d", i); + } + code[ci++] = (Eterm) stp->import[i].bf; + break; + case 'P': /* Byte offset into tuple */ + VerifyTag(stp, tag, TAG_u); + tmp = tmp_op->a[arg].val; + code[ci++] = (Eterm) ((tmp_op->a[arg].val+1) * sizeof(Eterm *)); + break; + case 'l': /* Floating point register. */ + VerifyTag(stp, tag_to_letter[tag], *sign); + code[ci++] = tmp_op->a[arg].val * sizeof(FloatDef); + break; + case 'q': /* Literal */ + new_literal_patch(stp, ci); + code[ci++] = tmp_op->a[arg].val; + break; + default: + LoadError1(stp, "bad argument tag: %d", *sign); + } + sign++; + arg++; + } + + /* + * Load any list arguments using the primitive tags. + */ + + for ( ; arg < tmp_op->arity; arg++) { + switch (tmp_op->a[arg].type) { + case TAG_i: + Need(1); + code[ci++] = make_small(tmp_op->a[arg].val); + break; + case TAG_u: + case TAG_a: + case TAG_v: + Need(1); + code[ci++] = tmp_op->a[arg].val; + break; + case TAG_f: + Need(1); + code[ci] = stp->labels[tmp_op->a[arg].val].patches; + stp->labels[tmp_op->a[arg].val].patches = ci; + ci++; + break; + case TAG_q: + { + Eterm lit; + + lit = stp->literals[tmp_op->a[arg].val].term; + if (is_big(lit)) { + Eterm* bigp; + Uint size; + + bigp = big_val(lit); + size = bignum_header_arity(*bigp); + Need(size+1); + code[ci++] = *bigp++; + while (size-- > 0) { + code[ci++] = *bigp++; + } + } else if (is_float(lit)) { +#ifdef ARCH_64 + Need(1); + code[ci++] = float_val(stp->literals[tmp_op->a[arg].val].term)[1]; +#else + Eterm* fptr; + + fptr = float_val(stp->literals[tmp_op->a[arg].val].term)+1; + Need(2); + code[ci++] = *fptr++; + code[ci++] = *fptr; +#endif + } else { + LoadError0(stp, "literal is neither float nor big"); + } + } + break; + default: + LoadError1(stp, "unsupported primitive type '%c'", + tag_to_letter[tmp_op->a[arg].type]); + } + } + + /* + * The packing engine. + */ + if (opc[stp->specific_op].pack[0]) { + char* prog; /* Program for packing engine. */ + Uint stack[8]; /* Stack. */ + Uint* sp = stack; /* Points to next free position. */ + Uint packed = 0; /* Accumulator for packed operations. */ + + for (prog = opc[stp->specific_op].pack; *prog; prog++) { + switch (*prog) { + case 'g': /* Get instruction; push on stack. */ + *sp++ = code[--ci]; + break; + case 'i': /* Initialize packing accumulator. */ + packed = code[--ci]; + break; + case '0': /* Tight shift */ + packed = (packed << BEAM_TIGHT_SHIFT) | code[--ci]; + break; + case '6': /* Shift 16 steps */ + packed = (packed << 16) | code[--ci]; + break; + case 'p': /* Put instruction (from stack). */ + code[ci++] = *--sp; + break; + case 'P': /* Put packed operands. */ + *sp++ = packed; + packed = 0; + break; + default: + ASSERT(0); + } + } + ASSERT(sp == stack); /* Incorrect program? */ + } + + /* + * Handle a few special cases. + */ + switch (stp->specific_op) { + case op_i_func_info_IaaI: + { + Uint offset; + enum { FINFO_SZ = 5 }; + + if (function_number >= stp->num_functions) { + LoadError1(stp, "too many functions in module (header said %d)", + stp->num_functions); + } + + if (stp->may_load_nif) { + const int finfo_ix = ci - FINFO_SZ; + enum { MIN_FUNC_SZ = 3 }; + if (finfo_ix - last_func_start < MIN_FUNC_SZ && last_func_start) { + /* Must make room for call_nif op */ + int pad = MIN_FUNC_SZ - (finfo_ix - last_func_start); + ASSERT(pad > 0 && pad < MIN_FUNC_SZ); + Need(pad); + sys_memmove(&code[finfo_ix+pad], &code[finfo_ix], FINFO_SZ*sizeof(Eterm)); + sys_memset(&code[finfo_ix], 0, pad*sizeof(Eterm)); + ci += pad; + stp->labels[last_label].value += pad; + } + } + last_func_start = ci; + /* + * Save context for error messages. + */ + stp->function = code[ci-2]; + stp->arity = code[ci-1]; + ASSERT(stp->labels[last_label].value == ci - FINFO_SZ); + offset = MI_FUNCTIONS + function_number; + code[offset] = stp->labels[last_label].patches; + stp->labels[last_label].patches = offset; + function_number++; + if (stp->arity > MAX_ARG) { + LoadError1(stp, "too many arguments: %d", stp->arity); + } +#ifdef DEBUG + ASSERT(stp->labels[0].patches == 0); /* Should not be referenced. */ + for (i = 1; i < stp->num_labels; i++) { + ASSERT(stp->labels[i].patches < ci); + } +#endif + } + break; + case op_on_load: + ci--; /* Get rid of the instruction */ + + /* Remember offset for the on_load function. */ + stp->on_load = ci; + break; + case op_put_string_IId: + { + /* + * At entry: + * + * code[ci-4] &&lb_put_string_IId + * code[ci-3] length of string + * code[ci-2] offset into string table + * code[ci-1] destination register + * + * Since we don't know the address of the string table yet, + * just check the offset and length for validity, and use + * the instruction field as a link field to link all put_string + * instructions into a single linked list. At exit: + * + * code[ci-4] pointer to next put_string instruction (or 0 + * if this is the last) + */ + Uint offset = code[ci-2]; + Uint len = code[ci-3]; + unsigned strtab_size = stp->chunks[STR_CHUNK].size; + if (offset > strtab_size || offset + len > strtab_size) { + LoadError2(stp, "invalid string reference %d, size %d", offset, len); + } + code[ci-4] = stp->put_strings; + stp->put_strings = ci - 4; + } + break; + case op_bs_put_string_II: + { + /* + * At entry: + * + * code[ci-3] &&lb_i_new_bs_put_string_II + * code[ci-2] length of string + * code[ci-1] offset into string table + * + * Since we don't know the address of the string table yet, + * just check the offset and length for validity, and use + * the instruction field as a link field to link all put_string + * instructions into a single linked list. At exit: + * + * code[ci-3] pointer to next i_new_bs_put_string instruction (or 0 + * if this is the last) + */ + Uint offset = code[ci-1]; + Uint len = code[ci-2]; + unsigned strtab_size = stp->chunks[STR_CHUNK].size; + if (offset > strtab_size || offset + len > strtab_size) { + LoadError2(stp, "invalid string reference %d, size %d", offset, len); + } + code[ci-3] = stp->new_bs_put_strings; + stp->new_bs_put_strings = ci - 3; + } + break; + case op_i_bs_match_string_rfII: + case op_i_bs_match_string_xfII: + new_string_patch(stp, ci-1); + break; + + case op_catch_yf: + /* code[ci-3] &&lb_catch_yf + * code[ci-2] y-register offset in E + * code[ci-1] label; index tagged as CATCH at runtime + */ + code[ci-3] = stp->catches; + stp->catches = ci-3; + break; + + /* + * End of code found. + */ + case op_int_code_end: + stp->code_buffer_size = code_buffer_size; + stp->ci = ci; + return 1; + } + + /* + * Delete the generic instruction just loaded. + */ + { + GenOp* next = stp->genop->next; + FREE_GENOP(stp, stp->genop); + stp->genop = next; + goto do_transform; + } + } + +#undef Need + + load_error: + return 0; +} + + +#define succ(St, X, Y) ((X).type == (Y).type && (X).val + 1 == (Y).val) +#define succ2(St, X, Y) ((X).type == (Y).type && (X).val + 2 == (Y).val) +#define succ3(St, X, Y) ((X).type == (Y).type && (X).val + 3 == (Y).val) + +#ifdef NO_FPE_SIGNALS +#define no_fpe_signals(St) 1 +#else +#define no_fpe_signals(St) 0 +#endif + +/* + * Predicate that tests whether a jump table can be used. + */ + +static int +use_jump_tab(LoaderState* stp, GenOpArg Size, GenOpArg* Rest) +{ + Sint min, max; + Sint i; + + if (Size.val < 2 || Size.val % 2 != 0) { + return 0; + } + + /* we may be called with sequences of tagged fixnums or atoms; + return early in latter case, before we access the values */ + if (Rest[0].type != TAG_i || Rest[1].type != TAG_f) + return 0; + min = max = Rest[0].val; + for (i = 2; i < Size.val; i += 2) { + if (Rest[i].type != TAG_i || Rest[i+1].type != TAG_f) { + return 0; + } + if (Rest[i].val < min) { + min = Rest[i].val; + } else if (max < Rest[i].val) { + max = Rest[i].val; + } + } + + return max - min <= Size.val; +} + +/* + * Predicate to test whether all values in a table are big numbers. + */ + +static int +all_values_are_big(LoaderState* stp, GenOpArg Size, GenOpArg* Rest) +{ + int i; + + if (Size.val < 2 || Size.val % 2 != 0) { + return 0; + } + + for (i = 0; i < Size.val; i += 2) { + if (Rest[i].type != TAG_q) { + return 0; + } + if (is_not_big(stp->literals[Rest[i].val].term)) { + return 0; + } + if (Rest[i+1].type != TAG_f) { + return 0; + } + } + + return 1; +} + + +/* + * Predicate to test whether all values in a table have a fixed size. + */ + +static int +fixed_size_values(LoaderState* stp, GenOpArg Size, GenOpArg* Rest) +{ + int i; + + if (Size.val < 2 || Size.val % 2 != 0) { + return 0; + } + + for (i = 0; i < Size.val; i += 2) { + if (Rest[i+1].type != TAG_f) + return 0; + switch (Rest[i].type) { + case TAG_a: + case TAG_i: + case TAG_v: + break; + case TAG_q: + return is_float(stp->literals[Rest[i].val].term); + default: + return 0; + } + } + + return 1; +} + +static int +mixed_types(LoaderState* stp, GenOpArg Size, GenOpArg* Rest) +{ + int i; + Uint type; + + if (Size.val < 2 || Size.val % 2 != 0) { + return 0; + } + + type = Rest[0].type; + for (i = 0; i < Size.val; i += 2) { + if (Rest[i].type != type) + return 1; + } + + return 0; +} + +/* + * Generate an instruction for element/2. + */ + +static GenOp* +gen_element(LoaderState* stp, GenOpArg Fail, GenOpArg Index, + GenOpArg Tuple, GenOpArg Dst) +{ + GenOp* op; + + NEW_GENOP(stp, op); + op->op = genop_i_element_4; + op->arity = 4; + op->a[0] = Fail; + op->a[1] = Index; + op->a[2] = Tuple; + op->a[3] = Dst; + op->next = NULL; + + /* + * If safe, generate a faster instruction. + */ + + if (Index.type == TAG_i && Index.val > 0 && + (Tuple.type == TAG_r || Tuple.type == TAG_x || Tuple.type == TAG_y)) { + op->op = genop_i_fast_element_4; + op->a[1].type = TAG_u; + op->a[1].val = Index.val; + } + + return op; +} + +static GenOp* +gen_bs_save(LoaderState* stp, GenOpArg Reg, GenOpArg Index) +{ + GenOp* op; + + NEW_GENOP(stp, op); + op->op = genop_i_bs_save2_2; + op->arity = 2; + op->a[0] = Reg; + op->a[1] = Index; + if (Index.type == TAG_u) { + op->a[1].val = Index.val+1; + } else if (Index.type == TAG_a && Index.val == am_start) { + op->a[1].type = TAG_u; + op->a[1].val = 0; + } + op->next = NULL; + return op; +} + +static GenOp* +gen_bs_restore(LoaderState* stp, GenOpArg Reg, GenOpArg Index) +{ + GenOp* op; + + NEW_GENOP(stp, op); + op->op = genop_i_bs_restore2_2; + op->arity = 2; + op->a[0] = Reg; + op->a[1] = Index; + if (Index.type == TAG_u) { + op->a[1].val = Index.val+1; + } else if (Index.type == TAG_a && Index.val == am_start) { + op->a[1].type = TAG_u; + op->a[1].val = 0; + } + op->next = NULL; + return op; +} + +/* + * Generate the fastest instruction to fetch an integer from a binary. + */ + +static GenOp* +gen_get_integer2(LoaderState* stp, GenOpArg Fail, GenOpArg Ms, GenOpArg Live, + GenOpArg Size, GenOpArg Unit, + GenOpArg Flags, GenOpArg Dst) +{ + GenOp* op; + Uint bits; + + NEW_GENOP(stp, op); + + NATIVE_ENDIAN(Flags); + if (Size.type == TAG_i) { + if (!safe_mul(Size.val, Unit.val, &bits)) { + goto error; + } else if ((Flags.val & BSF_SIGNED) != 0) { + goto generic; + } else if (bits == 8) { + op->op = genop_i_bs_get_integer_8_3; + op->arity = 3; + op->a[0] = Ms; + op->a[1] = Fail; + op->a[2] = Dst; + } else if (bits == 16 && (Flags.val & BSF_LITTLE) == 0) { + op->op = genop_i_bs_get_integer_16_3; + op->arity = 3; + op->a[0] = Ms; + op->a[1] = Fail; + op->a[2] = Dst; + } else if (bits == 32 && (Flags.val & BSF_LITTLE) == 0) { + op->op = genop_i_bs_get_integer_32_4; + op->arity = 4; + op->a[0] = Ms; + op->a[1] = Fail; + op->a[2] = Live; + op->a[3] = Dst; + } else { + generic: + if (bits < SMALL_BITS) { + op->op = genop_i_bs_get_integer_small_imm_5; + op->arity = 5; + op->a[0] = Ms; + op->a[1].type = TAG_u; + op->a[1].val = bits; + op->a[2] = Fail; + op->a[3] = Flags; + op->a[4] = Dst; + } else { + op->op = genop_i_bs_get_integer_imm_6; + op->arity = 6; + op->a[0] = Ms; + op->a[1].type = TAG_u; + op->a[1].val = bits; + op->a[2] = Live; + op->a[3] = Fail; + op->a[4] = Flags; + op->a[5] = Dst; + } + } + } else if (Size.type == TAG_q) { + Eterm big = stp->literals[Size.val].term; + Uint bigval; + + if (!term_to_Uint(big, &bigval)) { + error: + op->op = genop_jump_1; + op->arity = 1; + op->a[0] = Fail; + } else { + if (!safe_mul(bigval, Unit.val, &bits)) { + goto error; + } + goto generic; + } + } else { + GenOp* op2; + NEW_GENOP(stp, op2); + + op->op = genop_i_fetch_2; + op->arity = 2; + op->a[0] = Ms; + op->a[1] = Size; + op->next = op2; + + op2->op = genop_i_bs_get_integer_4; + op2->arity = 4; + op2->a[0] = Fail; + op2->a[1] = Live; + op2->a[2].type = TAG_u; + op2->a[2].val = (Unit.val << 3) | Flags.val; + op2->a[3] = Dst; + op2->next = NULL; + return op; + } + op->next = NULL; + return op; +} + +/* + * Generate the fastest instruction to fetch a binary from a binary. + */ + +static GenOp* +gen_get_binary2(LoaderState* stp, GenOpArg Fail, GenOpArg Ms, GenOpArg Live, + GenOpArg Size, GenOpArg Unit, + GenOpArg Flags, GenOpArg Dst) +{ + GenOp* op; + NEW_GENOP(stp, op); + + NATIVE_ENDIAN(Flags); + if (Size.type == TAG_a && Size.val == am_all) { + if (Ms.type == Dst.type && Ms.val == Dst.val) { + op->op = genop_i_bs_get_binary_all_reuse_3; + op->arity = 3; + op->a[0] = Ms; + op->a[1] = Fail; + op->a[2] = Unit; + } else { + op->op = genop_i_bs_get_binary_all2_5; + op->arity = 5; + op->a[0] = Fail; + op->a[1] = Ms; + op->a[2] = Live; + op->a[3] = Unit; + op->a[4] = Dst; + } + } else if (Size.type == TAG_i) { + op->op = genop_i_bs_get_binary_imm2_6; + op->arity = 6; + op->a[0] = Fail; + op->a[1] = Ms; + op->a[2] = Live; + op->a[3].type = TAG_u; + if (!safe_mul(Size.val, Unit.val, &op->a[3].val)) { + goto error; + } + op->a[4] = Flags; + op->a[5] = Dst; + } else if (Size.type == TAG_q) { + Eterm big = stp->literals[Size.val].term; + Uint bigval; + + if (!term_to_Uint(big, &bigval)) { + error: + op->op = genop_jump_1; + op->arity = 1; + op->a[0] = Fail; + } else { + op->op = genop_i_bs_get_binary_imm2_6; + op->arity = 6; + op->a[0] = Fail; + op->a[1] = Ms; + op->a[2] = Live; + op->a[3].type = TAG_u; + if (!safe_mul(bigval, Unit.val, &op->a[3].val)) { + goto error; + } + op->a[4] = Flags; + op->a[5] = Dst; + } + } else { + op->op = genop_i_bs_get_binary2_6; + op->arity = 6; + op->a[0] = Fail; + op->a[1] = Ms; + op->a[2] = Live; + op->a[3] = Size; + op->a[4].type = TAG_u; + op->a[4].val = (Unit.val << 3) | Flags.val; + op->a[5] = Dst; + } + op->next = NULL; + return op; +} + +/* + * Predicate to test whether a heap binary should be generated. + */ + +static int +should_gen_heap_bin(LoaderState* stp, GenOpArg Src) +{ + return Src.val <= ERL_ONHEAP_BIN_LIMIT; +} + +/* + * Predicate to test whether a binary construction is too big. + */ + +static int +binary_too_big(LoaderState* stp, GenOpArg Size) +{ + return Size.type == TAG_u && ((Size.val >> (8*sizeof(Uint)-3)) != 0); +} + +static int +binary_too_big_bits(LoaderState* stp, GenOpArg Size) +{ + return Size.type == TAG_u && (((Size.val+7)/8) >> (8*sizeof(Uint)-3) != 0); +} + +#define new_float_allocation(Stp) ((Stp)->new_float_instructions) + +static GenOp* +gen_put_binary(LoaderState* stp, GenOpArg Fail,GenOpArg Size, + GenOpArg Unit, GenOpArg Flags, GenOpArg Src) +{ + GenOp* op; + NEW_GENOP(stp, op); + + NATIVE_ENDIAN(Flags); + if (Size.type == TAG_a && Size.val == am_all) { + op->op = genop_i_new_bs_put_binary_all_3; + op->arity = 3; + op->a[0] = Fail; + op->a[1] = Src; + op->a[2] = Unit; + } else if (Size.type == TAG_i) { + op->op = genop_i_new_bs_put_binary_imm_3; + op->arity = 3; + op->a[0] = Fail; + op->a[1].type = TAG_u; + if (safe_mul(Size.val, Unit.val, &op->a[1].val)) { + op->a[2] = Src; + } else { + op->op = genop_badarg_1; + op->arity = 1; + op->a[0] = Fail; + } + } else { + op->op = genop_i_new_bs_put_binary_4; + op->arity = 4; + op->a[0] = Fail; + op->a[1] = Size; + op->a[2].type = TAG_u; + op->a[2].val = (Unit.val << 3) | (Flags.val & 7); + op->a[3] = Src; + } + + op->next = NULL; + return op; +} + +static GenOp* +gen_put_integer(LoaderState* stp, GenOpArg Fail, GenOpArg Size, + GenOpArg Unit, GenOpArg Flags, GenOpArg Src) +{ + GenOp* op; + NEW_GENOP(stp, op); + + NATIVE_ENDIAN(Flags); + if (Size.type == TAG_i && Size.val < 0) { + error: + /* Negative size must fail */ + op->op = genop_badarg_1; + op->arity = 1; + op->a[0] = Fail; + } else if (Size.type == TAG_i) { + op->op = genop_i_new_bs_put_integer_imm_4; + op->arity = 4; + op->a[0] = Fail; + op->a[1].type = TAG_u; + if (!safe_mul(Size.val, Unit.val, &op->a[1].val)) { + goto error; + } + op->a[1].val = Size.val * Unit.val; + op->a[2].type = Flags.type; + op->a[2].val = (Flags.val & 7); + op->a[3] = Src; + } else if (Size.type == TAG_q) { + Eterm big = stp->literals[Size.val].term; + Uint bigval; + + if (!term_to_Uint(big, &bigval)) { + goto error; + } else { + op->op = genop_i_new_bs_put_integer_imm_4; + op->arity = 4; + op->a[0] = Fail; + op->a[1].type = TAG_u; + op->a[1].val = bigval * Unit.val; + op->a[2].type = Flags.type; + op->a[2].val = (Flags.val & 7); + op->a[3] = Src; + } + } else { + op->op = genop_i_new_bs_put_integer_4; + op->arity = 4; + op->a[0] = Fail; + op->a[1] = Size; + op->a[2].type = TAG_u; + op->a[2].val = (Unit.val << 3) | (Flags.val & 7); + op->a[3] = Src; + } + op->next = NULL; + return op; +} + +static GenOp* +gen_put_float(LoaderState* stp, GenOpArg Fail, GenOpArg Size, + GenOpArg Unit, GenOpArg Flags, GenOpArg Src) +{ + GenOp* op; + NEW_GENOP(stp, op); + + NATIVE_ENDIAN(Flags); + if (Size.type == TAG_i) { + op->op = genop_i_new_bs_put_float_imm_4; + op->arity = 4; + op->a[0] = Fail; + op->a[1].type = TAG_u; + if (!safe_mul(Size.val, Unit.val, &op->a[1].val)) { + op->op = genop_badarg_1; + op->arity = 1; + op->a[0] = Fail; + } else { + op->a[2] = Flags; + op->a[3] = Src; + } + } else { + op->op = genop_i_new_bs_put_float_4; + op->arity = 4; + op->a[0] = Fail; + op->a[1] = Size; + op->a[2].type = TAG_u; + op->a[2].val = (Unit.val << 3) | (Flags.val & 7); + op->a[3] = Src; + } + op->next = NULL; + return op; +} + +/* + * Generate an instruction to fetch a float from a binary. + */ + +static GenOp* +gen_get_float2(LoaderState* stp, GenOpArg Fail, GenOpArg Ms, GenOpArg Live, + GenOpArg Size, GenOpArg Unit, GenOpArg Flags, GenOpArg Dst) +{ + GenOp* op; + NEW_GENOP(stp, op); + + NATIVE_ENDIAN(Flags); + op->op = genop_i_bs_get_float2_6; + op->arity = 6; + op->a[0] = Fail; + op->a[1] = Ms; + op->a[2] = Live; + op->a[3] = Size; + op->a[4].type = TAG_u; + op->a[4].val = (Unit.val << 3) | Flags.val; + op->a[5] = Dst; + op->next = NULL; + return op; +} + +/* + * Generate the fastest instruction for bs_skip_bits. + */ + +static GenOp* +gen_skip_bits2(LoaderState* stp, GenOpArg Fail, GenOpArg Ms, + GenOpArg Size, GenOpArg Unit, GenOpArg Flags) +{ + GenOp* op; + + NATIVE_ENDIAN(Flags); + NEW_GENOP(stp, op); + if (Size.type == TAG_a && Size.val == am_all) { + op->op = genop_i_bs_skip_bits_all2_3; + op->arity = 3; + op->a[0] = Fail; + op->a[1] = Ms; + op->a[2] = Unit; + } else if (Size.type == TAG_i) { + op->op = genop_i_bs_skip_bits_imm2_3; + op->arity = 3; + op->a[0] = Fail; + op->a[1] = Ms; + op->a[2].type = TAG_u; + if (!safe_mul(Size.val, Unit.val, &op->a[2].val)) { + goto error; + } + } else if (Size.type == TAG_q) { + Eterm big = stp->literals[Size.val].term; + Uint bigval; + + if (!term_to_Uint(big, &bigval)) { + error: + op->op = genop_jump_1; + op->arity = 1; + op->a[0] = Fail; + } else { + op->op = genop_i_bs_skip_bits_imm2_3; + op->arity = 3; + op->a[0] = Fail; + op->a[1] = Ms; + op->a[2].type = TAG_u; + if (!safe_mul(bigval, Unit.val, &op->a[2].val)) { + goto error; + } + } + } else { + op->op = genop_i_bs_skip_bits2_4; + op->arity = 4; + op->a[0] = Fail; + op->a[1] = Ms; + op->a[2] = Size; + op->a[3] = Unit; + } + op->next = NULL; + return op; +} + +static int +smp(LoaderState* stp) +{ +#ifdef ERTS_SMP + return 1; +#else + return 0; +#endif +} + +/* + * Mark this label. + */ +static int +smp_mark_target_label(LoaderState* stp, GenOpArg L) +{ +#ifdef ERTS_SMP + ASSERT(L.type == TAG_f); + stp->labels[L.val].looprec_targeted = 1; +#endif + return 1; +} + +/* + * Test whether this label was targeted by a loop_rec/2 instruction. + */ + +static int +smp_already_locked(LoaderState* stp, GenOpArg L) +{ +#ifdef ERTS_SMP + ASSERT(L.type == TAG_u); + return stp->labels[L.val].looprec_targeted; +#else + return 0; +#endif +} + +/* + * Generate a timeout instruction for a literal timeout. + */ + +static GenOp* +gen_literal_timeout(LoaderState* stp, GenOpArg Fail, GenOpArg Time) +{ + GenOp* op; + Sint timeout; + + NEW_GENOP(stp, op); + op->op = genop_i_wait_timeout_2; + op->next = NULL; + op->arity = 2; + op->a[0] = Fail; + op->a[1].type = TAG_u; + + if (Time.type == TAG_i && (timeout = Time.val) >= 0 && +#ifdef ARCH_64 + (timeout >> 32) == 0 +#else + 1 +#endif + ) { + op->a[1].val = timeout; +#if !defined(ARCH_64) + } else if (Time.type == TAG_q) { + Eterm big; + + big = stp->literals[Time.val].term; + if (is_not_big(big)) { + goto error; + } + if (big_arity(big) > 1 || big_sign(big)) { + goto error; + } else { + (void) term_to_Uint(big, &op->a[1].val); + } +#endif + } else { +#if !defined(ARCH_64) + error: +#endif + op->op = genop_i_wait_error_0; + op->arity = 0; + } + return op; +} + +static GenOp* +gen_literal_timeout_locked(LoaderState* stp, GenOpArg Fail, GenOpArg Time) +{ + GenOp* op; + Sint timeout; + + NEW_GENOP(stp, op); + op->op = genop_i_wait_timeout_locked_2; + op->next = NULL; + op->arity = 2; + op->a[0] = Fail; + op->a[1].type = TAG_u; + + if (Time.type == TAG_i && (timeout = Time.val) >= 0 && +#ifdef ARCH_64 + (timeout >> 32) == 0 +#else + 1 +#endif + ) { + op->a[1].val = timeout; +#ifndef ARCH_64 + } else if (Time.type == TAG_q) { + Eterm big; + + big = stp->literals[Time.val].term; + if (is_not_big(big)) { + goto error; + } + if (big_arity(big) > 1 || big_sign(big)) { + goto error; + } else { + (void) term_to_Uint(big, &op->a[1].val); + } +#endif + } else { +#ifndef ARCH_64 + error: +#endif + op->op = genop_i_wait_error_locked_0; + op->arity = 0; + } + return op; +} + +/* + * Tag the list of values with tuple arity tags. + */ + +static GenOp* +gen_select_tuple_arity(LoaderState* stp, GenOpArg S, GenOpArg Fail, + GenOpArg Size, GenOpArg* Rest) + +{ + GenOp* op; + int arity = Size.val + 3; + int size = Size.val / 2; + int i; + + /* + * Verify the validity of the list. + */ + + if (Size.val % 2 != 0) + return NULL; + for (i = 0; i < Size.val; i += 2) { + if (Rest[i].type != TAG_u || Rest[i+1].type != TAG_f) { + return NULL; + } + } + + /* + * Generate the generic instruction. + */ + + NEW_GENOP(stp, op); + op->next = NULL; + op->op = genop_i_select_tuple_arity_3; + GENOP_ARITY(op, arity); + op->a[0] = S; + op->a[1] = Fail; + op->a[2].type = TAG_u; + op->a[2].val = Size.val / 2; + for (i = 0; i < Size.val; i += 2) { + op->a[i+3].type = TAG_v; + op->a[i+3].val = make_arityval(Rest[i].val); + op->a[i+4] = Rest[i+1]; + } + + /* + * Sort the values to make them useful for a binary search. + */ + + qsort(op->a+3, size, 2*sizeof(GenOpArg), + (int (*)(const void *, const void *)) genopargcompare); +#ifdef DEBUG + for (i = 3; i < arity-2; i += 2) { + ASSERT(op->a[i].val < op->a[i+2].val); + } +#endif + return op; +} + +/* + * Split a list consisting of both small and bignumbers into two + * select_val instructions. + */ + +static GenOp* +gen_split_values(LoaderState* stp, GenOpArg S, GenOpArg Fail, + GenOpArg Size, GenOpArg* Rest) + +{ + GenOp* op1; + GenOp* op2; + GenOp* label; + Uint type; + int i; + + ASSERT(Size.val >= 2 && Size.val % 2 == 0); + + NEW_GENOP(stp, label); + label->op = genop_label_1; + label->arity = 1; + label->a[0].type = TAG_u; + label->a[0].val = new_label(stp); + + NEW_GENOP(stp, op1); + op1->op = genop_select_val_3; + GENOP_ARITY(op1, 3 + Size.val); + op1->arity = 3; + op1->a[0] = S; + op1->a[1].type = TAG_f; + op1->a[1].val = label->a[0].val; + op1->a[2].type = TAG_u; + op1->a[2].val = 0; + + NEW_GENOP(stp, op2); + op2->op = genop_select_val_3; + GENOP_ARITY(op2, 3 + Size.val); + op2->arity = 3; + op2->a[0] = S; + op2->a[1] = Fail; + op2->a[2].type = TAG_u; + op2->a[2].val = 0; + + op1->next = label; + label->next = op2; + op2->next = NULL; + + type = Rest[0].type; + + ASSERT(Size.type == TAG_u); + for (i = 0; i < Size.val; i += 2) { + GenOp* op = (Rest[i].type == type) ? op1 : op2; + int dst = 3 + op->a[2].val; + + ASSERT(Rest[i+1].type == TAG_f); + op->a[dst] = Rest[i]; + op->a[dst+1] = Rest[i+1]; + op->arity += 2; + op->a[2].val += 2; + } + + /* + * None of the instructions should have zero elements in the list. + */ + + ASSERT(op1->a[2].val > 0); + ASSERT(op2->a[2].val > 0); + + return op1; +} + +/* + * Generate a jump table. + */ + +static GenOp* +gen_jump_tab(LoaderState* stp, GenOpArg S, GenOpArg Fail, GenOpArg Size, GenOpArg* Rest) +{ + Sint min, max; + Sint i; + Sint size; + Sint arity; + int fixed_args; + GenOp* op; + + ASSERT(Size.val >= 2 && Size.val % 2 == 0); + + /* + * Calculate the minimum and maximum values and size of jump table. + */ + + ASSERT(Rest[0].type == TAG_i); + min = max = Rest[0].val; + for (i = 2; i < Size.val; i += 2) { + ASSERT(Rest[i].type == TAG_i && Rest[i+1].type == TAG_f); + if (Rest[i].val < min) { + min = Rest[i].val; + } else if (max < Rest[i].val) { + max = Rest[i].val; + } + } + size = max - min + 1; + + + /* + * Allocate structure and fill in the fixed fields. + */ + + NEW_GENOP(stp, op); + op->next = NULL; + if (min == 0) { + op->op = genop_i_jump_on_val_zero_3; + fixed_args = 3; + } else { + op->op = genop_i_jump_on_val_4; + fixed_args = 4; + } + arity = fixed_args + size; + GENOP_ARITY(op, arity); + op->a[0] = S; + op->a[1] = Fail; + op->a[2].type = TAG_u; + op->a[2].val = size; + op->a[3].type = TAG_u; + op->a[3].val = min; + + + /* + * Fill in the jump table. + */ + + for (i = fixed_args; i < arity; i++) { + op->a[i] = Fail; + } + for (i = 0; i < Size.val; i += 2) { + int index; + index = fixed_args+Rest[i].val-min; + ASSERT(fixed_args <= index && index < arity); + op->a[index] = Rest[i+1]; + } + return op; +} + +/* + * Compare function for qsort(). + */ + +static int +genopargcompare(GenOpArg* a, GenOpArg* b) +{ + if (a->val < b->val) + return -1; + else if (a->val == b->val) + return 0; + else + return 1; +} + +/* + * Generate a select_val instruction. We know that a jump table is not suitable, + * and that all values are of the same type (integer, atoms, floats; never bignums). + */ + +static GenOp* +gen_select_val(LoaderState* stp, GenOpArg S, GenOpArg Fail, + GenOpArg Size, GenOpArg* Rest) +{ + GenOp* op; + int arity = Size.val + 3; + int size = Size.val / 2; + int i; + + NEW_GENOP(stp, op); + op->next = NULL; + if (Rest[0].type != TAG_q) { + op->op = genop_i_select_val_3; + } else { + ASSERT(is_float(stp->literals[Rest[0].val].term)); + op->op = genop_i_select_float_3; + } + GENOP_ARITY(op, arity); + op->a[0] = S; + op->a[1] = Fail; + op->a[2].type = TAG_u; + op->a[2].val = size; + for (i = 3; i < arity; i++) { + op->a[i] = Rest[i-3]; + } + + /* + * Sort the values to make them useful for a binary search. + */ + + qsort(op->a+3, size, 2*sizeof(GenOpArg), + (int (*)(const void *, const void *)) genopargcompare); +#ifdef DEBUG + for (i = 3; i < arity-2; i += 2) { + ASSERT(op->a[i].val < op->a[i+2].val); + } +#endif + + return op; +} + +/* + * Compare function for qsort(). + */ + +static int +genbigcompare(GenOpArg* a, GenOpArg* b) +{ + int val = (int)(b->bigarity - a->bigarity); + + return val != 0 ? val : ((int) (a->val - b->val)); +} + +/* + * Generate a select_val instruction for big numbers. + */ + +static GenOp* +gen_select_big(LoaderState* stp, GenOpArg S, GenOpArg Fail, + GenOpArg Size, GenOpArg* Rest) +{ + GenOp* op; + int arity = Size.val + 2 + 1; + int size = Size.val / 2; + int i; + + NEW_GENOP(stp, op); + op->next = NULL; + op->op = genop_i_select_big_2; + GENOP_ARITY(op, arity); + op->a[0] = S; + op->a[1] = Fail; + for (i = 0; i < Size.val; i += 2) { + ASSERT(Rest[i].type == TAG_q); + op->a[i+2] = Rest[i]; + op->a[i+2].bigarity = *big_val(stp->literals[op->a[i+2].val].term); + op->a[i+3] = Rest[i+1]; + } + ASSERT(i+2 == arity-1); + op->a[arity-1].type = TAG_u; + op->a[arity-1].val = 0; + + /* + * Sort the values in descending arity order. + */ + + qsort(op->a+2, size, 2*sizeof(GenOpArg), + (int (*)(const void *, const void *)) genbigcompare); + + return op; +} + + +/* + * Replace a select_val instruction with a constant controlling expression + * with a jump instruction. + */ + +static GenOp* +const_select_val(LoaderState* stp, GenOpArg S, GenOpArg Fail, + GenOpArg Size, GenOpArg* Rest) +{ + GenOp* op; + int i; + + ASSERT(Size.type == TAG_u); + ASSERT(S.type == TAG_q); + + NEW_GENOP(stp, op); + op->next = NULL; + op->op = genop_jump_1; + op->arity = 1; + + /* + * Search for a literal matching the controlling expression. + */ + + if (S.type == TAG_q) { + Eterm expr = stp->literals[S.val].term; + for (i = 0; i < Size.val; i += 2) { + if (Rest[i].type == TAG_q) { + Eterm term = stp->literals[Rest[i].val].term; + if (eq(term, expr)) { + ASSERT(Rest[i+1].type == TAG_f); + op->a[0] = Rest[i+1]; + return op; + } + } + } + } + + /* + * No match. Use the failure label. + */ + + op->a[0] = Fail; + return op; +} + + +static GenOp* +gen_func_info(LoaderState* stp, GenOpArg mod, GenOpArg func, + GenOpArg arity, GenOpArg label) +{ + GenOp* fi; + GenOp* op; + + NEW_GENOP(stp, fi); + fi->op = genop_i_func_info_4; + fi->arity = 4; + fi->a[0].type = TAG_u; /* untagged Zero */ + fi->a[0].val = 0; + fi->a[1] = mod; + fi->a[2] = func; + fi->a[3] = arity; + + NEW_GENOP(stp, op); + op->op = genop_label_1; + op->arity = 1; + op->a[0] = label; + + fi->next = op; + op->next = NULL; + + return fi; +} + + + +static GenOp* +gen_make_fun2(LoaderState* stp, GenOpArg idx) +{ + ErlFunEntry* fe; + GenOp* op; + + if (idx.val >= stp->num_lambdas) { + stp->lambda_error = "missing or short chunk 'FunT'"; + fe = 0; + } else { + fe = stp->lambdas[idx.val].fe; + } + + NEW_GENOP(stp, op); + op->op = genop_i_make_fun_2; + op->arity = 2; + op->a[0].type = TAG_u; + op->a[0].val = (Uint) fe; + op->a[1].type = TAG_u; + op->a[1].val = stp->lambdas[idx.val].num_free; + op->next = NULL; + return op; +} + +static GenOp* +gen_guard_bif(LoaderState* stp, GenOpArg Fail, GenOpArg Live, GenOpArg Bif, + GenOpArg Src, GenOpArg Dst) +{ + GenOp* op; + BifFunction bf; + + NEW_GENOP(stp, op); + op->op = genop_i_gc_bif1_5; + op->arity = 5; + op->a[0] = Fail; + op->a[1].type = TAG_u; + bf = stp->import[Bif.val].bf; + if (bf == length_1) { + op->a[1].val = (Uint) (void *) erts_gc_length_1; + } else if (bf == size_1) { + op->a[1].val = (Uint) (void *) erts_gc_size_1; + } else if (bf == bit_size_1) { + op->a[1].val = (Uint) (void *) erts_gc_bit_size_1; + } else if (bf == byte_size_1) { + op->a[1].val = (Uint) (void *) erts_gc_byte_size_1; + } else if (bf == abs_1) { + op->a[1].val = (Uint) (void *) erts_gc_abs_1; + } else if (bf == float_1) { + op->a[1].val = (Uint) (void *) erts_gc_float_1; + } else if (bf == round_1) { + op->a[1].val = (Uint) (void *) erts_gc_round_1; + } else if (bf == trunc_1) { + op->a[1].val = (Uint) (void *) erts_gc_trunc_1; + } else { + abort(); + } + op->a[2] = Src; + op->a[3] = Live; + op->a[4] = Dst; + op->next = NULL; + return op; +} + + +/* + * Freeze the code in memory, move the string table into place, + * resolve all labels. + */ + +static int +freeze_code(LoaderState* stp) +{ + Eterm* code = stp->code; + Uint index; + int i; + byte* str_table; + unsigned strtab_size = stp->chunks[STR_CHUNK].size; + unsigned attr_size = stp->chunks[ATTR_CHUNK].size; + unsigned compile_size = stp->chunks[COMPILE_CHUNK].size; + Uint size; + unsigned catches; + Sint decoded_size; + + /* + * Verify that there was a correct 'FunT' chunk if there were + * make_fun2 instructions in the file. + */ + + if (stp->lambda_error != NULL) { + LoadError0(stp, stp->lambda_error); + } + + + /* + * Calculate the final size of the code. + */ + + size = (stp->ci + stp->total_literal_size) * sizeof(Eterm) + + strtab_size + attr_size + compile_size; + + /* + * Move the code to its final location. + */ + + code = (Eterm *) erts_realloc(ERTS_ALC_T_CODE, (void *) code, size); + + /* + * Place a pointer to the op_int_code_end instruction in the + * function table in the beginning of the file. + */ + + code[MI_FUNCTIONS+stp->num_functions] = (Eterm) (code + stp->ci - 1); + + /* + * Store the pointer to the on_load function. + */ + + if (stp->on_load) { + code[MI_ON_LOAD_FUNCTION_PTR] = (Eterm) (code + stp->on_load); + } else { + code[MI_ON_LOAD_FUNCTION_PTR] = 0; + } + + /* + * Place the literal heap directly after the code and fix up all + * put_literal instructions that refer to it. + */ + { + Eterm* ptr; + Eterm* low; + Eterm* high; + LiteralPatch* lp; + + low = code+stp->ci; + high = low + stp->total_literal_size; + code[MI_LITERALS_START] = (Eterm) low; + code[MI_LITERALS_END] = (Eterm) high; + ptr = low; + for (i = 0; i < stp->num_literals; i++) { + Uint offset; + + sys_memcpy(ptr, stp->literals[i].heap, + stp->literals[i].heap_size*sizeof(Eterm)); + offset = ptr - stp->literals[i].heap; + stp->literals[i].offset = offset; + high = ptr + stp->literals[i].heap_size; + while (ptr < high) { + Eterm val = *ptr; + switch (primary_tag(val)) { + case TAG_PRIMARY_LIST: + case TAG_PRIMARY_BOXED: + *ptr++ = offset_ptr(val, offset); + break; + case TAG_PRIMARY_HEADER: + ptr++; + if (header_is_thing(val)) { + ptr += thing_arityval(val); + } + break; + default: + ptr++; + break; + } + } + ASSERT(ptr == high); + } + lp = stp->literal_patches; + while (lp != 0) { + Uint* op_ptr; + Uint literal; + Literal* lit; + + op_ptr = code + lp->pos; + lit = &stp->literals[op_ptr[0]]; + literal = lit->term; + if (is_boxed(literal) || is_list(literal)) { + literal = offset_ptr(literal, lit->offset); + } + op_ptr[0] = literal; + lp = lp->next; + } + stp->ci += stp->total_literal_size; + } + + /* + * Place the string table and, optionally, attributes, after the literal heap. + */ + + sys_memcpy(code+stp->ci, stp->chunks[STR_CHUNK].start, strtab_size); + str_table = (byte *) (code+stp->ci); + if (attr_size) { + byte* attr = str_table + strtab_size; + sys_memcpy(attr, stp->chunks[ATTR_CHUNK].start, stp->chunks[ATTR_CHUNK].size); + code[MI_ATTR_PTR] = (Eterm) attr; + code[MI_ATTR_SIZE] = (Eterm) stp->chunks[ATTR_CHUNK].size; + decoded_size = erts_decode_ext_size(attr, attr_size, 0); + if (decoded_size < 0) { + LoadError0(stp, "bad external term representation of module attributes"); + } + code[MI_ATTR_SIZE_ON_HEAP] = decoded_size; + } + if (compile_size) { + byte* compile_info = str_table + strtab_size + attr_size; + sys_memcpy(compile_info, stp->chunks[COMPILE_CHUNK].start, + stp->chunks[COMPILE_CHUNK].size); + code[MI_COMPILE_PTR] = (Eterm) compile_info; + code[MI_COMPILE_SIZE] = (Eterm) stp->chunks[COMPILE_CHUNK].size; + decoded_size = erts_decode_ext_size(compile_info, compile_size, 0); + if (decoded_size < 0) { + LoadError0(stp, "bad external term representation of compilation information"); + } + code[MI_COMPILE_SIZE_ON_HEAP] = decoded_size; + } + + + /* + * Go through all put_strings instructions, restore the pointer to + * the instruction and convert string offsets to pointers (to the + * LAST character). + */ + + index = stp->put_strings; + while (index != 0) { + Uint next = code[index]; + code[index] = BeamOpCode(op_put_string_IId); + code[index+2] = (Uint) (str_table + code[index+2] + code[index+1] - 1); + index = next; + } + + /* + * Go through all i_new_bs_put_strings instructions, restore the pointer to + * the instruction and convert string offsets to pointers (to the + * FIRST character). + */ + + index = stp->new_bs_put_strings; + while (index != 0) { + Uint next = code[index]; + code[index] = BeamOpCode(op_bs_put_string_II); + code[index+2] = (Uint) (str_table + code[index+2]); + index = next; + } + + { + StringPatch* sp = stp->string_patches; + + while (sp != 0) { + Uint* op_ptr; + byte* strp; + + op_ptr = code + sp->pos; + strp = str_table + op_ptr[0]; + op_ptr[0] = (Eterm) strp; + sp = sp->next; + } + } + + /* + * Resolve all labels. + */ + + for (i = 0; i < stp->num_labels; i++) { + Uint this_patch; + Uint next_patch; + Uint value = stp->labels[i].value; + + if (value == 0 && stp->labels[i].patches != 0) { + LoadError1(stp, "label %d not resolved", i); + } + ASSERT(value < stp->ci); + this_patch = stp->labels[i].patches; + while (this_patch != 0) { + ASSERT(this_patch < stp->ci); + next_patch = code[this_patch]; + ASSERT(next_patch < stp->ci); + code[this_patch] = (Uint) (code + value); + this_patch = next_patch; + } + } + + /* + * Fix all catch_yf instructions. + */ + index = stp->catches; + catches = BEAM_CATCHES_NIL; + while (index != 0) { + Uint next = code[index]; + code[index] = BeamOpCode(op_catch_yf); + catches = beam_catches_cons((Uint*)code[index+2], catches); + code[index+2] = make_catch(catches); + index = next; + } + stp->catches = catches; + + /* + * Save the updated code pointer and code size. + */ + + stp->code = code; + stp->loaded_size = size; + + return 1; + + load_error: + /* + * Make sure that the caller frees the newly reallocated block, and + * not the old one (in case it has moved). + */ + stp->code = code; + return 0; +} + + +static void +final_touch(LoaderState* stp) +{ + int i; + int on_load = stp->on_load; + + /* + * Export functions. + */ + + for (i = 0; i < stp->num_exps; i++) { + Export* ep = erts_export_put(stp->module, stp->export[i].function, + stp->export[i].arity); + if (!on_load) { + ep->address = stp->export[i].address; + } else { + /* + * Don't make any of the exported functions + * callable yet. + */ + ep->address = ep->code+3; + ep->code[4] = (Eterm) stp->export[i].address; + } + } + + /* + * Import functions and patch all callers. + */ + + for (i = 0; i < stp->num_imports; i++) { + Eterm mod; + Eterm func; + Uint arity; + Uint import; + Uint current; + Uint next; + + mod = stp->import[i].module; + func = stp->import[i].function; + arity = stp->import[i].arity; + import = (Uint) erts_export_put(mod, func, arity); + current = stp->import[i].patches; + while (current != 0) { + ASSERT(current < stp->ci); + next = stp->code[current]; + stp->code[current] = import; + current = next; + } + } + + /* + * Fix all funs. + */ + + if (stp->num_lambdas > 0) { + for (i = 0; i < stp->num_lambdas; i++) { + unsigned entry_label = stp->lambdas[i].label; + ErlFunEntry* fe = stp->lambdas[i].fe; + Eterm* code_ptr = (Eterm *) (stp->code + stp->labels[entry_label].value); + + if (fe->address[0] != 0) { + /* + * We are hiding a pointer into older code. + */ + erts_refc_dec(&fe->refc, 1); + } + fe->address = code_ptr; +#ifdef HIPE + hipe_set_closure_stub(fe, stp->lambdas[i].num_free); +#endif + } + } +} + + +static int +transform_engine(LoaderState* st) +{ + Uint op; + int ap; /* Current argument. */ + Uint* restart; /* Where to restart if current match fails. */ + GenOpArg def_vars[TE_MAX_VARS]; /* Default buffer for variables. */ + GenOpArg* var = def_vars; + int i; /* General index. */ + Uint mask; + GenOp* instr; + Uint* pc; + int rval; + + ASSERT(gen_opc[st->genop->op].transform != -1); + pc = op_transform + gen_opc[st->genop->op].transform; + restart = pc; + + restart: + if (var != def_vars) { + erts_free(ERTS_ALC_T_LOADER_TMP, (void *) var); + var = def_vars; + } + ASSERT(restart != NULL); + pc = restart; + ASSERT(*pc < NUM_TOPS); /* Valid instruction? */ + ASSERT(*pc == TOP_try_me_else || *pc == TOP_fail); + instr = st->genop; + +#define RETURN(r) rval = (r); goto do_return; + +#ifdef DEBUG + restart = NULL; +#endif + ap = 0; + for (;;) { + op = *pc++; + + switch (op) { + case TOP_is_op: + if (instr == NULL) { + /* + * We'll need at least one more instruction to decide whether + * this combination matches or not. + */ + RETURN(TE_SHORT_WINDOW); + } + if (*pc++ != instr->op) + goto restart; + break; + case TOP_is_type: + mask = *pc++; + + ASSERT(ap < instr->arity); + ASSERT(instr->a[ap].type < BEAM_NUM_TAGS); + if (((1 << instr->a[ap].type) & mask) == 0) + goto restart; + break; + case TOP_pred: + i = *pc++; + switch (i) { +#define RVAL i +#include "beam_pred_funcs.h" +#undef RVAL + default: + ASSERT(0); + } + if (i == 0) + goto restart; + break; + case TOP_is_eq: + ASSERT(ap < instr->arity); + if (*pc++ != instr->a[ap].val) + goto restart; + break; + case TOP_is_same_var: + ASSERT(ap < instr->arity); + i = *pc++; + ASSERT(i < TE_MAX_VARS); + if (var[i].type != instr->a[ap].type) + goto restart; + switch (var[i].type) { + case TAG_r: case TAG_n: break; + default: + if (var[i].val != instr->a[ap].val) + goto restart; + } + break; +#if defined(TOP_is_bif) + case TOP_is_bif: + { + int bif_number = *pc++; + + /* + * In debug build, the type must be 'u'. + * In a real build, don't match. (I.e. retain the original + * call instruction, this will work, but it will be a + * slight performance loss.) + */ + + ASSERT(instr->a[ap].type == TAG_u); + if (instr->a[ap].type != TAG_u) + goto restart; + + /* + * In debug build, the assertion will catch invalid indexes + * immediately. In a real build, the loader will issue + * an diagnostic later when the instruction is loaded. + */ + + i = instr->a[ap].val; + ASSERT(i < st->num_imports); + if (i >= st->num_imports || st->import[i].bf == NULL) + goto restart; + if (bif_number != -1 && + bif_export[bif_number]->code[4] != (Uint) st->import[i].bf) { + goto restart; + } + } + break; + +#endif +#if defined(TOP_is_not_bif) + case TOP_is_not_bif: + { + pc++; + + /* + * In debug build, the type must be 'u'. + */ + + ASSERT(instr->a[ap].type == TAG_u); + if (instr->a[ap].type != TAG_u) { + goto restart; + } + i = instr->a[ap].val; + + /* + * erlang:apply/2,3 are strange. They exist as (dummy) BIFs + * so that they are included in the export table before + * the erlang module is loaded. They also exist in the erlang + * module as functions. When used in code, a special Beam + * instruction is used. + * + * Below we specially recognize erlang:apply/2,3 as special. + * This is necessary because after setting a trace pattern on + * them, you cannot no longer see from the export entry that + * they are special. + */ + if (i < st->num_imports) { + if (st->import[i].bf != NULL || + (st->import[i].module == am_erlang && + st->import[i].function == am_apply && + (st->import[i].arity == 2 || st->import[i].arity == 3))) { + goto restart; + } + } + } + break; + +#endif +#if defined(TOP_is_func) + case TOP_is_func: + { + Eterm mod = *pc++; + Eterm func = *pc++; + int arity = *pc++; + + ASSERT(instr->a[ap].type == TAG_u); + if (instr->a[ap].type != TAG_u) { + goto restart; + } + i = instr->a[ap].val; + ASSERT(i < st->num_imports); + if (i >= st->num_imports || st->import[i].module != mod || + st->import[i].function != func || + (arity < MAX_ARG && st->import[i].arity != arity)) { + goto restart; + } + } + break; +#endif + case TOP_set_var_next_arg: + ASSERT(ap < instr->arity); + i = *pc++; + ASSERT(i < TE_MAX_VARS); + var[i].type = instr->a[ap].type; + var[i].val = instr->a[ap].val; + ap++; + break; + +#if defined(TOP_rest_args) + case TOP_rest_args: + { + int n = *pc++; + var = erts_alloc(ERTS_ALC_T_LOADER_TMP, + instr->arity * sizeof(GenOpArg)); + for (i = 0; i < n; i++) { + var[i] = def_vars[i]; + } + while (i < instr->arity) { + var[i] = instr->a[i]; + i++; + } + } + break; +#endif + + case TOP_next_arg: + ap++; + break; + case TOP_next_instr: + instr = instr->next; + ap = 0; + break; + case TOP_commit: + instr = instr->next; /* The next_instr was optimized away. */ + + /* + * The left-hand side of this transformation matched. + * Delete all matched instructions. + */ + while (st->genop != instr) { + GenOp* next = st->genop->next; + FREE_GENOP(st, st->genop); + st->genop = next; + } +#ifdef DEBUG + instr = 0; +#endif + break; + +#if defined(TOP_call) + case TOP_call: + { + GenOp** lastp; + GenOp* new_instr; + + i = *pc++; + switch (i) { +#define RVAL new_instr +#include "beam_tr_funcs.h" +#undef RVAL + default: + new_instr = NULL; /* Silence compiler warning. */ + ASSERT(0); + } + if (new_instr == NULL) { + goto restart; + } + + lastp = &new_instr; + while (*lastp != NULL) { + lastp = &((*lastp)->next); + } + + instr = instr->next; /* The next_instr was optimized away. */ + + /* + * The left-hand side of this transformation matched. + * Delete all matched instructions. + */ + while (st->genop != instr) { + GenOp* next = st->genop->next; + FREE_GENOP(st, st->genop); + st->genop = next; + } + *lastp = st->genop; + st->genop = new_instr; + } + break; +#endif + case TOP_new_instr: + /* + * Note that the instructions are generated in reverse order. + */ + NEW_GENOP(st, instr); + instr->next = st->genop; + st->genop = instr; + ap = 0; + break; + case TOP_store_op: + instr->op = *pc++; + instr->arity = *pc++; + break; + case TOP_store_type: + i = *pc++; + instr->a[ap].type = i; + instr->a[ap].val = 0; + break; + case TOP_store_val: + i = *pc++; + instr->a[ap].val = i; + break; + case TOP_store_var: + i = *pc++; + ASSERT(i < TE_MAX_VARS); + instr->a[ap].type = var[i].type; + instr->a[ap].val = var[i].val; + break; + case TOP_try_me_else: + restart = pc + 1; + restart += *pc++; + ASSERT(*pc < NUM_TOPS); /* Valid instruction? */ + break; + case TOP_end: + RETURN(TE_OK); + case TOP_fail: + RETURN(TE_FAIL) + default: + ASSERT(0); + } + } +#undef RETURN + + do_return: + if (var != def_vars) { + erts_free(ERTS_ALC_T_LOADER_TMP, (void *) var); + } + return rval; +} + + +static void +short_file(int line, LoaderState* stp, unsigned needed) +{ + load_printf(line, stp, "unexpected end of %s when reading %d byte(s)", + stp->file_name, needed); +} + + +static void +load_printf(int line, LoaderState* context, char *fmt,...) +{ + erts_dsprintf_buf_t *dsbufp; + va_list va; + + if (is_non_value(context->module)) { + /* Suppressed by code:get_chunk/2 */ + return; + } + + dsbufp = erts_create_logger_dsbuf(); + + erts_dsprintf(dsbufp, "%s(%d): Error loading ", __FILE__, line); + + if (is_atom(context->function)) + erts_dsprintf(dsbufp, "function %T:%T/%d", context->module, + context->function, context->arity); + else + erts_dsprintf(dsbufp, "module %T", context->module); + + if (context->genop) + erts_dsprintf(dsbufp, ": op %s", gen_opc[context->genop->op].name); + + if (context->specific_op != -1) + erts_dsprintf(dsbufp, ": %s", opc[context->specific_op].sign); + else if (context->genop) { + int i; + for (i = 0; i < context->genop->arity; i++) + erts_dsprintf(dsbufp, " %c", + tag_to_letter[context->genop->a[i].type]); + } + + erts_dsprintf(dsbufp, ":\n "); + + va_start(va, fmt); + erts_vdsprintf(dsbufp, fmt, va); + va_end(va); + + erts_dsprintf(dsbufp, "\n"); +#ifdef DEBUG + erts_fprintf(stderr, "%s", dsbufp->str); +#endif + erts_send_error_to_logger(context->group_leader, dsbufp); +} + + +static int +get_int_val(LoaderState* stp, Uint len_code, Uint* result) +{ + Uint count; + Uint val; + + len_code >>= 5; + ASSERT(len_code < 8); + if (len_code == 7) { + LoadError0(stp, "can't load integers bigger than 8 bytes yet\n"); + } + count = len_code + 2; + if (count == 5) { + Uint msb; + GetByte(stp, msb); + if (msb == 0) { + count--; + } + GetInt(stp, 4, *result); + } else if (count <= 4) { + GetInt(stp, count, val); + *result = ((val << 8*(sizeof(val)-count)) >> 8*(sizeof(val)-count)); + } else { + LoadError1(stp, "too big integer; %d bytes\n", count); + } + return 1; + + load_error: + return 0; +} + + +static int +get_erlang_integer(LoaderState* stp, Uint len_code, Uint* result) +{ + Uint count; + Sint val; + byte default_buf[128]; + byte* bigbuf = default_buf; + byte* s; + int i; + int neg = 0; + Uint arity; + Eterm* hp; + + /* + * Retrieve the size of the value in bytes. + */ + + len_code >>= 5; + if (len_code < 7) { + count = len_code + 2; + } else { + Uint tag; + + ASSERT(len_code == 7); + GetTagAndValue(stp, tag, len_code); + VerifyTag(stp, TAG_u, tag); + count = len_code + 9; + } + + /* + * Handle values up to the size of an int, meaning either a small or bignum. + */ + + if (count <= sizeof(val)) { + GetInt(stp, count, val); + + val = ((val << 8*(sizeof(val)-count)) >> 8*(sizeof(val)-count)); + if (IS_SSMALL(val)) { + *result = val; + return TAG_i; + } else { + *result = new_literal(stp, &hp, BIG_UINT_HEAP_SIZE); + (void) small_to_big(val, hp); + return TAG_q; + } + } + + /* + * Make sure that the number will fit in our temporary buffer + * (including margin). + */ + + if (count+8 > sizeof(default_buf)) { + bigbuf = erts_alloc(ERTS_ALC_T_LOADER_TMP, count+8); + } + + /* + * Copy the number reversed to our temporary buffer. + */ + + GetString(stp, s, count); + for (i = 0; i < count; i++) { + bigbuf[count-i-1] = *s++; + } + + /* + * Check if the number is negative, and negate it if so. + */ + + if ((bigbuf[count-1] & 0x80) != 0) { + unsigned carry = 1; + + neg = 1; + for (i = 0; i < count; i++) { + bigbuf[i] = ~bigbuf[i] + carry; + carry = (bigbuf[i] == 0 && carry == 1); + } + ASSERT(carry == 0); + } + + /* + * Align to word boundary. + */ + + if (bigbuf[count-1] == 0) { + count--; + } + if (bigbuf[count-1] == 0) { + LoadError0(stp, "bignum not normalized"); + } + while (count % sizeof(Eterm) != 0) { + bigbuf[count++] = 0; + } + + /* + * Allocate heap space for the bignum and copy it. + */ + + arity = count/sizeof(Eterm); + *result = new_literal(stp, &hp, arity+1); + (void) bytes_to_big(bigbuf, count, neg, hp); + + if (bigbuf != default_buf) { + erts_free(ERTS_ALC_T_LOADER_TMP, (void *) bigbuf); + } + return TAG_q; + + load_error: + if (bigbuf != default_buf) { + erts_free(ERTS_ALC_T_LOADER_TMP, (void *) bigbuf); + } + return -1; +} + +/* + * Converts an IFF id to a printable string. + */ + +static void +id_to_string(Uint id, char* s) +{ + int i; + + for (i = 3; i >= 0; i--) { + *s++ = (id >> i*8) & 0xff; + } + *s++ = '\0'; +} + +static void +new_genop(LoaderState* stp) +{ + GenOpBlock* p = (GenOpBlock *) erts_alloc(ERTS_ALC_T_LOADER_TMP, + sizeof(GenOpBlock)); + int i; + + p->next = stp->genop_blocks; + stp->genop_blocks = p; + for (i = 0; i < sizeof(p->genop)/sizeof(p->genop[0])-1; i++) { + p->genop[i].next = p->genop + i + 1; + } + p->genop[i].next = NULL; + stp->free_genop = p->genop; +} + +static int +new_label(LoaderState* stp) +{ + int num = stp->num_labels; + + stp->num_labels++; + stp->labels = (Label *) erts_realloc(ERTS_ALC_T_LOADER_TMP, + (void *) stp->labels, + stp->num_labels * sizeof(Label)); + stp->labels[num].value = 0; + stp->labels[num].patches = 0; + return num; +} + +static void +new_literal_patch(LoaderState* stp, int pos) +{ + LiteralPatch* p = erts_alloc(ERTS_ALC_T_LOADER_TMP, sizeof(LiteralPatch)); + p->pos = pos; + p->next = stp->literal_patches; + stp->literal_patches = p; +} + +static void +new_string_patch(LoaderState* stp, int pos) +{ + StringPatch* p = erts_alloc(ERTS_ALC_T_LOADER_TMP, sizeof(StringPatch)); + p->pos = pos; + p->next = stp->string_patches; + stp->string_patches = p; +} + +static Uint +new_literal(LoaderState* stp, Eterm** hpp, Uint heap_size) +{ + Literal* lit; + + if (stp->allocated_literals == 0) { + Uint need; + + ASSERT(stp->literals == 0); + ASSERT(stp->num_literals == 0); + stp->allocated_literals = 8; + need = stp->allocated_literals * sizeof(Literal); + stp->literals = (Literal *) erts_alloc(ERTS_ALC_T_LOADER_TMP, + need); + } else if (stp->allocated_literals <= stp->num_literals) { + Uint need; + + stp->allocated_literals *= 2; + need = stp->allocated_literals * sizeof(Literal); + stp->literals = (Literal *) erts_realloc(ERTS_ALC_T_LOADER_TMP, + (void *) stp->literals, + need); + } + + stp->total_literal_size += heap_size; + lit = stp->literals + stp->num_literals; + lit->offset = 0; + lit->heap_size = heap_size; + lit->heap = erts_alloc(ERTS_ALC_T_LOADER_TMP, heap_size*sizeof(Eterm)); + lit->term = make_boxed(lit->heap); + *hpp = lit->heap; + return stp->num_literals++; +} + +Eterm +erts_module_info_0(Process* p, Eterm module) +{ + Eterm *hp; + Eterm list = NIL; + Eterm tup; + + if (is_not_atom(module)) { + return THE_NON_VALUE; + } + + if (erts_get_module(module) == NULL) { + return THE_NON_VALUE; + } + +#define BUILD_INFO(What) \ + tup = erts_module_info_1(p, module, What); \ + hp = HAlloc(p, 5); \ + tup = TUPLE2(hp, What, tup); \ + hp += 3; \ + list = CONS(hp, tup, list) + + BUILD_INFO(am_compile); + BUILD_INFO(am_attributes); + BUILD_INFO(am_imports); + BUILD_INFO(am_exports); +#undef BUILD_INFO + return list; +} + +Eterm +erts_module_info_1(Process* p, Eterm module, Eterm what) +{ + if (what == am_module) { + return module; + } else if (what == am_imports) { + return NIL; + } else if (what == am_exports) { + return exported_from_module(p, module); + } else if (what == am_functions) { + return functions_in_module(p, module); + } else if (what == am_attributes) { + return attributes_for_module(p, module); + } else if (what == am_compile) { + return compilation_info_for_module(p, module); + } else if (what == am_native_addresses) { + return native_addresses(p, module); + } + return THE_NON_VALUE; +} + +/* + * Builds a list of all functions in the given module: + * [{Name, Arity},...] + * + * Returns a tagged term, or 0 on error. + */ + +Eterm +functions_in_module(Process* p, /* Process whose heap to use. */ + Eterm mod) /* Tagged atom for module. */ +{ + Module* modp; + Eterm* code; + int i; + Uint num_functions; + Eterm* hp; + Eterm result = NIL; + + if (is_not_atom(mod)) { + return THE_NON_VALUE; + } + + modp = erts_get_module(mod); + if (modp == NULL) { + return THE_NON_VALUE; + } + code = modp->code; + num_functions = code[MI_NUM_FUNCTIONS]; + hp = HAlloc(p, 5*num_functions); + for (i = num_functions-1; i >= 0 ; i--) { + Eterm* func_info = (Eterm *) code[MI_FUNCTIONS+i]; + Eterm name = func_info[3]; + int arity = func_info[4]; + Eterm tuple; + + ASSERT(is_atom(name)); + tuple = TUPLE2(hp, name, make_small(arity)); + hp += 3; + result = CONS(hp, tuple, result); + hp += 2; + } + return result; +} + +/* + * Builds a list of all functions including native addresses. + * [{Name,Arity,NativeAddress},...] + * + * Returns a tagged term, or 0 on error. + */ + +static Eterm +native_addresses(Process* p, Eterm mod) +{ + Module* modp; + Eterm* code; + int i; + Eterm* hp; + Uint num_functions; + Uint need; + Eterm* hp_end; + Eterm result = NIL; + + if (is_not_atom(mod)) { + return THE_NON_VALUE; + } + + modp = erts_get_module(mod); + if (modp == NULL) { + return THE_NON_VALUE; + } + + code = modp->code; + num_functions = code[MI_NUM_FUNCTIONS]; + need = (6+BIG_UINT_HEAP_SIZE)*num_functions; + hp = HAlloc(p, need); + hp_end = hp + need; + for (i = num_functions-1; i >= 0 ; i--) { + Eterm* func_info = (Eterm *) code[MI_FUNCTIONS+i]; + Eterm name = func_info[3]; + int arity = func_info[4]; + Eterm tuple; + + ASSERT(is_atom(name)); + if (func_info[1] != 0) { + Eterm addr = erts_bld_uint(&hp, NULL, func_info[1]); + tuple = erts_bld_tuple(&hp, NULL, 3, name, make_small(arity), addr); + result = erts_bld_cons(&hp, NULL, tuple, result); + } + } + HRelease(p, hp_end, hp); + return result; +} + + +/* + * Builds a list of all exported functions in the given module: + * [{Name, Arity},...] + * + * Returns a tagged term, or 0 on error. + */ + +Eterm +exported_from_module(Process* p, /* Process whose heap to use. */ + Eterm mod) /* Tagged atom for module. */ +{ + int i; + Eterm* hp = NULL; + Eterm* hend = NULL; + Eterm result = NIL; + + if (is_not_atom(mod)) { + return THE_NON_VALUE; + } + + for (i = 0; i < export_list_size(); i++) { + Export* ep = export_list(i); + + if (ep->code[0] == mod) { + Eterm tuple; + + if (ep->address == ep->code+3 && + ep->code[3] == (Eterm) em_call_error_handler) { + /* There is a call to the function, but it does not exist. */ + continue; + } + + if (hp == hend) { + int need = 10 * 5; + hp = HAlloc(p, need); + hend = hp + need; + } + tuple = TUPLE2(hp, ep->code[1], make_small(ep->code[2])); + hp += 3; + result = CONS(hp, tuple, result); + hp += 2; + } + } + HRelease(p,hend,hp); + return result; +} + + +/* + * Returns a list of all attributes for the module. + * + * Returns a tagged term, or 0 on error. + */ + +Eterm +attributes_for_module(Process* p, /* Process whose heap to use. */ + Eterm mod) /* Tagged atom for module. */ + +{ + Module* modp; + Eterm* code; + Eterm* hp; + byte* ext; + Eterm result = NIL; + Eterm* end; + + if (is_not_atom(mod) || (is_not_list(result) && is_not_nil(result))) { + return THE_NON_VALUE; + } + + modp = erts_get_module(mod); + if (modp == NULL) { + return THE_NON_VALUE; + } + code = modp->code; + ext = (byte *) code[MI_ATTR_PTR]; + if (ext != NULL) { + hp = HAlloc(p, code[MI_ATTR_SIZE_ON_HEAP]); + end = hp + code[MI_ATTR_SIZE_ON_HEAP]; + result = erts_decode_ext(&hp, &MSO(p), &ext); + if (is_value(result)) { + ASSERT(hp <= end); + } + HRelease(p,end,hp); + } + return result; +} + + +/* + * Returns a list containing compilation information. + * + * Returns a tagged term, or 0 on error. + */ + +Eterm +compilation_info_for_module(Process* p, /* Process whose heap to use. */ + Eterm mod) /* Tagged atom for module. */ +{ + Module* modp; + Eterm* code; + Eterm* hp; + byte* ext; + Eterm result = NIL; + Eterm* end; + + if (is_not_atom(mod) || (is_not_list(result) && is_not_nil(result))) { + return THE_NON_VALUE; + } + + modp = erts_get_module(mod); + if (modp == NULL) { + return THE_NON_VALUE; + } + code = modp->code; + ext = (byte *) code[MI_COMPILE_PTR]; + if (ext != NULL) { + hp = HAlloc(p, code[MI_COMPILE_SIZE_ON_HEAP]); + end = hp + code[MI_COMPILE_SIZE_ON_HEAP]; + result = erts_decode_ext(&hp, &MSO(p), &ext); + if (is_value(result)) { + ASSERT(hp <= end); + } + HRelease(p,end,hp); + } + return result; +} + + +/* + * Returns a pointer to {module, function, arity}, or NULL if not found. + */ +Eterm* +find_function_from_pc(Eterm* pc) +{ + Range* low = modules; + Range* high = low + num_loaded_modules; + Range* mid = mid_module; + + while (low < high) { + if (pc < mid->start) { + high = mid; + } else if (pc > mid->end) { + low = mid + 1; + } else { + Eterm** low1 = (Eterm **) (mid->start + MI_FUNCTIONS); + Eterm** high1 = low1 + mid->start[MI_NUM_FUNCTIONS]; + Eterm** mid1; + + while (low1 < high1) { + mid1 = low1 + (high1-low1) / 2; + if (pc < mid1[0]) { + high1 = mid1; + } else if (pc < mid1[1]) { + mid_module = mid; + return mid1[0]+2; + } else { + low1 = mid1 + 1; + } + } + return NULL; + } + mid = low + (high-low) / 2; + } + return NULL; +} + +/* + * Read a specific chunk from a Beam binary. + */ + +Eterm +code_get_chunk_2(Process* p, Eterm Bin, Eterm Chunk) +{ + LoaderState state; + Uint chunk = 0; + ErlSubBin* sb; + Uint offset; + Uint bitoffs; + Uint bitsize; + byte* start; + int i; + Eterm res; + Eterm real_bin; + byte* temp_alloc = NULL; + + if ((start = erts_get_aligned_binary_bytes(Bin, &temp_alloc)) == NULL) { + error: + erts_free_aligned_binary_bytes(temp_alloc); + BIF_ERROR(p, BADARG); + } + state.module = THE_NON_VALUE; /* Suppress diagnostiscs */ + state.file_name = "IFF header for Beam file"; + state.file_p = start; + state.file_left = binary_size(Bin); + for (i = 0; i < 4; i++) { + Eterm* chunkp; + Eterm num; + if (is_not_list(Chunk)) { + goto error; + } + chunkp = list_val(Chunk); + num = CAR(chunkp); + Chunk = CDR(chunkp); + if (!is_byte(num)) { + goto error; + } + chunk = chunk << 8 | unsigned_val(num); + } + if (is_not_nil(Chunk)) { + goto error; + } + if (!scan_iff_file(&state, &chunk, 1, 1)) { + erts_free_aligned_binary_bytes(temp_alloc); + return am_undefined; + } + ERTS_GET_REAL_BIN(Bin, real_bin, offset, bitoffs, bitsize); + if (bitoffs) { + res = new_binary(p, state.chunks[0].start, state.chunks[0].size); + } else { + sb = (ErlSubBin *) HAlloc(p, ERL_SUB_BIN_SIZE); + sb->thing_word = HEADER_SUB_BIN; + sb->orig = real_bin; + sb->size = state.chunks[0].size; + sb->bitsize = 0; + sb->bitoffs = 0; + sb->offs = offset + (state.chunks[0].start - start); + sb->is_writable = 0; + res = make_binary(sb); + } + erts_free_aligned_binary_bytes(temp_alloc); + return res; +} + +/* + * Calculate the MD5 for a module. + */ + +Eterm +code_module_md5_1(Process* p, Eterm Bin) +{ + LoaderState state; + byte* temp_alloc = NULL; + + if ((state.file_p = erts_get_aligned_binary_bytes(Bin, &temp_alloc)) == NULL) { + BIF_ERROR(p, BADARG); + } + state.module = THE_NON_VALUE; /* Suppress diagnostiscs */ + state.file_name = "IFF header for Beam file"; + state.file_left = binary_size(Bin); + + if (!scan_iff_file(&state, chunk_types, NUM_CHUNK_TYPES, NUM_MANDATORY)) { + return am_undefined; + } + erts_free_aligned_binary_bytes(temp_alloc); + return new_binary(p, state.mod_md5, sizeof(state.mod_md5)); +} + +#define WORDS_PER_FUNCTION 6 + +static Eterm* +make_stub(Eterm* fp, Eterm mod, Eterm func, Uint arity, Uint native, Eterm OpCode) +{ + fp[0] = (Eterm) BeamOp(op_i_func_info_IaaI); + fp[1] = native; + fp[2] = mod; + fp[3] = func; + fp[4] = arity; +#ifdef HIPE + if (native) { + fp[5] = BeamOpCode(op_move_return_nr); + hipe_mfa_save_orig_beam_op(mod, func, arity, fp+5); + } +#endif + fp[5] = OpCode; + return fp + WORDS_PER_FUNCTION; +} + +static byte* +stub_copy_info(LoaderState* stp, + int chunk, /* Chunk: ATTR_CHUNK or COMPILE_CHUNK */ + byte* info, /* Where to store info. */ + Eterm* ptr_word, /* Where to store pointer into info. */ + Eterm* size_word) /* Where to store size of info. */ +{ + Sint decoded_size; + Uint size = stp->chunks[chunk].size; + if (size != 0) { + memcpy(info, stp->chunks[chunk].start, size); + *ptr_word = (Eterm) info; + decoded_size = erts_decode_ext_size(info, size, 0); + if (decoded_size < 0) { + return 0; + } + *size_word = decoded_size; + } + return info + size; +} + +static int +stub_read_export_table(LoaderState* stp) +{ + int i; + + GetInt(stp, 4, stp->num_exps); + if (stp->num_exps > stp->num_functions) { + LoadError2(stp, "%d functions exported; only %d functions defined", + stp->num_exps, stp->num_functions); + } + stp->export + = (ExportEntry *) erts_alloc(ERTS_ALC_T_LOADER_TMP, + stp->num_exps * sizeof(ExportEntry)); + + for (i = 0; i < stp->num_exps; i++) { + Uint n; + + GetInt(stp, 4, n); + GetAtom(stp, n, stp->export[i].function); + GetInt(stp, 4, n); + if (n > MAX_REG) { + LoadError2(stp, "export table entry %d: absurdly high arity %d", i, n); + } + stp->export[i].arity = n; + GetInt(stp, 4, n); /* Ignore label */ + } + return 1; + + load_error: + return 0; +} + +static void +stub_final_touch(LoaderState* stp, Eterm* fp) +{ + int i; + int n = stp->num_exps; + Eterm function = fp[3]; + int arity = fp[4]; +#ifdef HIPE + Lambda* lp; +#endif + + /* + * Test if the function should be exported. + */ + + for (i = 0; i < n; i++) { + if (stp->export[i].function == function && stp->export[i].arity == arity) { + Export* ep = erts_export_put(fp[2], function, arity); + ep->address = fp+5; + return; + } + } + + /* + * Must be a plain local function or a lambda local function. + * Search the lambda table to find out which. + */ + +#ifdef HIPE + n = stp->num_lambdas; + for (i = 0, lp = stp->lambdas; i < n; i++, lp++) { + ErlFunEntry* fe = stp->lambdas[i].fe; + if (lp->function == function && lp->arity == arity) { + fp[5] = (Eterm) BeamOpCode(op_hipe_trap_call_closure); + fe->address = &(fp[5]); + } + } +#endif + return; +} + + +/* Takes an erlang list of addresses: + [{Adr, Patchtyppe} | Addresses] + and the address of a fun_entry. +*/ +int +patch(Eterm Addresses, Uint fe) + { +#ifdef HIPE + Eterm* listp; + Eterm tuple; + Eterm* tp; + Eterm patchtype; + Uint AddressToPatch; + + while (!is_nil(Addresses)) { + listp = list_val(Addresses); + + tuple = CAR(listp); + if (is_not_tuple(tuple)) { + return 0; /* Signal error */ + } + + tp = tuple_val(tuple); + if (tp[0] != make_arityval(2)) { + return 0; /* Signal error */ + } + + if(term_to_Uint(tp[1], &AddressToPatch) == 0) { + return 0; /* Signal error */ + } + + patchtype = tp[2]; + if (is_not_atom(patchtype)) { + return 0; /* Signal error */ + } + + hipe_patch_address((Uint *)AddressToPatch, patchtype, fe); + + Addresses = CDR(listp); + + + } + +#endif + return 1; +} + + +int +patch_funentries(Eterm Patchlist) + { +#ifdef HIPE + while (!is_nil(Patchlist)) { + Eterm Info; + Eterm MFA; + Eterm Addresses; + Eterm tuple; + Eterm Mod; + Eterm* listp; + Eterm* tp; + ErlFunEntry* fe; + Uint index; + Uint uniq; + Uint native_address; + + listp = list_val(Patchlist); + tuple = CAR(listp); + Patchlist = CDR(listp); + + if (is_not_tuple(tuple)) { + return 0; /* Signal error */ + } + + tp = tuple_val(tuple); + if (tp[0] != make_arityval(3)) { + return 0; /* Signal error */ + } + + Info = tp[1]; + if (is_not_tuple(Info)) { + return 0; /* Signal error */ + } + Addresses = tp[2]; + if (is_not_list(Addresses)) { + return 0; /* Signal error */ + } + + if(term_to_Uint(tp[3], &native_address) == 0) { + return 0; /* Signal error */ + } + + + + tp = tuple_val(Info); + if (tp[0] != make_arityval(3)) { + return 0; /* Signal error */ + } + MFA = tp[1]; + if (is_not_tuple(MFA)) { + return 0; /* Signal error */ + } + if(term_to_Uint(tp[2], &uniq) == 0){ + return 0; /* Signal error */ + } + if(term_to_Uint(tp[3], &index) == 0) { + return 0; /* Signal error */ + } + + + + + tp = tuple_val(MFA); + if (tp[0] != make_arityval(3)) { + return 0; /* Signal error */ + } + Mod = tp[1]; + if (is_not_atom(Mod)) { + return 0; /* Signal error */ + } + + + + fe = erts_get_fun_entry(Mod, uniq, index); + fe->native_address = (Uint *)native_address; + erts_refc_dec(&fe->refc, 1); + + if (!patch(Addresses, (Uint) fe)) + return 0; + + } +#endif + return 1; /* Signal that all went well */ +} + + +/* + * Do a dummy load of a module. No threaded code will be loaded. + * Used for loading native code. + * Will also patch all references to fun_entries to point to + * the new fun_entries created. + */ + +Eterm +erts_make_stub_module(Process* p, Eterm Mod, Eterm Beam, Eterm Info) +{ + LoaderState state; + Eterm Funcs; + Eterm Patchlist; + Eterm* tp; + Eterm* code = NULL; + Eterm* ptrs; + Eterm* fp; + byte* info; + Uint ci; + int n; + int code_size; + int rval; + int i; + ErlDrvBinary* bin = NULL; + byte* temp_alloc = NULL; + byte* bytes; + Uint size; + + /* + * Must initialize state.lambdas here because the error handling code + * at label 'error' uses it. + */ + init_state(&state); + + if (is_not_atom(Mod)) { + goto error; + } + if (is_not_tuple(Info)) { + goto error; + } + tp = tuple_val(Info); + if (tp[0] != make_arityval(2)) { + goto error; + } + Funcs = tp[1]; + Patchlist = tp[2]; + + if ((n = list_length(Funcs)) < 0) { + goto error; + } + if ((bytes = erts_get_aligned_binary_bytes(Beam, &temp_alloc)) == NULL) { + goto error; + } + size = binary_size(Beam); + + /* + * Uncompressed if needed. + */ + if (!(size >= 4 && bytes[0] == 'F' && bytes[1] == 'O' && + bytes[2] == 'R' && bytes[3] == '1')) { + bin = (ErlDrvBinary *) erts_gzinflate_buffer((char*)bytes, size); + if (bin == NULL) { + goto error; + } + bytes = (byte*)bin->orig_bytes; + size = bin->orig_size; + } + + /* + * Scan the Beam binary and read the interesting sections. + */ + + state.file_name = "IFF header for Beam file"; + state.file_p = bytes; + state.file_left = size; + state.module = Mod; + state.group_leader = p->group_leader; + state.num_functions = n; + if (!scan_iff_file(&state, chunk_types, NUM_CHUNK_TYPES, NUM_MANDATORY)) { + goto error; + } + define_file(&state, "code chunk header", CODE_CHUNK); + if (!read_code_header(&state)) { + goto error; + } + define_file(&state, "atom table", ATOM_CHUNK); + if (!load_atom_table(&state)) { + goto error; + } + define_file(&state, "export table", EXP_CHUNK); + if (!stub_read_export_table(&state)) { + goto error; + } + + if (state.chunks[LAMBDA_CHUNK].size > 0) { + define_file(&state, "lambda (fun) table", LAMBDA_CHUNK); + if (!read_lambda_table(&state)) { + goto error; + } + } + + /* + * Allocate memory for the stub module. + */ + + code_size = ((WORDS_PER_FUNCTION+1)*n + MI_FUNCTIONS + 2) * sizeof(Eterm); + code_size += state.chunks[ATTR_CHUNK].size; + code_size += state.chunks[COMPILE_CHUNK].size; + code = erts_alloc_fnf(ERTS_ALC_T_CODE, code_size); + if (!code) { + goto error; + } + + /* + * Initialize code area. + */ + + code[MI_NUM_FUNCTIONS] = n; + code[MI_ATTR_PTR] = 0; + code[MI_ATTR_SIZE_ON_HEAP] = 0; + code[MI_COMPILE_PTR] = 0; + code[MI_COMPILE_SIZE_ON_HEAP] = 0; + code[MI_NUM_BREAKPOINTS] = 0; + ci = MI_FUNCTIONS + n + 1; + + /* + * Make stubs for all functions. + */ + + ptrs = code + MI_FUNCTIONS; + fp = code + ci; + for (i = 0; i < n; i++) { + Eterm* listp; + Eterm tuple; + Eterm* tp; + Eterm func; + Eterm arity_term; + Uint arity; + Uint native_address; + Eterm op; + + if (is_nil(Funcs)) { + break; + } + listp = list_val(Funcs); + tuple = CAR(listp); + Funcs = CDR(listp); + + /* Error checking */ + if (is_not_tuple(tuple)) { + goto error; + } + tp = tuple_val(tuple); + if (tp[0] != make_arityval(3)) { + goto error; + } + func = tp[1]; + arity_term = tp[2]; + if (is_not_atom(func) || is_not_small(arity_term)) { + goto error; + } + arity = signed_val(arity_term); + if (arity < 0) { + goto error; + } + if (term_to_Uint(tp[3], &native_address) == 0) { + goto error; + } + + /* + * Set the pointer and make the stub. Put a return instruction + * as the body until we know what kind of trap we should put there. + */ + ptrs[i] = (Eterm) fp; +#ifdef HIPE + op = (Eterm) BeamOpCode(op_hipe_trap_call); /* Might be changed later. */ +#else + op = (Eterm) BeamOpCode(op_move_return_nr); +#endif + fp = make_stub(fp, Mod, func, arity, (Uint)native_address, op); + } + + /* + * Insert the last pointer and the int_code_end instruction. + */ + + ptrs[i] = (Eterm) fp; + *fp++ = (Eterm) BeamOp(op_int_code_end); + + /* + * Copy attributes and compilation information. + */ + + info = (byte *) fp; + info = stub_copy_info(&state, ATTR_CHUNK, info, + code+MI_ATTR_PTR, code+MI_ATTR_SIZE_ON_HEAP); + if (info == NULL) { + goto error; + } + info = stub_copy_info(&state, COMPILE_CHUNK, info, + code+MI_COMPILE_PTR, code+MI_COMPILE_SIZE_ON_HEAP); + if (info == NULL) { + goto error; + } + + /* + * Insert the module in the module table. + */ + + rval = insert_new_code(p, 0, p->group_leader, Mod, code, code_size, + BEAM_CATCHES_NIL); + if (rval < 0) { + goto error; + } + + /* + * Export all stub functions and insert the correct type of HiPE trap. + */ + + fp = code + ci; + for (i = 0; i < n; i++) { + stub_final_touch(&state, fp); + fp += WORDS_PER_FUNCTION; + } + + if (patch_funentries(Patchlist)) { + erts_free_aligned_binary_bytes(temp_alloc); + if (state.lambdas != state.def_lambdas) { + erts_free(ERTS_ALC_T_LOADER_TMP, (void *) state.lambdas); + } + if (bin != NULL) { + driver_free_binary(bin); + } + return Mod; + } + + error: + erts_free_aligned_binary_bytes(temp_alloc); + if (code != NULL) { + erts_free(ERTS_ALC_T_CODE, code); + } + if (state.lambdas != state.def_lambdas) { + erts_free(ERTS_ALC_T_LOADER_TMP, (void *) state.lambdas); + } + if (bin != NULL) { + driver_free_binary(bin); + } + + + BIF_ERROR(p, BADARG); +} + +#undef WORDS_PER_FUNCTION + +static int safe_mul(Uint a, Uint b, Uint* resp) +{ + Uint res = a * b; + *resp = res; + + if (b == 0) { + return 1; + } else { + return (res / b) == a; + } +} diff --git a/erts/emulator/beam/beam_load.h b/erts/emulator/beam/beam_load.h new file mode 100644 index 0000000000..c17844a553 --- /dev/null +++ b/erts/emulator/beam/beam_load.h @@ -0,0 +1,120 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1999-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifndef _BEAM_LOAD_H +# define _BEAM_LOAD_H + +#include "beam_opcodes.h" +#include "erl_process.h" + +int beam_make_current_old(Process *c_p, ErtsProcLocks c_p_locks, Eterm module); + +typedef struct gen_op_entry { + char* name; + int arity; + int specific; + int num_specific; + int transform; + int min_window; +} GenOpEntry; + +extern GenOpEntry gen_opc[]; + +#ifdef NO_JUMP_TABLE +#define BeamOp(Op) (Op) +#else +extern void** beam_ops; +#define BeamOp(Op) beam_ops[(Op)] +#endif + + +extern Eterm beam_debug_apply[]; +extern Eterm* em_call_error_handler; +extern Eterm* em_apply_bif; +extern Eterm* em_call_traced_function; +typedef struct { + Eterm* start; /* Pointer to start of module. */ + Eterm* end; /* Points one word beyond last function in module. */ +} Range; + +/* + * The following variables keep a sorted list of address ranges for + * each module. It allows us to quickly find a function given an + * instruction pointer. + */ + +extern Range* modules; +extern int num_loaded_modules; +extern int allocated_modules; +extern Range* mid_module; + +/* Total code size in bytes */ +extern Uint erts_total_code_size; +/* + * Index into start of code chunks which contains additional information + * about the loaded module. + * + * First number of functions. + */ + +#define MI_NUM_FUNCTIONS 0 + +/* + * The attributes retrieved by Mod:module_info(attributes). + */ + +#define MI_ATTR_PTR 1 +#define MI_ATTR_SIZE 2 +#define MI_ATTR_SIZE_ON_HEAP 3 + +/* + * The compilation information retrieved by Mod:module_info(compile). + */ + +#define MI_COMPILE_PTR 4 +#define MI_COMPILE_SIZE 5 +#define MI_COMPILE_SIZE_ON_HEAP 6 + +/* + * Number of breakpoints in module is stored in this word + */ +#define MI_NUM_BREAKPOINTS 7 + +/* + * Literal area (constant pool). + */ +#define MI_LITERALS_START 8 +#define MI_LITERALS_END 9 + +/* + * Pointer to the on_load function (or NULL if none). + */ +#define MI_ON_LOAD_FUNCTION_PTR 10 + +/* + * Start of function pointer table. This table contains pointers to + * all functions in the module plus an additional pointer just beyond + * the end of the last function. + * + * The actual loaded code (for the first function) start just beyond + * this table. + */ + +#define MI_FUNCTIONS 11 +#endif /* _BEAM_LOAD_H */ diff --git a/erts/emulator/beam/benchmark.c b/erts/emulator/beam/benchmark.c new file mode 100644 index 0000000000..7fbf44a03c --- /dev/null +++ b/erts/emulator/beam/benchmark.c @@ -0,0 +1,395 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2002-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "global.h" +#include "benchmark.h" + +#ifdef BM_COUNTERS +unsigned long long processes_busy; +unsigned long long processes_spawned; +unsigned long long messages_sent; +unsigned long long messages_copied; +unsigned long long messages_ego; +unsigned long long minor_gc; +unsigned long long major_gc; +#ifdef HYBRID +unsigned long long minor_global_gc; +unsigned long long major_global_gc; +unsigned long long gc_in_copy; +#ifdef INCREMENTAL +unsigned long long minor_gc_cycles; +unsigned long long major_gc_cycles; +unsigned long long minor_gc_stages; +unsigned long long major_gc_stages; +#endif +#endif +#endif /* BM_COUNTERS */ + +#ifdef BM_TIMERS + +#if (defined(__i386__) || defined(__x86_64__)) && USE_PERFCTR + +#include "libperfctr.h" +struct vperfctr *system_clock; +double cpu_khz; +BM_NEW_TIMER(start); + +static double get_hrvtime(void) +{ + unsigned long long ticks; + double milli_seconds; + + ticks = vperfctr_read_tsc(system_clock); + milli_seconds = (double)ticks / cpu_khz; + return milli_seconds; +} + +static void stop_hrvtime(void) +{ + if(system_clock) + { + vperfctr_stop(system_clock); + vperfctr_close(system_clock); + system_clock = NULL; + } +} + +#else /* not perfctr, asuming Solaris */ +#include +BM_TIMER_T system_clock; +#endif + +unsigned long local_pause_times[MAX_PAUSE_TIME]; +unsigned long pause_times[MAX_PAUSE_TIME]; +unsigned long pause_times_old[MAX_PAUSE_TIME]; + +BM_TIMER_T mmu; +BM_TIMER_T mmu_counter; + +BM_NEW_TIMER(timer); +BM_NEW_TIMER(system); +BM_NEW_TIMER(gc); +BM_NEW_TIMER(minor_gc); +BM_NEW_TIMER(major_gc); +BM_NEW_TIMER(minor_global_gc); +BM_NEW_TIMER(major_global_gc); +BM_NEW_TIMER(send); +BM_NEW_TIMER(copy); +BM_NEW_TIMER(size); +BM_NEW_TIMER(max_minor); +BM_NEW_TIMER(max_major); +BM_NEW_TIMER(max_global_minor); +BM_NEW_TIMER(max_global_major); +BM_NEW_TIMER(misc0); +BM_NEW_TIMER(misc1); +BM_NEW_TIMER(misc2); +#endif /* BM_TIMERS */ + +#ifdef BM_HEAP_SIZES +unsigned long long max_used_heap; +unsigned long long max_allocated_heap; +unsigned long long max_used_global_heap; +unsigned long long max_allocated_global_heap; +#endif /* BM_HEAP_SIZES */ + +#ifdef BM_MESSAGE_SIZES +unsigned long long words_sent; +unsigned long long words_copied; +unsigned long long words_prealloc; +unsigned long long message_sizes[1000]; +#endif /* BM_MESSAGE_SIZES */ + +/***** + * The following functions have to be defined, but they only have contents + * if certain keywords are defined. + */ + +void init_benchmarking() +{ +#ifdef BM_TIMERS +#if (defined(__i386__) || defined(__x86_64__)) && USE_PERFCTR + /* pass `--with-perfctr=/path/to/perfctr' when configuring */ + struct perfctr_info info; + struct vperfctr_control control; + int i; + + system_clock = vperfctr_open(); + if (system_clock != NULL) + { + if (vperfctr_info(system_clock,&info) >= 0) + { + cpu_khz = (double)info.cpu_khz; + if (info.cpu_features & PERFCTR_FEATURE_RDTSC) + { + memset(&control,0,sizeof control); + control.cpu_control.tsc_on = 1; + } + } + if (vperfctr_control(system_clock,&control) < 0) + { + vperfctr_close(system_clock); + system_clock = NULL; + } + } + + for (i = 0; i < 1000; i++) + { + BM_START_TIMER(system); + BM_STOP_TIMER(system); + } + + timer_time = system_time / 1000; + start_time = 0; +#else + int i; + for (i = 0; i < 1000; i++) + { + BM_START_TIMER(system); + BM_STOP_TIMER(system); + } + timer_time = system_time / 1000; +#endif + + for (i = 0; i < MAX_PAUSE_TIME; i++) { + local_pause_times[i] = 0; + pause_times[i] = 0; + pause_times_old[i] = 0; + } + + mmu = 0; + mmu_counter = 0; + + BM_MMU_INIT(); +#endif /* BM_TIMERS */ + +#ifdef BM_COUNTERS + processes_busy = 0; + processes_spawned = 0; + messages_sent = 0; + messages_copied = 0; + messages_ego = 0; + minor_gc = 0; + major_gc = 0; +#ifdef HYBRID + minor_global_gc = 0; + major_global_gc = 0; + gc_in_copy = 0; +#ifdef INCREMENTAL + minor_gc_cycles = 0; + major_gc_cycles = 0; + minor_gc_stages = 0; + major_gc_stages = 0; +#endif +#endif +#endif /* BM_COUNTERS */ + +#ifdef BM_HEAP_SIZES + max_used_heap = 0; + max_allocated_heap = 0; + max_used_global_heap = 0; + max_allocated_global_heap = 0; +#endif /* BM_HEAP_SIZES */ + +#ifdef BM_MESSAGE_SIZES + words_sent = 0; + words_copied = 0; + words_prealloc = 0; + { + int i; + for (i = 0; i < 1000; i++) + message_sizes[i] = 0; + } +#endif /* BM_MESSAGE_SIZES */ +} + +void save_statistics() +{ +#ifdef BM_STATISTICS + FILE *file = fopen(BM_STATISTICS_FILE,"a"); + long i = 0; + + if (file) + { + erts_fprintf(file,"-------------------------------------------------------------------------\n"); + erts_fprintf(file,"The counters are reset at system start and are sums over the entire node.\n"); + erts_fprintf(file,"You may reset them manually using the BIFs in the module hipe_bifs.\n"); + erts_fprintf(file,"All times are given in milliseconds.\n"); + erts_fprintf(file,"-------------------------------------------------------------------------\n"); + + erts_fprintf(file,"Node: %T\n",erts_this_node->sysname); + +#ifdef BM_COUNTERS + erts_fprintf(file,"Number of processes spawned: %lld\n",processes_spawned); + erts_fprintf(file,"Number of local minor GCs: %lld\n",minor_gc); + erts_fprintf(file,"Number of local major GCs: %lld\n",major_gc); +#ifdef HYBRID + erts_fprintf(file,"Number of global minor GCs: %lld\n",minor_global_gc); + erts_fprintf(file,"Number of global major GCs: %lld\n",major_global_gc); +#ifdef INCREMENTAL + erts_fprintf(file,"Number of minor GC-cycles: %lld\n",minor_gc_cycles); + erts_fprintf(file,"Number of major GC-cycles: %lld\n",major_gc_cycles); + erts_fprintf(file,"Number of minor GC-stages: %lld\n",minor_gc_stages); + erts_fprintf(file,"Number of major GC-stages: %lld\n",major_gc_stages); +#endif +#endif + erts_fprintf(file,"Number of messages sent: %lld\n",messages_sent); + erts_fprintf(file,"Number of messages copied: %lld\n",messages_copied); + erts_fprintf(file,"Number of messages sent to self: %lld\n",messages_ego); +#endif /* BM_COUNTERS */ + +#ifdef BM_MESSAGE_SIZES + erts_fprintf(file,"Number of words sent: %lld\n",words_sent); + erts_fprintf(file,"Number of words copied: %lld\n",words_copied); + erts_fprintf(file,"Number of words preallocated: %lld\n",words_prealloc); +#endif /* BM_MESSAGE_SIZES */ + +#ifdef BM_HEAP_SIZES + erts_fprintf(file,"Biggest local heap used (in words): %lld\n",max_used_heap); + erts_fprintf(file,"Biggest local heap allocated (in words): %lld\n",max_allocated_heap); + erts_fprintf(file,"Biggest global heap used (in words): %lld\n",max_used_global_heap); + erts_fprintf(file,"Biggest global heap allocated (in words): %lld\n",max_allocated_global_heap); +#endif /* BM_HEAP_SIZES */ + +#ifdef BM_TIMERS + erts_fprintf(file,"--- The total active system time is the sum of all times below ---\n"); + BM_TIME_PRINTER("Mutator time",system_time); + BM_TIME_PRINTER("Time spent in send (excluding size & copy)",send_time); + BM_TIME_PRINTER("Time spent in size",size_time); + BM_TIME_PRINTER("Time spent in copy",copy_time); + BM_TIME_PRINTER("Time spent in local minor GC",minor_gc_time); + BM_TIME_PRINTER("Time spent in local major GC",major_gc_time); + BM_TIME_PRINTER("Time spent in global minor GC",minor_global_gc_time); + BM_TIME_PRINTER("Time spent in global major GC",major_global_gc_time); + erts_fprintf(file,"---\n"); + BM_TIME_PRINTER("Maximum time spent in one separate local minor GC",max_minor_time); + BM_TIME_PRINTER("Maximum time spent in one separate local major GC",max_major_time); + BM_TIME_PRINTER("Maximum time spent in one separate global minor GC",max_global_minor_time); + BM_TIME_PRINTER("Maximum time spent in one separate global major GC",max_global_major_time); +#endif /* BM_TIMERS */ + +#if 0 + /* Save a log file for import into excel */ + + long long total_time, n; + long left, right, mid; + +#ifdef BM_COUNTERS + erts_fprintf(file,"Spawns\tLocalGC\tMAGC\tMessages\tMutator_t\tLocalGC_t\tMAGC_t\tLocMaxP\tLocMeanP\tLocGeoMP\tMAMaxP\tMAMeanP\tMAGeoMP\t\tCMAGC\tCMAGC_t\n"); + erts_fprintf(file,"%lld\t%lld\t%lld\t%lld\t", + processes_spawned, + minor_garbage_cols + major_garbage_cols, + minor_global_garbage_cols + major_global_garbage_cols, + messages_sent); +#endif /* BM_COUNTERS */ + +#ifdef BM_TIMERS + erts_fprintf(file,"%lld\t%lld\t%lld\t", + (long long)(system_time + send_time + size_time + copy_time), + (long long)(minor_gc_time + major_gc_time), + (long long)(minor_global_gc_time + major_global_gc_time)); + + total_time = 0; n = 0; + left = 0; right = 0; mid = 0; + for (i = 0; i < MAX_PAUSE_TIME; i++) { + total_time += local_pause_times[i] * i; + n += local_pause_times[i]; + if (i > mid) + right += local_pause_times[i]; + while(right > left) { + left += local_pause_times[mid++]; + right -= local_pause_times[mid]; + } + } + erts_fprintf(file,"%lld\t%lld\t%ld\t", + (long long)((max_minor_time > max_major_time ? + max_minor_time : + max_major_time)*1000), + total_time / n, + mid); + + total_time = 0; n = 0; + left = 0; right = 0; mid = 0; + for (i = 0; i < MAX_PAUSE_TIME; i++) { + if (pause_times[i] > 0) { + total_time += pause_times[i] * i; + n += pause_times[i]; + if (i > mid) + right += pause_times[i]; + while(right > left) { + left += pause_times[mid++]; + right -= pause_times[mid]; + } + } + } + erts_fprintf(file,"%lld\t%lld\t%ld\t", + (long long)((max_global_minor_time > max_global_major_time ? + max_global_minor_time : + max_global_major_time)*1000), + (n > 0 ? total_time / n : 0), + mid); + + erts_fprintf(file,"\t%lld\t%lld\n",n,total_time); + + erts_fprintf(file,"\nMinor:\n"); + for (i = 0; i < MAX_PAUSE_TIME; i++) { + if (i < 1000 || pause_times[i] > 0) { + erts_fprintf(file,"%d\t%ld\n",i,pause_times[i]); + } + } + + fprintf(file,"Major:\n"); + for (i = 0; i < MAX_PAUSE_TIME; i++) { + if (pause_times_old[i] > 0) { + fprintf(file,"%d\t%ld\n",i,pause_times_old[i]); + } + } +#endif /* BM_TIMERS */ + +#ifdef BM_TIMERS + total_time = 0; n = 0; + left = 0; right = 0; mid = 0; + fprintf(file,"\nLocal:\n"); + for (i = 0; i < MAX_PAUSE_TIME; i++) { + if (local_pause_times[i] > 0) { + erts_fprintf(file,"%d\t%ld\n",i,local_pause_times[i]); + total_time += local_pause_times[i] * i; + n += local_pause_times[i]; + if (i > mid) + right += local_pause_times[i]; + while(right > left) { + left += local_pause_times[mid++]; + right -= local_pause_times[mid]; + } + } + } + erts_fprintf(file,"Mid: %ld Mean: %ld\n",(long)mid, + (long)(n > 0 ? total_time / n : 0)); +#endif +#endif /* 0 */ + fclose(file); + } + else + fprintf(stderr,"Sorry... Can not write to %s!\n\r",BM_STATISTICS_FILE); +#endif /* BM_STATISTICS */ +} diff --git a/erts/emulator/beam/benchmark.h b/erts/emulator/beam/benchmark.h new file mode 100644 index 0000000000..eedb06a1b6 --- /dev/null +++ b/erts/emulator/beam/benchmark.h @@ -0,0 +1,340 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2002-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifndef __BENCHMARK_H__ +#define __BENCHMARK_H__ + +/* The define __BENCHMARK__ is the master switch to turn on and off + * benchmarking. This will enable the benchmark-BIFs in hipe_bif1.c. + * Documentation for the BIFs is in hipe_bif1.c, and that is where you + * will find the information about how to accually get some data out + * from these timers and counters. + */ +/* #define __BENCHMARK__ */ + +#ifdef __BENCHMARK__ +/* + * The defines below enables different parts of the benchmaring. + * Counters and timers that are disabled, always report zero in + * the BIFs. + */ + +/* BM_TIMERS keeps track of the time spent in diferent parts of the + * system. It only measures accual active time, not time spent in idle + * mode. These timers requires hardware support. For Linux, use the + * package perfctr from user.it.uu.se/~mikpe/linux/perfctr. If this + * package is not specified when configuring the system + * (--with-perfctr=PATH), the Solaris hrtime_t will be used. + * To add new timers look below. + */ +#define BM_TIMERS + +/* BM_COUNTERS count all kinds of events that occurs in the system. + * Among other things it counts the number of messages, then number of + * garbage collections, the number of processes spawned etc. + * To add new counters look below. + */ +#define BM_COUNTERS + +/* BM_MESSAGE_SIZES keeps a log of the size of all messages sent in + * the system. This introduce an overhead in time for the shared heap + * system since all message sizes have to be calculated at send. + */ +/* #define BM_MESSAGE_SIZES */ + +/* BM_HEAP_SIZES goes through all processes at garbage collection time + * to sum their allocated and used heap sizes. In anything else than a + * shared heap system, this will cost. + */ +/* #define BM_HEAP_SIZES */ + +/* BM_STATISTICS saves an entry in the file BM_STATISTICS_FILE. This + * is done for each erlang node at exit time. + */ +/* #define BM_STATISTICS */ + +#endif /* __BENCHMARK__ */ + + +#ifdef BM_STATISTICS +# define BM_STATISTICS_FILE "/tmp/erlang_statistics.joppe.log" +#endif /* BM_STATISTICS */ + + +/************ There are no more settings below this line *************/ + +/* + * Maintenance and how to add new stuff is documented by the code + * below ;-) + */ + +#ifdef BM_COUNTERS +/********************************************************************* + * To add new counters: + * + * Add the variable here AND in benchmark.c. Use the macro + * BM_COUNT(var) in the code where you want to increase it. + * + */ +extern unsigned long long processes_busy; +extern unsigned long long processes_spawned; +extern unsigned long long messages_sent; +extern unsigned long long messages_copied; +extern unsigned long long messages_ego; +extern unsigned long long minor_gc; +extern unsigned long long major_gc; +#ifdef HYBRID +extern unsigned long long minor_global_gc; +extern unsigned long long major_global_gc; +extern unsigned long long gc_in_copy; +#ifdef INCREMENTAL +extern unsigned long long minor_gc_cycles; +extern unsigned long long major_gc_cycles; +extern unsigned long long minor_gc_stages; +extern unsigned long long major_gc_stages; +#endif +#endif + +#define BM_COUNT(var) (var)++; + +#define BM_EGO_COUNT(send,rec) { \ + if ((send) == (rec)) \ + BM_COUNT(messages_ego); } + +#define BM_LAZY_COPY_START long long gcs = minor_global_gc + major_global_gc; +#define BM_LAZY_COPY_STOP { gcs = (minor_global_gc + major_global_gc) - gcs; \ + if (gcs > gc_in_copy) gc_in_copy = gcs; } + +#else /* !BM_COUNTERS */ +# define BM_COUNT(var) +# define BM_EGO_COUNT(send,rec) +# define BM_LAZY_COPY_START +# define BM_LAZY_COPY_STOP +#endif /* BM_COUNTERS */ + + +#ifdef BM_TIMERS +/********************************************************************* + * To add new timers: + * + * Add the variable below using the form extern BM_TIMER_T blah_time. + * Also add them in benchmark.c using the macro NEW_TIMER(blah). Use + * the macro BM_SWAP_TIMER(from,blah) ... BM_SWAP_TIMER(blah,to) to + * start and stop the new timer. Note, that you have to know what + * timer is running at the place where you want to insert your new + * timer to be able to stop and start (from,to) it. + * + * You can use the macros BM_STOP_TIMER(blah) and BM_START_TIMER(blah) + * around code that should not be timed at all. As above, you have to + * know what timer to start and stop. The system timer is running at + * most places in the emulator. Only the garbage collector and the + * message sending has its own timers at the moment. + * + * The timer_time used when stopping timers is the time it takes to + * start and stop the timers, calculated in init_benchmarking(). If it + * is not there, the time it takes to do this will accually be + * substantial compared to some small times in the system we want to + * meassure (send time in shared heap for instance). + */ + +#if (defined(__i386__) || defined(__x86_64__)) && USE_PERFCTR +#include "libperfctr.h" + +#define BM_TIMER_T double + +extern struct vperfctr *system_clock; +extern double cpu_khz; +extern BM_TIMER_T start_time; + +#define BM_START_TIMER(t) start_time = \ + (BM_TIMER_T)vperfctr_read_tsc(system_clock) / \ + cpu_khz; + +#define BM_STOP_TIMER(t) do { \ + BM_TIMER_T tmp = ((BM_TIMER_T)vperfctr_read_tsc(system_clock) / cpu_khz); \ + tmp -= (start_time + timer_time); \ + t##_time += (tmp > 0 ? tmp : 0); \ +} while(0) + +#define BM_TIME_PRINTER(str,time) do { \ + int min,sec,milli,micro; \ + BM_TIMER_T tmp = (time) * 1000; \ + micro = (uint)(tmp - ((int)(tmp / 1000)) * 1000); \ + tmp /= 1000; \ + milli = (uint)(tmp - ((int)(tmp / 1000)) * 1000); \ + tmp /= 1000; \ + sec = (uint)(tmp - ((int)(tmp / 60)) * 60); \ + min = (uint)tmp / 60; \ + erts_fprintf(file,str": %d:%02d.%03d %03d\n",min,sec,milli,micro); \ +} while(0) + +#else /* !USE_PERFCTR (Assuming Solaris) */ + +#define BM_TIMER_T hrtime_t +#define BM_START_TIMER(t) system_clock = sys_gethrtime() +#define BM_STOP_TIMER(t) do { \ + BM_TIMER_T tmp = (sys_gethrtime() - system_clock) - timer_time; \ + t##_time += (tmp > 0 ? tmp : 0); \ +} while(0) + +#define BM_TIME_PRINTER(str,time) do { \ + int min,sec,milli,micro; \ + BM_TIMER_T tmp; \ + tmp = (time) / 1000; \ + micro = tmp % 1000; \ + tmp /= 1000; \ + milli = tmp % 1000; \ + tmp /= 1000; \ + sec = tmp % 60; \ + min = tmp / 60; \ + erts_fprintf(file,str": %d:%02d.%03d %03d\n",min,sec,milli,micro); \ +} while(0) + +extern BM_TIMER_T system_clock; +#endif /* USE_PERFCTR */ + +extern BM_TIMER_T timer_time; +extern BM_TIMER_T system_time; +extern BM_TIMER_T gc_time; +extern BM_TIMER_T minor_gc_time; +extern BM_TIMER_T major_gc_time; +extern BM_TIMER_T minor_global_gc_time; +extern BM_TIMER_T major_global_gc_time; +extern BM_TIMER_T send_time; +extern BM_TIMER_T copy_time; +extern BM_TIMER_T size_time; +extern BM_TIMER_T max_minor_time; +extern BM_TIMER_T max_major_time; +extern BM_TIMER_T max_global_minor_time; +extern BM_TIMER_T max_global_major_time; +extern BM_TIMER_T misc0_time; +extern BM_TIMER_T misc1_time; +extern BM_TIMER_T misc2_time; + +#define MAX_PAUSE_TIME 500000 +extern unsigned long local_pause_times[MAX_PAUSE_TIME]; +extern unsigned long pause_times[MAX_PAUSE_TIME]; +extern unsigned long pause_times_old[MAX_PAUSE_TIME]; + +#define MMU_INTERVAL 5 /* milli seconds */ +extern BM_TIMER_T mmu_counter; +extern BM_TIMER_T mmu; + +#define BM_NEW_TIMER(t) BM_TIMER_T t##_time = 0; +#define BM_RESET_TIMER(t) t##_time = 0; +#define BM_SWAP_TIMER(t1,t2) do { BM_STOP_TIMER(t1); BM_START_TIMER(t2); } while(0) +#define BM_MMU_INIT() do { \ + BM_TIMER_T gc = gc_time; \ + while (gc > 0) { \ + if (gc > MMU_INTERVAL) { \ + gc -= MMU_INTERVAL - mmu_counter; \ + erts_printf("%d\n",(int)((mmu / MMU_INTERVAL) * 100)); \ + mmu_counter = 0; mmu = 0; \ + } else { \ + mmu_counter += gc; \ + if (mmu_counter >= MMU_INTERVAL) { \ + mmu_counter -= MMU_INTERVAL; \ + erts_printf("%d\n",(int)((mmu / MMU_INTERVAL) * 100)); \ + mmu = 0; \ + } \ + gc = 0; \ + } \ + } \ + BM_RESET_TIMER(system); \ + BM_RESET_TIMER(send); \ + BM_RESET_TIMER(copy); \ + BM_RESET_TIMER(size); \ +} while(0) + +#define BM_MMU_READ() do { \ + BM_TIMER_T mut = system_time + send_time + copy_time + size_time; \ + while (mut > 0) { \ + if (mut > MMU_INTERVAL) { \ + BM_TIMER_T tmp = MMU_INTERVAL - mmu_counter; \ + mmu += tmp; mut -= tmp; \ + erts_printf("%d\n",(int)((mmu / MMU_INTERVAL) * 100)); \ + mmu_counter = 0; mmu = 0; \ + } else { \ + mmu_counter += mut; mmu += mut; \ + if (mmu_counter >= MMU_INTERVAL) { \ + mmu_counter -= MMU_INTERVAL; \ + mmu -= mmu_counter; \ + erts_printf("%d\n",(int)((mmu / MMU_INTERVAL) * 100)); \ + mmu = mmu_counter; \ + } \ + mut = 0; \ + } \ + } \ +} while(0) + +#else /* !BM_TIMERS */ +# define BM_NEW_TIMER(t) +# define BM_START_TIMER(t) +# define BM_STOP_TIMER(t) +# define BM_RESET_TIMER(t) +# define BM_SWAP_TIMER(t1,t2) +# define BM_TIME_PRINTER(str,time) +# define BM_MMU_INIT() +# define BM_MMU_READ() +#endif /* BM_TIMERS */ + +#ifdef BM_HEAP_SIZES +extern unsigned long long max_used_heap; +extern unsigned long long max_allocated_heap; +extern unsigned long long max_used_global_heap; +extern unsigned long long max_allocated_global_heap; +#endif /* BM_HEAP_SIZES */ + +#ifdef BM_MESSAGE_SIZES +extern unsigned long long words_sent; +extern unsigned long long words_copied; +extern unsigned long long words_prealloc; +extern unsigned long long message_sizes[1000]; + +#define BM_MESSAGE_COPIED(size) { \ + words_copied += size; \ + BM_COUNT(messages_copied); } + +#define BM_PREALLOC_DATA(size) { \ + words_prealloc += size; } + +#define BM_MESSAGE(mess,send,rec) { \ + Uint msize = size_object(mess); \ + words_sent += msize; \ + if (msize < 1000) \ + message_sizes[msize]++; \ + else \ + message_sizes[999]++; \ + BM_EGO_COUNT(send,rec); \ + BM_COUNT(messages_sent); } + +#else /* !BM_MESSAGE_SIZES */ + +#define BM_MESSAGE_COPIED(size) BM_COUNT(messages_copied); +#define BM_PREALLOC_DATA(size) +#define BM_MESSAGE(mess,send,rec) { \ + BM_EGO_COUNT(send,rec); \ + BM_COUNT(messages_sent); } + +#endif /* BM_MESSAGE_SIZES */ + +void init_benchmarking(void); +void save_statistics(void); + +#endif /* _BENCHMARK_H_ */ diff --git a/erts/emulator/beam/bif.c b/erts/emulator/beam/bif.c new file mode 100644 index 0000000000..74b231d56d --- /dev/null +++ b/erts/emulator/beam/bif.c @@ -0,0 +1,4201 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include /* offsetof() */ +#include "sys.h" +#include "erl_vm.h" +#include "erl_sys_driver.h" +#include "global.h" +#include "erl_process.h" +#include "error.h" +#include "bif.h" +#include "big.h" +#include "dist.h" +#include "erl_version.h" +#include "erl_binary.h" +#include "beam_bp.h" +#include "erl_db_util.h" +#include "register.h" + +static Export* flush_monitor_message_trap = NULL; +static Export* set_cpu_topology_trap = NULL; +static Export* await_proc_exit_trap = NULL; +Export* erts_format_cpu_topology_trap = NULL; + +#define DECL_AM(S) Eterm AM_ ## S = am_atom_put(#S, sizeof(#S) - 1) + +/* + * The BIF's now follow, see the Erlang Manual for a description of what + * each individual BIF does. + */ + +BIF_RETTYPE spawn_3(BIF_ALIST_3) +{ + ErlSpawnOpts so; + Eterm pid; + + so.flags = 0; + pid = erl_create_process(BIF_P, BIF_ARG_1, BIF_ARG_2, BIF_ARG_3, &so); + if (is_non_value(pid)) { + BIF_ERROR(BIF_P, so.error_code); + } else { + if (ERTS_USE_MODIFIED_TIMING()) { + BIF_TRAP2(erts_delay_trap, BIF_P, pid, ERTS_MODIFIED_TIMING_DELAY); + } + BIF_RET(pid); + } +} + +/**********************************************************************/ + +/* Utility to add a new link between processes p and another internal + * process (rpid). Process p must be the currently executing process. + */ +static int insert_internal_link(Process* p, Eterm rpid) +{ + Process *rp; + ErtsProcLocks rp_locks = ERTS_PROC_LOCK_LINK; + + ASSERT(is_internal_pid(rpid)); + +#ifdef ERTS_SMP + if (IS_TRACED(p) && (p->trace_flags & (F_TRACE_SOL|F_TRACE_SOL1))) + rp_locks = ERTS_PROC_LOCKS_ALL; + + erts_smp_proc_lock(p, ERTS_PROC_LOCK_LINK); +#endif + + /* get a pointer to the process struct of the linked process */ + rp = erts_pid2proc_opt(p, ERTS_PROC_LOCK_MAIN|ERTS_PROC_LOCK_LINK, + rpid, rp_locks, + ERTS_P2P_FLG_ALLOW_OTHER_X); + + if (!rp) { + erts_smp_proc_unlock(p, ERTS_PROC_LOCK_LINK); + return 0; + } + + if (p != rp) { + erts_add_link(&(p->nlinks), LINK_PID, rp->id); + erts_add_link(&(rp->nlinks), LINK_PID, p->id); + + ASSERT(is_nil(p->tracer_proc) + || is_internal_pid(p->tracer_proc) + || is_internal_port(p->tracer_proc)); + + if (IS_TRACED(p)) { + if (p->trace_flags & (F_TRACE_SOL|F_TRACE_SOL1)) { + rp->trace_flags |= (p->trace_flags & TRACEE_FLAGS); + rp->tracer_proc = p->tracer_proc; /* maybe steal */ + + if (p->trace_flags & F_TRACE_SOL1) { /* maybe override */ + rp->trace_flags &= ~(F_TRACE_SOL1 | F_TRACE_SOL); + p->trace_flags &= ~(F_TRACE_SOL1 | F_TRACE_SOL); + } + } + } + } + if (IS_TRACED_FL(rp, F_TRACE_PROCS)) + trace_proc(p, rp, am_getting_linked, p->id); + + if (p == rp) + erts_smp_proc_unlock(p, rp_locks & ~ERTS_PROC_LOCK_MAIN); + else { + erts_smp_proc_unlock(p, ERTS_PROC_LOCK_LINK); + erts_smp_proc_unlock(rp, rp_locks); + } + + return 1; +} + + +/* create a link to the process */ +BIF_RETTYPE link_1(BIF_ALIST_1) +{ + DistEntry *dep; + + if (IS_TRACED_FL(BIF_P, F_TRACE_PROCS)) { + trace_proc(BIF_P, BIF_P, am_link, BIF_ARG_1); + } + /* check that the pid or port which is our argument is OK */ + + if (is_internal_pid(BIF_ARG_1)) { + if (internal_pid_index(BIF_ARG_1) >= erts_max_processes) { + BIF_ERROR(BIF_P, BADARG); + } + + if (insert_internal_link(BIF_P, BIF_ARG_1)) { + BIF_RET(am_true); + } + else { + goto res_no_proc; + } + } + + if (is_internal_port(BIF_ARG_1)) { + Port *pt = erts_id2port(BIF_ARG_1, BIF_P, ERTS_PROC_LOCK_MAIN); + if (!pt) { + goto res_no_proc; + } + + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_LINK); + + if (erts_add_link(&(BIF_P->nlinks), LINK_PID, BIF_ARG_1) >= 0) + erts_add_link(&(pt->nlinks), LINK_PID, BIF_P->id); + /* else: already linked */ + + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_LINK); + erts_smp_port_unlock(pt); + BIF_RET(am_true); + } + else if (is_external_port(BIF_ARG_1) + && external_port_dist_entry(BIF_ARG_1) == erts_this_dist_entry) { + goto res_no_proc; + } + + if (is_external_pid(BIF_ARG_1)) { + + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_LINK); + + /* We may earn time by checking first that we're not linked already */ + if (erts_lookup_link(BIF_P->nlinks, BIF_ARG_1) != NULL) { + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_LINK); + BIF_RET(am_true); + } + else { + ErtsLink *lnk; + int code; + ErtsDSigData dsd; + dep = external_pid_dist_entry(BIF_ARG_1); + if (dep == erts_this_dist_entry) { + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_LINK); + goto res_no_proc; + } + + code = erts_dsig_prepare(&dsd, dep, BIF_P, ERTS_DSP_RLOCK, 0); + switch (code) { + case ERTS_DSIG_PREP_NOT_ALIVE: + /* Let the dlink trap handle it */ + case ERTS_DSIG_PREP_NOT_CONNECTED: + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_LINK); + BIF_TRAP1(dlink_trap, BIF_P, BIF_ARG_1); + + case ERTS_DSIG_PREP_CONNECTED: + /* We are connected. Setup link and send link signal */ + + erts_smp_de_links_lock(dep); + + erts_add_link(&(BIF_P->nlinks), LINK_PID, BIF_ARG_1); + lnk = erts_add_or_lookup_link(&(dep->nlinks), + LINK_PID, + BIF_P->id); + ASSERT(lnk != NULL); + erts_add_link(&ERTS_LINK_ROOT(lnk), LINK_PID, BIF_ARG_1); + + erts_smp_de_links_unlock(dep); + erts_smp_de_runlock(dep); + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_LINK); + + code = erts_dsig_send_link(&dsd, BIF_P->id, BIF_ARG_1); + if (code == ERTS_DSIG_SEND_YIELD) + ERTS_BIF_YIELD_RETURN(BIF_P, am_true); + BIF_RET(am_true); + default: + ASSERT(! "Invalid dsig prepare result"); + BIF_ERROR(BIF_P, EXC_INTERNAL_ERROR); + } + } + } + + BIF_ERROR(BIF_P, BADARG); + + res_no_proc: + if (BIF_P->flags & F_TRAPEXIT) { + ErtsProcLocks locks = ERTS_PROC_LOCK_MAIN; + erts_deliver_exit_message(BIF_ARG_1, BIF_P, &locks, am_noproc, NIL); + erts_smp_proc_unlock(BIF_P, ~ERTS_PROC_LOCK_MAIN & locks); + BIF_RET(am_true); + } + else + BIF_ERROR(BIF_P, EXC_NOPROC); +} + +#define ERTS_DEMONITOR_FALSE 2 +#define ERTS_DEMONITOR_TRUE 1 +#define ERTS_DEMONITOR_BADARG 0 +#define ERTS_DEMONITOR_YIELD_TRUE -1 +#define ERTS_DEMONITOR_INTERNAL_ERROR -2 + +static int +remote_demonitor(Process *c_p, DistEntry *dep, Eterm ref, Eterm to) +{ + ErtsDSigData dsd; + ErtsMonitor *dmon; + ErtsMonitor *mon; + int code; + int res; +#ifndef ERTS_SMP + int stale_mon = 0; +#endif + + ERTS_SMP_LC_ASSERT((ERTS_PROC_LOCK_MAIN|ERTS_PROC_LOCK_LINK) + == erts_proc_lc_my_proc_locks(c_p)); + + code = erts_dsig_prepare(&dsd, dep, c_p, ERTS_DSP_RLOCK, 0); + switch (code) { + case ERTS_DSIG_PREP_NOT_ALIVE: + case ERTS_DSIG_PREP_NOT_CONNECTED: +#ifndef ERTS_SMP + /* XXX Is this possible? Shouldn't this link + previously have been removed if the node + had previously been disconnected. */ + ASSERT(0); + stale_mon = 1; +#endif + /* + * In the smp case this is possible if the node goes + * down just before the call to demonitor. + */ + if (dep) { + erts_smp_de_links_lock(dep); + dmon = erts_remove_monitor(&dep->monitors, ref); + erts_smp_de_links_unlock(dep); + if (dmon) + erts_destroy_monitor(dmon); + } + mon = erts_remove_monitor(&c_p->monitors, ref); + erts_smp_proc_unlock(c_p, ERTS_PROC_LOCK_LINK); + + res = ERTS_DEMONITOR_TRUE; + break; + + case ERTS_DSIG_PREP_CONNECTED: + + erts_smp_de_links_lock(dep); + mon = erts_remove_monitor(&c_p->monitors, ref); + dmon = erts_remove_monitor(&dep->monitors, ref); + erts_smp_de_links_unlock(dep); + erts_smp_de_runlock(dep); + erts_smp_proc_unlock(c_p, ERTS_PROC_LOCK_LINK); + + if (!dmon) { +#ifndef ERTS_SMP + /* XXX How is this possible? Shouldn't this link + previously have been removed when the distributed + end was removed. */ + ASSERT(0); + stale_mon = 1; +#endif + /* + * This is possible when smp support is enabled. + * 'DOWN' message just arrived. + */ + res = ERTS_DEMONITOR_TRUE; + } + else { + /* + * Soft (no force) send, use ->data in dist slot + * monitor list since in case of monitor name + * the atom is stored there. Yield if necessary. + */ + code = erts_dsig_send_demonitor(&dsd, + c_p->id, + (mon->name != NIL + ? mon->name + : mon->pid), + ref, + 0); + res = (code == ERTS_DSIG_SEND_YIELD + ? ERTS_DEMONITOR_YIELD_TRUE + : ERTS_DEMONITOR_TRUE); + erts_destroy_monitor(dmon); + + } + break; + default: + ASSERT(! "Invalid dsig prepare result"); + res = ERTS_DEMONITOR_INTERNAL_ERROR; + break; + } + +#ifndef ERTS_SMP + if (stale_mon) { + erts_dsprintf_buf_t *dsbufp = erts_create_logger_dsbuf(); + erts_dsprintf(dsbufp, "Stale process monitor %T to ", ref); + if (is_atom(to)) + erts_dsprintf(dsbufp, "{%T, %T}", to, dep->sysname); + else + erts_dsprintf(dsbufp, "%T", to); + erts_dsprintf(dsbufp, " found\n"); + erts_send_error_to_logger(c_p->group_leader, dsbufp); + } +#endif + + /* + * We aren't allowed to destroy 'mon' until now, since 'to' + * may refer into 'mon' (external pid). + */ + ASSERT(mon); /* Since link lock wasn't released between + lookup and remove */ + erts_destroy_monitor(mon); + + ERTS_SMP_LC_ASSERT(ERTS_PROC_LOCK_MAIN == erts_proc_lc_my_proc_locks(c_p)); + return res; +} + +static int demonitor(Process *c_p, Eterm ref) +{ + ErtsMonitor *mon = NULL; /* The monitor entry to delete */ + Process *rp; /* Local target process */ + Eterm to = NIL; /* Monitor link traget */ + Eterm ref_p; /* Pid of this end */ + DistEntry *dep = NULL; /* Target's distribution entry */ + int deref_de = 0; + int res; + int unlock_link = 1; + + + erts_smp_proc_lock(c_p, ERTS_PROC_LOCK_LINK); + + if (is_not_internal_ref(ref)) { + res = ERTS_DEMONITOR_BADARG; + goto done; /* Cannot be this monitor's ref */ + } + ref_p = c_p->id; + + mon = erts_lookup_monitor(c_p->monitors, ref); + if (!mon) { + res = ERTS_DEMONITOR_FALSE; + goto done; + } + + if (mon->type != MON_ORIGIN) { + res = ERTS_DEMONITOR_BADARG; + goto done; + } + to = mon->pid; + + if (is_atom(to)) { + /* Monitoring a name at node to */ + ASSERT(is_node_name_atom(to)); + dep = erts_sysname_to_connected_dist_entry(to); + ASSERT(dep != erts_this_dist_entry); + if (dep) + deref_de = 1; + } else { + ASSERT(is_pid(to)); + dep = pid_dist_entry(to); + } + if (dep != erts_this_dist_entry) { + res = remote_demonitor(c_p, dep, ref, to); + /* remote_demonitor() unlocks link lock on c_p */ + unlock_link = 0; + } + else { /* Local monitor */ + if (deref_de) { + deref_de = 0; + erts_deref_dist_entry(dep); + } + dep = NULL; + rp = erts_pid2proc_opt(c_p, + ERTS_PROC_LOCK_MAIN|ERTS_PROC_LOCK_LINK, + to, + ERTS_PROC_LOCK_LINK, + ERTS_P2P_FLG_ALLOW_OTHER_X); + mon = erts_remove_monitor(&c_p->monitors, ref); +#ifndef ERTS_SMP + ASSERT(mon); +#else + if (!mon) + res = ERTS_DEMONITOR_FALSE; + else +#endif + { + res = ERTS_DEMONITOR_TRUE; + erts_destroy_monitor(mon); + } + if (rp) { + ErtsMonitor *rmon; + rmon = erts_remove_monitor(&(rp->monitors), ref); + if (rp != c_p) + erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_LINK); + if (rmon != NULL) + erts_destroy_monitor(rmon); + } + else { + ERTS_SMP_ASSERT_IS_NOT_EXITING(c_p); + } + + } + + done: + + if (unlock_link) + erts_smp_proc_unlock(c_p, ERTS_PROC_LOCK_LINK); + + if (deref_de) { + ASSERT(dep); + erts_deref_dist_entry(dep); + } + + ERTS_SMP_LC_ASSERT(ERTS_PROC_LOCK_MAIN == erts_proc_lc_my_proc_locks(c_p)); + return res; +} + +BIF_RETTYPE demonitor_1(BIF_ALIST_1) +{ + switch (demonitor(BIF_P, BIF_ARG_1)) { + case ERTS_DEMONITOR_FALSE: + case ERTS_DEMONITOR_TRUE: + BIF_RET(am_true); + case ERTS_DEMONITOR_YIELD_TRUE: + ERTS_BIF_YIELD_RETURN(BIF_P, am_true); + case ERTS_DEMONITOR_BADARG: + BIF_ERROR(BIF_P, BADARG); + case ERTS_DEMONITOR_INTERNAL_ERROR: + default: + ASSERT(! "demonitor(): internal error"); + BIF_ERROR(BIF_P, EXC_INTERNAL_ERROR); + } +} + +BIF_RETTYPE demonitor_2(BIF_ALIST_2) +{ + Eterm res = am_true; + int info = 0; + int flush = 0; + Eterm list = BIF_ARG_2; + + while (is_list(list)) { + Eterm* consp = list_val(list); + switch (CAR(consp)) { + case am_flush: + flush = 1; + break; + case am_info: + info = 1; + break; + default: + goto badarg; + } + list = CDR(consp); + } + + if (is_not_nil(list)) + goto badarg; + + switch (demonitor(BIF_P, BIF_ARG_1)) { + case ERTS_DEMONITOR_FALSE: + if (info) + res = am_false; + if (flush) + BIF_TRAP2(flush_monitor_message_trap, BIF_P, BIF_ARG_1, res); + case ERTS_DEMONITOR_TRUE: + BIF_RET(res); + case ERTS_DEMONITOR_YIELD_TRUE: + ERTS_BIF_YIELD_RETURN(BIF_P, am_true); + case ERTS_DEMONITOR_BADARG: + badarg: + BIF_ERROR(BIF_P, BADARG); + case ERTS_DEMONITOR_INTERNAL_ERROR: + default: + ASSERT(! "demonitor(): internal error"); + BIF_ERROR(BIF_P, EXC_INTERNAL_ERROR); + } +} + +/* Type must be atomic object! */ +void +erts_queue_monitor_message(Process *p, + ErtsProcLocks *p_locksp, + Eterm ref, + Eterm type, + Eterm item, + Eterm reason) +{ + Eterm tup; + Eterm* hp; + Eterm reason_copy, ref_copy, item_copy; + Uint reason_size, ref_size, item_size, heap_size; + ErlOffHeap *ohp; + ErlHeapFragment *bp; + + reason_size = IS_CONST(reason) ? 0 : size_object(reason); + item_size = IS_CONST(item) ? 0 : size_object(item); + ref_size = size_object(ref); + + heap_size = 6+reason_size+ref_size+item_size; + + hp = erts_alloc_message_heap(heap_size, + &bp, + &ohp, + p, + p_locksp); + + reason_copy = (IS_CONST(reason) + ? reason + : copy_struct(reason, reason_size, &hp, ohp)); + item_copy = (IS_CONST(item) + ? item + : copy_struct(item, item_size, &hp, ohp)); + ref_copy = copy_struct(ref, ref_size, &hp, ohp); + + tup = TUPLE5(hp, am_DOWN, ref_copy, type, item_copy, reason_copy); + erts_queue_message(p, p_locksp, bp, tup, NIL); +} + +static BIF_RETTYPE +local_pid_monitor(Process *p, Eterm target) +{ + BIF_RETTYPE ret; + Eterm mon_ref; + Process *rp; + ErtsProcLocks p_locks = ERTS_PROC_LOCK_MAIN|ERTS_PROC_LOCK_LINK; + + mon_ref = erts_make_ref(p); + ERTS_BIF_PREP_RET(ret, mon_ref); + if (target == p->id) { + return ret; + } + + erts_smp_proc_lock(p, ERTS_PROC_LOCK_LINK); + rp = erts_pid2proc_opt(p, p_locks, + target, ERTS_PROC_LOCK_LINK, + ERTS_P2P_FLG_ALLOW_OTHER_X); + if (!rp) { + erts_smp_proc_unlock(p, ERTS_PROC_LOCK_LINK); + p_locks &= ~ERTS_PROC_LOCK_LINK; + erts_queue_monitor_message(p, &p_locks, + mon_ref, am_process, target, am_noproc); + } + else { + ASSERT(rp != p); + + erts_add_monitor(&(p->monitors), MON_ORIGIN, mon_ref, target, NIL); + erts_add_monitor(&(rp->monitors), MON_TARGET, mon_ref, p->id, NIL); + + erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_LINK); + } + + erts_smp_proc_unlock(p, p_locks & ~ERTS_PROC_LOCK_MAIN); + + return ret; +} + +static BIF_RETTYPE +local_name_monitor(Process *p, Eterm target_name) +{ + BIF_RETTYPE ret; + Eterm mon_ref; + ErtsProcLocks p_locks = ERTS_PROC_LOCK_MAIN|ERTS_PROC_LOCK_LINK; + Process *rp; + + mon_ref = erts_make_ref(p); + ERTS_BIF_PREP_RET(ret, mon_ref); + erts_smp_proc_lock(p, ERTS_PROC_LOCK_LINK); + rp = erts_whereis_process(p, p_locks, target_name, ERTS_PROC_LOCK_LINK, + ERTS_P2P_FLG_ALLOW_OTHER_X); + if (!rp) { + Eterm lhp[3]; + Eterm item; + erts_smp_proc_unlock(p, ERTS_PROC_LOCK_LINK); + p_locks &= ~ERTS_PROC_LOCK_LINK; + item = TUPLE2(lhp, target_name, erts_this_dist_entry->sysname); + erts_queue_monitor_message(p, &p_locks, + mon_ref, am_process, item, am_noproc); + } + else if (rp != p) { + erts_add_monitor(&(p->monitors), MON_ORIGIN, mon_ref, rp->id, + target_name); + erts_add_monitor(&(rp->monitors), MON_TARGET, mon_ref, p->id, + target_name); + erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_LINK); + } + + erts_smp_proc_unlock(p, p_locks & ~ERTS_PROC_LOCK_MAIN); + + return ret; +} + +static BIF_RETTYPE +remote_monitor(Process *p, Eterm bifarg1, Eterm bifarg2, + DistEntry *dep, Eterm target, int byname) +{ + ErtsDSigData dsd; + BIF_RETTYPE ret; + int code; + + erts_smp_proc_lock(p, ERTS_PROC_LOCK_LINK); + code = erts_dsig_prepare(&dsd, dep, p, ERTS_DSP_RLOCK, 0); + switch (code) { + case ERTS_DSIG_PREP_NOT_ALIVE: + /* Let the dmonitor_p trap handle it */ + case ERTS_DSIG_PREP_NOT_CONNECTED: + erts_smp_proc_unlock(p, ERTS_PROC_LOCK_LINK); + ERTS_BIF_PREP_TRAP2(ret, dmonitor_p_trap, p, bifarg1, bifarg2); + break; + case ERTS_DSIG_PREP_CONNECTED: + if (!(dep->flags & DFLAG_DIST_MONITOR) + || (byname && !(dep->flags & DFLAG_DIST_MONITOR_NAME))) { + erts_smp_de_runlock(dep); + erts_smp_proc_unlock(p, ERTS_PROC_LOCK_LINK); + ERTS_BIF_PREP_ERROR(ret, p, BADARG); + } + else { + Eterm p_trgt, p_name, d_name, mon_ref; + + mon_ref = erts_make_ref(p); + + if (byname) { + p_trgt = dep->sysname; + p_name = target; + d_name = target; + } + else { + p_trgt = target; + p_name = NIL; + d_name = NIL; + } + + erts_smp_de_links_lock(dep); + + erts_add_monitor(&(p->monitors), MON_ORIGIN, mon_ref, p_trgt, + p_name); + erts_add_monitor(&(dep->monitors), MON_TARGET, mon_ref, p->id, + d_name); + + erts_smp_de_links_unlock(dep); + erts_smp_de_runlock(dep); + erts_smp_proc_unlock(p, ERTS_PROC_LOCK_LINK); + + code = erts_dsig_send_monitor(&dsd, p->id, target, mon_ref); + if (code == ERTS_DSIG_SEND_YIELD) + ERTS_BIF_PREP_YIELD_RETURN(ret, p, mon_ref); + else + ERTS_BIF_PREP_RET(ret, mon_ref); + } + break; + default: + ASSERT(! "Invalid dsig prepare result"); + ERTS_BIF_PREP_ERROR(ret, p, EXC_INTERNAL_ERROR); + break; + } + + return ret; +} + +BIF_RETTYPE monitor_2(BIF_ALIST_2) +{ + Eterm target = BIF_ARG_2; + BIF_RETTYPE ret; + DistEntry *dep = NULL; + int deref_de = 0; + + /* Only process monitors are implemented */ + if (BIF_ARG_1 != am_process) { + goto error; + } + + if (is_internal_pid(target)) { + local_pid: + ret = local_pid_monitor(BIF_P, target); + } else if (is_external_pid(target)) { + dep = external_pid_dist_entry(target); + if (dep == erts_this_dist_entry) + goto local_pid; + ret = remote_monitor(BIF_P, BIF_ARG_1, BIF_ARG_2, dep, target, 0); + } else if (is_atom(target)) { + ret = local_name_monitor(BIF_P, target); + } else if (is_tuple(target)) { + Eterm *tp = tuple_val(target); + Eterm remote_node; + Eterm name; + if (arityval(*tp) != 2) + goto error; + remote_node = tp[2]; + name = tp[1]; + if (!is_atom(remote_node) || !is_atom(name)) { + goto error; + } + if (!erts_is_alive && remote_node != am_Noname) { + goto error; /* Remote monitor from (this) undistributed node */ + } + dep = erts_sysname_to_connected_dist_entry(remote_node); + if (dep == erts_this_dist_entry) { + deref_de = 1; + ret = local_name_monitor(BIF_P, name); + } else { + if (dep) + deref_de = 1; + ret = remote_monitor(BIF_P, BIF_ARG_1, BIF_ARG_2, dep, name, 1); + } + } else { + error: + ERTS_BIF_PREP_ERROR(ret, BIF_P, BADARG); + } + if (deref_de) { + deref_de = 0; + erts_deref_dist_entry(dep); + } + + return ret; +} + + +/**********************************************************************/ +/* this is a combination of the spawn and link BIFs */ + +BIF_RETTYPE spawn_link_3(BIF_ALIST_3) +{ + ErlSpawnOpts so; + Eterm pid; + + so.flags = SPO_LINK; + pid = erl_create_process(BIF_P, BIF_ARG_1, BIF_ARG_2, BIF_ARG_3, &so); + if (is_non_value(pid)) { + BIF_ERROR(BIF_P, so.error_code); + } else { + if (ERTS_USE_MODIFIED_TIMING()) { + BIF_TRAP2(erts_delay_trap, BIF_P, pid, ERTS_MODIFIED_TIMING_DELAY); + } + BIF_RET(pid); + } +} + +/**********************************************************************/ + +BIF_RETTYPE spawn_opt_1(BIF_ALIST_1) +{ + ErlSpawnOpts so; + Eterm pid; + Eterm* tp; + Eterm ap; + Eterm arg; + Eterm res; + + /* + * Check that the first argument is a tuple of four elements. + */ + if (is_not_tuple(BIF_ARG_1)) { + error: + BIF_ERROR(BIF_P, BADARG); + } + tp = tuple_val(BIF_ARG_1); + if (*tp != make_arityval(4)) + goto error; + + /* + * Store default values for options. + */ + so.flags = SPO_USE_ARGS; + so.min_heap_size = H_MIN_SIZE; + so.priority = PRIORITY_NORMAL; + so.max_gen_gcs = (Uint16) erts_smp_atomic_read(&erts_max_gen_gcs); + so.scheduler = 0; + + /* + * Walk through the option list. + */ + ap = tp[4]; + while (is_list(ap)) { + arg = CAR(list_val(ap)); + if (arg == am_link) { + so.flags |= SPO_LINK; + } else if (arg == am_monitor) { + so.flags |= SPO_MONITOR; + } else if (is_tuple(arg)) { + Eterm* tp2 = tuple_val(arg); + Eterm val; + if (*tp2 != make_arityval(2)) + goto error; + arg = tp2[1]; + val = tp2[2]; + if (arg == am_priority) { + if (val == am_max) + so.priority = PRIORITY_MAX; + else if (val == am_high) + so.priority = PRIORITY_HIGH; + else if (val == am_normal) + so.priority = PRIORITY_NORMAL; + else if (val == am_low) + so.priority = PRIORITY_LOW; + else + goto error; + } else if (arg == am_min_heap_size && is_small(val)) { + Sint min_heap_size = signed_val(val); + if (min_heap_size < 0) { + goto error; + } else if (min_heap_size < H_MIN_SIZE) { + so.min_heap_size = H_MIN_SIZE; + } else { + so.min_heap_size = erts_next_heap_size(min_heap_size, 0); + } + } else if (arg == am_fullsweep_after && is_small(val)) { + Sint max_gen_gcs = signed_val(val); + if (max_gen_gcs < 0) { + goto error; + } else { + so.max_gen_gcs = max_gen_gcs; + } + } else if (arg == am_scheduler && is_small(val)) { + Sint scheduler = signed_val(val); + if (erts_common_run_queue && erts_no_schedulers > 1) + goto error; + if (scheduler < 0 || erts_no_schedulers < scheduler) + goto error; + so.scheduler = (int) scheduler; + } else { + goto error; + } + } else { + goto error; + } + ap = CDR(list_val(ap)); + } + if (is_not_nil(ap)) { + goto error; + } + + /* + * Spawn the process. + */ + pid = erl_create_process(BIF_P, tp[1], tp[2], tp[3], &so); + if (is_non_value(pid)) { + BIF_ERROR(BIF_P, so.error_code); + } else if (so.flags & SPO_MONITOR) { + Eterm* hp = HAlloc(BIF_P, 3); + res = TUPLE2(hp, pid, so.mref); + } else { + res = pid; + } + + if (ERTS_USE_MODIFIED_TIMING()) { + BIF_TRAP2(erts_delay_trap, BIF_P, res, ERTS_MODIFIED_TIMING_DELAY); + } + else { + BIF_RET(res); + } +} + + +/**********************************************************************/ +/* remove a link from a process */ +BIF_RETTYPE unlink_1(BIF_ALIST_1) +{ + Process *rp; + DistEntry *dep; + ErtsLink *l = NULL, *rl = NULL; + + /* + * SMP specific note concerning incoming exit signals: + * We have to have at least the status lock during removal of + * the link half on current process, and check for and handle + * a present pending exit while the status lock is held. This + * in order to ensure that we wont be exited by a link after + * it has been removed. + * + * (We also have to have the link lock, of course, in order to + * be allowed to remove the link...) + */ + + if (IS_TRACED_FL(BIF_P, F_TRACE_PROCS)) { + trace_proc(BIF_P, BIF_P, am_unlink, BIF_ARG_1); + } + + if (is_internal_port(BIF_ARG_1)) { + Port *pt = erts_id2port_sflgs(BIF_ARG_1, + BIF_P, + ERTS_PROC_LOCK_MAIN, + ERTS_PORT_SFLGS_DEAD); + + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_LINK|ERTS_PROC_LOCK_STATUS); +#ifdef ERTS_SMP + if (ERTS_PROC_PENDING_EXIT(BIF_P)) { + if (pt) + erts_smp_port_unlock(pt); + goto handle_pending_exit; + } +#endif + + l = erts_remove_link(&BIF_P->nlinks, BIF_ARG_1); + + ASSERT(pt || !l); + + if (pt) { + rl = erts_remove_link(&pt->nlinks, BIF_P->id); + erts_smp_port_unlock(pt); + if (rl) + erts_destroy_link(rl); + } + + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_LINK|ERTS_PROC_LOCK_STATUS); + + if (l) + erts_destroy_link(l); + + BIF_RET(am_true); + } + else if (is_external_port(BIF_ARG_1) + && external_port_dist_entry(BIF_ARG_1) == erts_this_dist_entry) { + BIF_RET(am_true); + } + + if (is_not_pid(BIF_ARG_1)) + BIF_ERROR(BIF_P, BADARG); + + if (is_external_pid(BIF_ARG_1)) { + ErtsDistLinkData dld; + int code; + ErtsDSigData dsd; + /* Blind removal, we might have trapped or anything, this leaves + us in a state where monitors might be inconsistent, but the dist + code should take care of it. */ + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_LINK|ERTS_PROC_LOCK_STATUS); +#ifdef ERTS_SMP + if (ERTS_PROC_PENDING_EXIT(BIF_P)) + goto handle_pending_exit; +#endif + l = erts_remove_link(&BIF_P->nlinks,BIF_ARG_1); + + erts_smp_proc_unlock(BIF_P, + ERTS_PROC_LOCK_LINK|ERTS_PROC_LOCK_STATUS); + + if (l) + erts_destroy_link(l); + + dep = external_pid_dist_entry(BIF_ARG_1); + if (dep == erts_this_dist_entry) { + BIF_RET(am_true); + } + + code = erts_dsig_prepare(&dsd, dep, BIF_P, ERTS_DSP_NO_LOCK, 0); + switch (code) { + case ERTS_DSIG_PREP_NOT_ALIVE: + case ERTS_DSIG_PREP_NOT_CONNECTED: +#if 1 + BIF_RET(am_true); +#else + /* + * This is how we used to do it, but the link is obviously not + * active, so I see no point in setting up a connection. + * /Rickard + */ + BIF_TRAP1(dunlink_trap, BIF_P, BIF_ARG_1); +#endif + + case ERTS_DSIG_PREP_CONNECTED: + erts_remove_dist_link(&dld, BIF_P->id, BIF_ARG_1, dep); + code = erts_dsig_send_unlink(&dsd, BIF_P->id, BIF_ARG_1); + erts_destroy_dist_link(&dld); + if (code == ERTS_DSIG_SEND_YIELD) + ERTS_BIF_YIELD_RETURN(BIF_P, am_true); + BIF_RET(am_true); + + default: + ASSERT(! "Invalid dsig prepare result"); + BIF_ERROR(BIF_P, EXC_INTERNAL_ERROR); + } + } + + /* Internal pid... */ + + /* process ok ? */ + if (internal_pid_index(BIF_ARG_1) >= erts_max_processes) + BIF_ERROR(BIF_P, BADARG); + + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_LINK|ERTS_PROC_LOCK_STATUS); + + /* get process struct */ + rp = erts_pid2proc_opt(BIF_P, (ERTS_PROC_LOCK_MAIN + | ERTS_PROC_LOCK_LINK + | ERTS_PROC_LOCK_STATUS), + BIF_ARG_1, ERTS_PROC_LOCK_LINK, + ERTS_P2P_FLG_ALLOW_OTHER_X); + +#ifdef ERTS_SMP + if (ERTS_PROC_PENDING_EXIT(BIF_P)) { + if (rp && rp != BIF_P) + erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_LINK); + goto handle_pending_exit; + } +#endif + + /* unlink and ignore errors */ + l = erts_remove_link(&BIF_P->nlinks,BIF_ARG_1); + if (l != NULL) + erts_destroy_link(l); + + if (!rp) { + ERTS_SMP_ASSERT_IS_NOT_EXITING(BIF_P); + } + else { + rl = erts_remove_link(&(rp->nlinks),BIF_P->id); + if (rl != NULL) + erts_destroy_link(rl); + + if (IS_TRACED_FL(rp, F_TRACE_PROCS) && rl != NULL) { + trace_proc(BIF_P, rp, am_getting_unlinked, BIF_P->id); + } + + if (rp != BIF_P) + erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_LINK); + } + + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_LINK|ERTS_PROC_LOCK_STATUS); + + BIF_RET(am_true); + +#ifdef ERTS_SMP + handle_pending_exit: + erts_handle_pending_exit(BIF_P, (ERTS_PROC_LOCK_MAIN + | ERTS_PROC_LOCK_LINK + | ERTS_PROC_LOCK_STATUS)); + ASSERT(ERTS_PROC_IS_EXITING(BIF_P)); + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_LINK|ERTS_PROC_LOCK_STATUS); + ERTS_BIF_EXITED(BIF_P); +#endif +} + +BIF_RETTYPE hibernate_3(BIF_ALIST_3) +{ + /* + * hibernate/3 is implemented as an instruction; therefore + * this function will never be called. + */ + BIF_ERROR(BIF_P, BADARG); +} + +/**********************************************************************/ + +BIF_RETTYPE get_stacktrace_0(Process* p) +{ + Eterm t = build_stacktrace(p, p->ftrace); + BIF_RET(t); +} + +/**********************************************************************/ +/* + * This is like exit/1, except that errors are logged if they terminate + * the process, and the final error value will be {Term,StackTrace}. + */ + +BIF_RETTYPE error_1(Process* p, Eterm term) +{ + p->fvalue = term; + BIF_ERROR(p, EXC_ERROR); +} + +/**********************************************************************/ +/* + * This is like error/1, except that the given 'args' will be included + * in the stacktrace. + */ + +BIF_RETTYPE error_2(Process* p, Eterm value, Eterm args) +{ + Eterm* hp = HAlloc(p, 3); + + p->fvalue = TUPLE2(hp, value, args); + BIF_ERROR(p, EXC_ERROR_2); +} + +/**********************************************************************/ +/* this is like throw/1 except that we set freason to EXC_EXIT */ + +BIF_RETTYPE exit_1(BIF_ALIST_1) +{ + BIF_P->fvalue = BIF_ARG_1; /* exit value */ + BIF_ERROR(BIF_P, EXC_EXIT); +} + + +/**********************************************************************/ +/* raise an exception of given class, value and stacktrace. + * + * If there is an error in the argument format, + * return the atom 'badarg' instead. + */ +Eterm +raise_3(Process *c_p, Eterm class, Eterm value, Eterm stacktrace) { + Eterm reason; + Eterm l, *hp, *hp_end, *tp; + int depth, cnt; + size_t sz; + struct StackTrace *s; + + if (class == am_error) { + c_p->fvalue = value; + reason = EXC_ERROR; + } else if (class == am_exit) { + c_p->fvalue = value; + reason = EXC_EXIT; + } else if (class == am_throw) { + c_p->fvalue = value; + reason = EXC_THROWN; + } else goto error; + reason &= ~EXF_SAVETRACE; + + /* Check syntax of stacktrace, and count depth. + * Accept anything that can be returned from erlang:get_stacktrace/0, + * as well as a 2-tuple with a fun as first element that the + * error_handler may need to give us. + */ + for (l = stacktrace, depth = 0; + is_list(l); + l = CDR(list_val(l)), depth++) { + Eterm t = CAR(list_val(l)); + int arity; + if (is_not_tuple(t)) goto error; + tp = tuple_val(t); + arity = arityval(tp[0]); + if ((arity == 3) && is_atom(tp[1]) && is_atom(tp[2])) continue; + if ((arity == 2) && is_fun(tp[1])) continue; + goto error; + } + if (is_not_nil(l)) goto error; + + /* Create stacktrace and store */ + if (depth <= erts_backtrace_depth) { + cnt = 0; + c_p->ftrace = stacktrace; + } else { + cnt = depth = erts_backtrace_depth; + c_p->ftrace = NIL; + } + tp = &c_p->ftrace; + sz = (offsetof(struct StackTrace, trace) + sizeof(Eterm) - 1) + / sizeof(Eterm); + hp = HAlloc(c_p, sz + 2*(cnt + 1)); + hp_end = hp + sz + 2*(cnt + 1); + s = (struct StackTrace *) hp; + s->header = make_neg_bignum_header(sz - 1); + s->freason = reason; + s->pc = NULL; + s->current = NULL; + s->depth = 0; + hp += sz; + if (cnt > 0) { + /* Copy list up to depth */ + for (cnt = 0, l = stacktrace; + cnt < depth; + cnt++, l = CDR(list_val(l))) { + ASSERT(*tp == NIL); + *tp = CONS(hp, CAR(list_val(l)), *tp); + tp = &CDR(list_val(*tp)); + hp += 2; + } + } + c_p->ftrace = CONS(hp, c_p->ftrace, make_big((Eterm *) s)); + hp += 2; + ASSERT(hp <= hp_end); + + BIF_ERROR(c_p, reason); + + error: + return am_badarg; +} + +/**********************************************************************/ +/* send an exit message to another process (if trapping exits) or + exit the other process */ + +BIF_RETTYPE exit_2(BIF_ALIST_2) +{ + Process *rp; + + /* + * If the first argument is not a pid, or a local port it is an error. + */ + + if (is_internal_port(BIF_ARG_1)) { + Port *prt; + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN); + prt = erts_id2port(BIF_ARG_1, NULL, 0); + if (prt) { + erts_do_exit_port(prt, BIF_P->id, BIF_ARG_2); + erts_port_release(prt); + } + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_MAIN); + ERTS_BIF_CHK_EXITED(BIF_P); + BIF_RET(am_true); + } + else if(is_external_port(BIF_ARG_1) + && external_port_dist_entry(BIF_ARG_1) == erts_this_dist_entry) + BIF_RET(am_true); + + /* + * If it is a remote pid, send a signal to the remote node. + */ + + if (is_external_pid(BIF_ARG_1)) { + int code; + ErtsDSigData dsd; + DistEntry *dep; + + dep = external_pid_dist_entry(BIF_ARG_1); + if(dep == erts_this_dist_entry) + BIF_RET(am_true); + + code = erts_dsig_prepare(&dsd, dep, BIF_P, ERTS_DSP_NO_LOCK, 0); + switch (code) { + case ERTS_DSIG_PREP_NOT_ALIVE: + case ERTS_DSIG_PREP_NOT_CONNECTED: + BIF_TRAP2(dexit_trap, BIF_P, BIF_ARG_1, BIF_ARG_2); + case ERTS_DSIG_PREP_CONNECTED: + code = erts_dsig_send_exit2(&dsd, BIF_P->id, BIF_ARG_1, BIF_ARG_2); + if (code == ERTS_DSIG_SEND_YIELD) + ERTS_BIF_YIELD_RETURN(BIF_P, am_true); + BIF_RET(am_true); + default: + ASSERT(! "Invalid dsig prepare result"); + BIF_ERROR(BIF_P, EXC_INTERNAL_ERROR); + } + } + else if (is_not_internal_pid(BIF_ARG_1)) { + BIF_ERROR(BIF_P, BADARG); + } + else { + /* + * The pid is internal. Verify that it refers to an existing process. + */ + ErtsProcLocks rp_locks; + + if (internal_pid_index(BIF_ARG_1) >= erts_max_processes) + BIF_ERROR(BIF_P, BADARG); + if (BIF_ARG_1 == BIF_P->id) { + rp_locks = ERTS_PROC_LOCKS_ALL; + rp = BIF_P; + erts_smp_proc_lock(rp, ERTS_PROC_LOCKS_ALL_MINOR); + } + else { + rp_locks = ERTS_PROC_LOCKS_XSIG_SEND; + rp = erts_pid2proc_opt(BIF_P, ERTS_PROC_LOCK_MAIN, + BIF_ARG_1, rp_locks, + ERTS_P2P_FLG_SMP_INC_REFC); + if (!rp) { + BIF_RET(am_true); + } + } + + /* + * Send an exit signal. + */ + erts_send_exit_signal(BIF_P, + BIF_P->id, + rp, + &rp_locks, + BIF_ARG_2, + NIL, + NULL, + BIF_P == rp ? ERTS_XSIG_FLG_NO_IGN_NORMAL : 0); +#ifdef ERTS_SMP + if (rp == BIF_P) + rp_locks &= ~ERTS_PROC_LOCK_MAIN; + else + erts_smp_proc_dec_refc(rp); + erts_smp_proc_unlock(rp, rp_locks); +#endif + /* + * We may have exited ourselves and may have to take action. + */ + ERTS_BIF_CHK_EXITED(BIF_P); + BIF_RET(am_true); + } +} + +/**********************************************************************/ +/* this sets some process info- trapping exits or the error handler */ + + +/* Handle flags common to both process_flag_2 and process_flag_3. */ +static BIF_RETTYPE process_flag_aux(Process *BIF_P, + Process *rp, + Eterm flag, + Eterm val) +{ + Eterm old_value = NIL; /* shut up warning about use before set */ + Sint i; + if (flag == am_save_calls) { + struct saved_calls *scb; + if (!is_small(val)) + goto error; + i = signed_val(val); + if (i < 0 || i > 10000) + goto error; + + if (i == 0) + scb = NULL; + else { + Uint sz = sizeof(*scb) + (i-1) * sizeof(scb->ct[0]); + scb = erts_alloc(ERTS_ALC_T_CALLS_BUF, sz); + scb->len = i; + scb->cur = 0; + scb->n = 0; + } + + scb = ERTS_PROC_SET_SAVED_CALLS_BUF(rp, ERTS_PROC_LOCK_MAIN, scb); + + if (!scb) + old_value = make_small(0); + else { + old_value = make_small(scb->len); + erts_free(ERTS_ALC_T_CALLS_BUF, (void *) scb); + } + + /* Make sure the process in question is rescheduled + immediately, if it's us, so the call saving takes effect. */ + if (rp == BIF_P) + BIF_RET2(old_value, CONTEXT_REDS); + else + BIF_RET(old_value); + } + + error: + BIF_ERROR(BIF_P, BADARG); +} + +BIF_RETTYPE process_flag_2(BIF_ALIST_2) +{ + Eterm old_value; + if (BIF_ARG_1 == am_error_handler) { + if (is_not_atom(BIF_ARG_2)) { + goto error; + } + old_value = erts_proc_set_error_handler(BIF_P, + ERTS_PROC_LOCK_MAIN, + BIF_ARG_2); + BIF_RET(old_value); + } + else if (BIF_ARG_1 == am_priority) { + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_STATUS); + old_value = erts_set_process_priority(BIF_P, BIF_ARG_2); + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_STATUS); + if (old_value == THE_NON_VALUE) + goto error; + BIF_RET(old_value); + } + else if (BIF_ARG_1 == am_trap_exit) { + Uint trap_exit; + if (BIF_ARG_2 == am_true) { + trap_exit = 1; + } else if (BIF_ARG_2 == am_false) { + trap_exit = 0; + } else { + goto error; + } + /* + * NOTE: It is important that we check for pending exit signals + * and handle them before flag trap_exit is set to true. + * For more info, see implementation of erts_send_exit_signal(). + */ + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_STATUS); + ERTS_SMP_BIF_CHK_PENDING_EXIT(BIF_P, + ERTS_PROC_LOCK_MAIN|ERTS_PROC_LOCK_STATUS); + old_value = ERTS_PROC_IS_TRAPPING_EXITS(BIF_P) ? am_true : am_false; + if (trap_exit) { + ERTS_PROC_SET_TRAP_EXIT(BIF_P); + } else { + ERTS_PROC_UNSET_TRAP_EXIT(BIF_P); + } + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_STATUS); + BIF_RET(old_value); + } + else if (BIF_ARG_1 == am_scheduler) { + int yield; + ErtsRunQueue *old; + ErtsRunQueue *new; + Sint sched; + if (erts_common_run_queue && erts_no_schedulers > 1) + goto error; + if (!is_small(BIF_ARG_2)) + goto error; + sched = signed_val(BIF_ARG_2); + if (sched < 0 || erts_no_schedulers < sched) + goto error; + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_STATUS); + old = BIF_P->bound_runq; +#ifdef ERTS_SMP + ASSERT(!old || old == BIF_P->run_queue); +#endif + new = !sched ? NULL : erts_schedid2runq(sched); +#ifndef ERTS_SMP + yield = 0; +#else + if (new == old) + yield = 0; + else { + ErtsRunQueue *curr = BIF_P->run_queue; + if (!new) + erts_smp_runq_lock(curr); + else + erts_smp_runqs_lock(curr, new); + yield = new && BIF_P->run_queue != new; +#endif + BIF_P->bound_runq = new; +#ifdef ERTS_SMP + if (new) + BIF_P->run_queue = new; + if (!new) + erts_smp_runq_unlock(curr); + else + erts_smp_runqs_unlock(curr, new); + } +#endif + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_STATUS); + old_value = old ? make_small(old->ix+1) : make_small(0); + if (yield) + ERTS_BIF_YIELD_RETURN_X(BIF_P, old_value, am_scheduler); + else + BIF_RET(old_value); + } + else if (BIF_ARG_1 == am_min_heap_size) { + Sint i; + if (!is_small(BIF_ARG_2)) { + goto error; + } + i = signed_val(BIF_ARG_2); + if (i < 0) { + goto error; + } + old_value = make_small(BIF_P->min_heap_size); + if (i < H_MIN_SIZE) { + BIF_P->min_heap_size = H_MIN_SIZE; + } else { + BIF_P->min_heap_size = erts_next_heap_size(i, 0); + } + BIF_RET(old_value); + } + else if (BIF_ARG_1 == am_sensitive) { + Uint is_sensitive; + if (BIF_ARG_2 == am_true) { + is_sensitive = 1; + } else if (BIF_ARG_2 == am_false) { + is_sensitive = 0; + } else { + goto error; + } + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCKS_ALL_MINOR); + old_value = BIF_P->trace_flags & F_SENSITIVE ? am_true : am_false; + if (is_sensitive) { + BIF_P->trace_flags |= F_SENSITIVE; + } else { + BIF_P->trace_flags &= ~F_SENSITIVE; + } + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCKS_ALL_MINOR); + BIF_RET(old_value); + } + else if (BIF_ARG_1 == am_monitor_nodes) { + /* + * This argument is intentionally *not* documented. It is intended + * to be used by net_kernel:monitor_nodes/1. + */ + old_value = erts_monitor_nodes(BIF_P, BIF_ARG_2, NIL); + if (old_value == THE_NON_VALUE) + goto error; + BIF_RET(old_value); + } + else if (is_tuple(BIF_ARG_1)) { + /* + * This argument is intentionally *not* documented. It is intended + * to be used by net_kernel:monitor_nodes/2. + */ + Eterm *tp = tuple_val(BIF_ARG_1); + if (arityval(tp[0]) == 2) { + if (tp[1] == am_monitor_nodes) { + old_value = erts_monitor_nodes(BIF_P, BIF_ARG_2, tp[2]); + if (old_value == THE_NON_VALUE) + goto error; + BIF_RET(old_value); + } + } + /* Fall through and try process_flag_aux() ... */ + } + + BIF_RET(process_flag_aux(BIF_P, BIF_P, BIF_ARG_1, BIF_ARG_2)); + error: + BIF_ERROR(BIF_P, BADARG); +} + +BIF_RETTYPE process_flag_3(BIF_ALIST_3) +{ + Process *rp; + Eterm res; + + if ((rp = erts_pid2proc(BIF_P, ERTS_PROC_LOCK_MAIN, + BIF_ARG_1, ERTS_PROC_LOCK_MAIN)) == NULL) { + BIF_ERROR(BIF_P, BADARG); + } + + res = process_flag_aux(BIF_P, rp, BIF_ARG_2, BIF_ARG_3); + + if (rp != BIF_P) + erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_MAIN); + + return res; +} + +/**********************************************************************/ + +/* register(atom, Process|Port) registers a global process or port + (for this node) */ + +BIF_RETTYPE register_2(BIF_ALIST_2) /* (Atom, Pid|Port) */ +{ + if (erts_register_name(BIF_P, BIF_ARG_1, BIF_ARG_2)) + BIF_RET(am_true); + else { + BIF_ERROR(BIF_P, BADARG); + } +} + + +/**********************************************************************/ + +/* removes the registration of a process or port */ + +BIF_RETTYPE unregister_1(BIF_ALIST_1) +{ + int res; + if (is_not_atom(BIF_ARG_1)) { + BIF_ERROR(BIF_P, BADARG); + } + res = erts_unregister_name(BIF_P, ERTS_PROC_LOCK_MAIN, NULL, BIF_ARG_1); + if (res == 0) { + BIF_ERROR(BIF_P, BADARG); + } + BIF_RET(am_true); +} + +/**********************************************************************/ + +/* find out the pid of a registered process */ +/* this is a rather unsafe BIF as it allows users to do nasty things. */ + +BIF_RETTYPE whereis_1(BIF_ALIST_1) +{ + Eterm res; + + if (is_not_atom(BIF_ARG_1)) { + BIF_ERROR(BIF_P, BADARG); + } + res = erts_whereis_name_to_id(BIF_P, BIF_ARG_1); + BIF_RET(res); +} + +/**********************************************************************/ + +/* + * erlang:'!'/2 + */ + +Eterm +ebif_bang_2(Process* p, Eterm To, Eterm Message) +{ + return send_2(p, To, Message); +} + + +/* + * Send a message to Process, Port or Registered Process. + * Returns non-negative reduction bump or negative result code. + */ +#define SEND_TRAP (-1) +#define SEND_YIELD (-2) +#define SEND_YIELD_RETURN (-3) +#define SEND_BADARG (-4) +#define SEND_USER_ERROR (-5) +#define SEND_INTERNAL_ERROR (-6) + +Sint do_send(Process *p, Eterm to, Eterm msg, int suspend); + +static Sint remote_send(Process *p, DistEntry *dep, + Eterm to, Eterm full_to, Eterm msg, int suspend) +{ + Sint res; + int code; + ErtsDSigData dsd; + + ASSERT(is_atom(to) || is_external_pid(to)); + + code = erts_dsig_prepare(&dsd, dep, p, ERTS_DSP_NO_LOCK, !suspend); + switch (code) { + case ERTS_DSIG_PREP_NOT_ALIVE: + case ERTS_DSIG_PREP_NOT_CONNECTED: + res = SEND_TRAP; + break; + case ERTS_DSIG_PREP_WOULD_SUSPEND: + ASSERT(!suspend); + res = SEND_YIELD; + break; + case ERTS_DSIG_PREP_CONNECTED: { + + if (is_atom(to)) + code = erts_dsig_send_reg_msg(&dsd, to, msg); + else + code = erts_dsig_send_msg(&dsd, to, msg); + /* + * Note that reductions have been bumped on calling + * process by erts_dsig_send_reg_msg() or + * erts_dsig_send_msg(). + */ + if (code == ERTS_DSIG_SEND_YIELD) + res = SEND_YIELD_RETURN; + else + res = 0; + break; + } + default: + ASSERT(! "Invalid dsig prepare result"); + res = SEND_INTERNAL_ERROR; + } + + if (res >= 0) { + if (IS_TRACED(p)) + trace_send(p, full_to, msg); + if (ERTS_PROC_GET_SAVED_CALLS_BUF(p)) + save_calls(p, &exp_send); + } + + return res; +} + +Sint +do_send(Process *p, Eterm to, Eterm msg, int suspend) { + Eterm portid; + Port *pt; + Process* rp; + DistEntry *dep; + Eterm* tp; + + if (is_internal_pid(to)) { + if (IS_TRACED(p)) + trace_send(p, to, msg); + if (ERTS_PROC_GET_SAVED_CALLS_BUF(p)) + save_calls(p, &exp_send); + + if (internal_pid_index(to) >= erts_max_processes) + return SEND_BADARG; + + rp = erts_pid2proc_opt(p, ERTS_PROC_LOCK_MAIN, + to, 0, ERTS_P2P_FLG_SMP_INC_REFC); + + if (!rp) { + ERTS_SMP_ASSERT_IS_NOT_EXITING(p); + return 0; + } + } else if (is_external_pid(to)) { + dep = external_pid_dist_entry(to); + if(dep == erts_this_dist_entry) { + erts_dsprintf_buf_t *dsbufp = erts_create_logger_dsbuf(); + erts_dsprintf(dsbufp, + "Discarding message %T from %T to %T in an old " + "incarnation (%d) of this node (%d)\n", + msg, + p->id, + to, + external_pid_creation(to), + erts_this_node->creation); + erts_send_error_to_logger(p->group_leader, dsbufp); + return 0; + } + return remote_send(p, dep, to, to, msg, suspend); + } else if (is_atom(to)) { + + /* Need to virtual schedule out sending process + * because of lock wait. This is only necessary + * for internal port calling but the lock is bundled + * with name lookup. + */ + + if (IS_TRACED_FL(p, F_TRACE_SCHED_PROCS)) { + trace_virtual_sched(p, am_out); + } + if (erts_system_profile_flags.runnable_procs && erts_system_profile_flags.exclusive) { + profile_runnable_proc(p, am_inactive); + } + erts_whereis_name(p, ERTS_PROC_LOCK_MAIN, + to, + &rp, 0, ERTS_P2P_FLG_SMP_INC_REFC, + &pt); + + if (pt) { + portid = pt->id; + goto port_common; + } + + /* Not a port virtually schedule the process back in */ + if (IS_TRACED_FL(p, F_TRACE_SCHED_PROCS)) { + trace_virtual_sched(p, am_in); + } + if (erts_system_profile_flags.runnable_procs && erts_system_profile_flags.exclusive) { + profile_runnable_proc(p, am_active); + } + + if (IS_TRACED(p)) + trace_send(p, to, msg); + if (ERTS_PROC_GET_SAVED_CALLS_BUF(p)) + save_calls(p, &exp_send); + + if (!rp) { + return SEND_BADARG; + } + } else if (is_external_port(to) + && (external_port_dist_entry(to) + == erts_this_dist_entry)) { + erts_dsprintf_buf_t *dsbufp = erts_create_logger_dsbuf(); + erts_dsprintf(dsbufp, + "Discarding message %T from %T to %T in an old " + "incarnation (%d) of this node (%d)\n", + msg, + p->id, + to, + external_port_creation(to), + erts_this_node->creation); + erts_send_error_to_logger(p->group_leader, dsbufp); + return 0; + } else if (is_internal_port(to)) { + portid = to; + /* schedule out calling process, waiting for lock*/ + if (IS_TRACED_FL(p, F_TRACE_SCHED_PROCS)) { + trace_virtual_sched(p, am_out); + } + if (erts_system_profile_flags.runnable_procs && erts_system_profile_flags.exclusive) { + profile_runnable_proc(p, am_inactive); + } + pt = erts_id2port(to, p, ERTS_PROC_LOCK_MAIN); + port_common: + ERTS_SMP_LC_ASSERT(!pt || erts_lc_is_port_locked(pt)); + + /* We have waited for locks, trace schedule ports */ + if (pt && IS_TRACED_FL(pt, F_TRACE_SCHED_PORTS)) { + trace_sched_ports_where(pt, am_in, am_command); + } + if (pt && erts_system_profile_flags.runnable_ports && !erts_port_is_scheduled(pt)) { + profile_runnable_port(pt, am_active); + } + + /* XXX let port_command handle the busy stuff !!! */ + if (pt && (pt->status & ERTS_PORT_SFLG_PORT_BUSY)) { + if (suspend) { + erts_suspend(p, ERTS_PROC_LOCK_MAIN, pt); + if (erts_system_monitor_flags.busy_port) { + monitor_generic(p, am_busy_port, portid); + } + } + /* Virtually schedule out the port before releasing */ + if (IS_TRACED_FL(pt, F_TRACE_SCHED_PORTS)) { + trace_sched_ports_where(pt, am_out, am_command); + } + if (erts_system_profile_flags.runnable_ports && !erts_port_is_scheduled(pt)) { + profile_runnable_port(pt, am_inactive); + } + erts_port_release(pt); + return SEND_YIELD; + } + + if (IS_TRACED(p)) /* trace once only !! */ + trace_send(p, portid, msg); + if (ERTS_PROC_GET_SAVED_CALLS_BUF(p)) + save_calls(p, &exp_send); + + if (SEQ_TRACE_TOKEN(p) != NIL) { + seq_trace_update_send(p); + seq_trace_output(SEQ_TRACE_TOKEN(p), msg, + SEQ_TRACE_SEND, portid, p); + } + + /* XXX NO GC in port command */ + erts_port_command(p, p->id, pt, msg); + if (pt) { + /* Virtually schedule out the port before releasing */ + if (IS_TRACED_FL(pt, F_TRACE_SCHED_PORTS)) { + trace_sched_ports_where(pt, am_out, am_command); + } + if (erts_system_profile_flags.runnable_ports && !erts_port_is_scheduled(pt)) { + profile_runnable_port(pt, am_inactive); + } + erts_port_release(pt); + } + /* Virtually schedule in process */ + if (IS_TRACED_FL(p, F_TRACE_SCHED_PROCS)) { + trace_virtual_sched(p, am_in); + } + if (erts_system_profile_flags.runnable_procs && erts_system_profile_flags.exclusive) { + profile_runnable_proc(p, am_active); + } + if (ERTS_PROC_IS_EXITING(p)) { + KILL_CATCHES(p); /* Must exit */ + return SEND_USER_ERROR; + } + return 0; + } else if (is_tuple(to)) { /* Remote send */ + int ret; + tp = tuple_val(to); + if (*tp != make_arityval(2)) + return SEND_BADARG; + if (is_not_atom(tp[1]) || is_not_atom(tp[2])) + return SEND_BADARG; + + /* sysname_to_connected_dist_entry will return NULL if there + is no dist_entry or the dist_entry has no port, + but remote_send() will handle that. */ + + dep = erts_sysname_to_connected_dist_entry(tp[2]); + + if (dep == erts_this_dist_entry) { + erts_deref_dist_entry(dep); + if (IS_TRACED(p)) + trace_send(p, to, msg); + if (ERTS_PROC_GET_SAVED_CALLS_BUF(p)) + save_calls(p, &exp_send); + + /* Need to virtual schedule out sending process + * because of lock wait. This is only necessary + * for internal port calling but the lock is bundled. + */ + + if (IS_TRACED_FL(p, F_TRACE_SCHED_PROCS)) { + trace_virtual_sched(p, am_out); + } + if (erts_system_profile_flags.runnable_procs && erts_system_profile_flags.exclusive) { + profile_runnable_proc(p, am_inactive); + } + + erts_whereis_name(p, ERTS_PROC_LOCK_MAIN, + tp[1], + &rp, 0, ERTS_P2P_FLG_SMP_INC_REFC, + &pt); + if (pt) { + portid = pt->id; + goto port_common; + } + /* Port lookup failed, virtually schedule the process + * back in. + */ + + if (IS_TRACED_FL(p, F_TRACE_SCHED_PROCS)) { + trace_virtual_sched(p, am_in); + } + if (erts_system_profile_flags.runnable_procs && erts_system_profile_flags.exclusive) { + profile_runnable_proc(p, am_active); + } + + if (!rp) { + return 0; + } + goto send_message; + } + + ret = remote_send(p, dep, tp[1], to, msg, suspend); + if (dep) + erts_deref_dist_entry(dep); + return ret; + } else { + if (IS_TRACED(p)) /* XXX Is this really neccessary ??? */ + trace_send(p, to, msg); + if (ERTS_PROC_GET_SAVED_CALLS_BUF(p)) + save_calls(p, &exp_send); + return SEND_BADARG; + } + + send_message: { + ErtsProcLocks rp_locks = 0; + Sint res; +#ifdef ERTS_SMP + if (p == rp) + rp_locks |= ERTS_PROC_LOCK_MAIN; +#endif + /* send to local process */ + erts_send_message(p, rp, &rp_locks, msg, 0); + if (!erts_use_sender_punish) + res = 0; + else { +#ifdef ERTS_SMP + res = rp->msg_inq.len*4; + if (ERTS_PROC_LOCK_MAIN & rp_locks) + res += rp->msg.len*4; +#else + res = rp->msg.len*4; +#endif + } + erts_smp_proc_unlock(rp, + p == rp + ? (rp_locks & ~ERTS_PROC_LOCK_MAIN) + : rp_locks); + erts_smp_proc_dec_refc(rp); + return res; + } +} + + +Eterm +send_3(Process *p, Eterm to, Eterm msg, Eterm opts) { + int connect = !0; + int suspend = !0; + Eterm l = opts; + Sint result; + + while (is_list(l)) { + if (CAR(list_val(l)) == am_noconnect) { + connect = 0; + } else if (CAR(list_val(l)) == am_nosuspend) { + suspend = 0; + } else { + BIF_ERROR(p, BADARG); + } + l = CDR(list_val(l)); + } + if(!is_nil(l)) { + BIF_ERROR(p, BADARG); + } + + result = do_send(p, to, msg, suspend); + if (result > 0) { + ERTS_VBUMP_REDS(p, result); + BIF_RET(am_ok); + } else switch (result) { + case 0: + BIF_RET(am_ok); + break; + case SEND_TRAP: + if (connect) { + BIF_TRAP3(dsend3_trap, p, to, msg, opts); + } else { + BIF_RET(am_noconnect); + } + break; + case SEND_YIELD: + if (suspend) { + ERTS_BIF_YIELD3(bif_export[BIF_send_3], p, to, msg, opts); + } else { + BIF_RET(am_nosuspend); + } + break; + case SEND_YIELD_RETURN: + if (suspend) + ERTS_BIF_YIELD_RETURN(p, am_ok); + else + BIF_RET(am_nosuspend); + case SEND_BADARG: + BIF_ERROR(p, BADARG); + break; + case SEND_USER_ERROR: + BIF_ERROR(p, EXC_ERROR); + break; + case SEND_INTERNAL_ERROR: + BIF_ERROR(p, EXC_INTERNAL_ERROR); + break; + default: + ASSERT(! "Illegal send result"); + break; + } + ASSERT(! "Can not arrive here"); + BIF_ERROR(p, BADARG); +} + +Eterm +send_2(Process *p, Eterm to, Eterm msg) { + Sint result = do_send(p, to, msg, !0); + + if (result > 0) { + ERTS_VBUMP_REDS(p, result); + BIF_RET(msg); + } else switch (result) { + case 0: + BIF_RET(msg); + break; + case SEND_TRAP: + BIF_TRAP2(dsend2_trap, p, to, msg); + break; + case SEND_YIELD: + ERTS_BIF_YIELD2(bif_export[BIF_send_2], p, to, msg); + break; + case SEND_YIELD_RETURN: + ERTS_BIF_YIELD_RETURN(p, msg); + case SEND_BADARG: + BIF_ERROR(p, BADARG); + break; + case SEND_USER_ERROR: + BIF_ERROR(p, EXC_ERROR); + break; + case SEND_INTERNAL_ERROR: + BIF_ERROR(p, EXC_INTERNAL_ERROR); + break; + default: + ASSERT(! "Illegal send result"); + break; + } + ASSERT(! "Can not arrive here"); + BIF_ERROR(p, BADARG); +} + +/**********************************************************************/ +/* + * apply/3 is implemented as an instruction and as erlang code in the + * erlang module. + * + * There is only one reason that apply/3 is included in the BIF table: + * The error handling code in the beam emulator passes the pointer to + * this function to the error handling code if the apply instruction + * fails. The error handling use the function pointer to lookup + * erlang:apply/3 in the BIF table. + * + * This function will never be called. (It could be if init did something + * like this: apply(erlang, apply, [M, F, A]). Not recommended.) + */ + +BIF_RETTYPE apply_3(BIF_ALIST_3) +{ + BIF_ERROR(BIF_P, BADARG); +} + + +/**********************************************************************/ + +/* integer to float */ + +/**********************************************************************/ + +/* returns the head of a list - this function is unecessary + and is only here to keep Robert happy (Even more, since it's OP as well) */ +BIF_RETTYPE hd_1(BIF_ALIST_1) +{ + if (is_not_list(BIF_ARG_1)) { + BIF_ERROR(BIF_P, BADARG); + } + BIF_RET(CAR(list_val(BIF_ARG_1))); +} + +/**********************************************************************/ + +/* returns the tails of a list - same comment as above */ + +BIF_RETTYPE tl_1(BIF_ALIST_1) +{ + if (is_not_list(BIF_ARG_1)) { + BIF_ERROR(BIF_P, BADARG); + } + BIF_RET(CDR(list_val(BIF_ARG_1))); +} + + +/**********************************************************************/ +/* return the size of an I/O list */ + +BIF_RETTYPE iolist_size_1(BIF_ALIST_1) +{ + Sint size = io_list_len(BIF_ARG_1); + + if (size == -1) { + BIF_ERROR(BIF_P, BADARG); + } else if (IS_USMALL(0, (Uint) size)) { + BIF_RET(make_small(size)); + } else { + Eterm* hp = HAlloc(BIF_P, BIG_UINT_HEAP_SIZE); + BIF_RET(uint_to_big(size, hp)); + } +} + + +/**********************************************************************/ + +/* return the N'th element of a tuple */ + +BIF_RETTYPE element_2(BIF_ALIST_2) +{ + if (is_not_small(BIF_ARG_1)) { + BIF_ERROR(BIF_P, BADARG); + } + if (is_tuple(BIF_ARG_2)) { + Eterm* tuple_ptr = tuple_val(BIF_ARG_2); + Sint ix = signed_val(BIF_ARG_1); + + if ((ix >= 1) && (ix <= arityval(*tuple_ptr))) + BIF_RET(tuple_ptr[ix]); + } + BIF_ERROR(BIF_P, BADARG); +} + +/**********************************************************************/ + +/* return the arity of a tuple */ + +BIF_RETTYPE tuple_size_1(BIF_ALIST_1) +{ + if (is_tuple(BIF_ARG_1)) { + return make_small(arityval(*tuple_val(BIF_ARG_1))); + } + BIF_ERROR(BIF_P, BADARG); +} + +/**********************************************************************/ + +/* set the n'th element in a tuple */ + +BIF_RETTYPE setelement_3(BIF_ALIST_3) +{ + Eterm* ptr; + Eterm* hp; + Eterm* resp; + Uint ix; + Uint size; + + if (is_not_small(BIF_ARG_1) || is_not_tuple(BIF_ARG_2)) { + error: + BIF_ERROR(BIF_P, BADARG); + } + ptr = tuple_val(BIF_ARG_2); + ix = signed_val(BIF_ARG_1); + size = arityval(*ptr) + 1; /* include arity */ + if ((ix < 1) || (ix >= size)) { + goto error; + } + + hp = HAlloc(BIF_P, size); + + /* copy the tuple */ + resp = hp; + while (size--) { /* XXX use memcpy? */ + *hp++ = *ptr++; + } + resp[ix] = BIF_ARG_3; + BIF_RET(make_tuple(resp)); +} + +/**********************************************************************/ + +BIF_RETTYPE make_tuple_2(BIF_ALIST_2) +{ + Sint n; + Eterm* hp; + Eterm res; + + if (is_not_small(BIF_ARG_1) || (n = signed_val(BIF_ARG_1)) < 0) { + BIF_ERROR(BIF_P, BADARG); + } + hp = HAlloc(BIF_P, n+1); + res = make_tuple(hp); + *hp++ = make_arityval(n); + while (n--) { + *hp++ = BIF_ARG_2; + } + BIF_RET(res); +} + +BIF_RETTYPE make_tuple_3(BIF_ALIST_3) +{ + Sint n; + Uint limit; + Eterm* hp; + Eterm res; + Eterm list = BIF_ARG_3; + Eterm* tup; + + if (is_not_small(BIF_ARG_1) || (n = signed_val(BIF_ARG_1)) < 0) { + error: + BIF_ERROR(BIF_P, BADARG); + } + limit = (Uint) n; + hp = HAlloc(BIF_P, n+1); + res = make_tuple(hp); + *hp++ = make_arityval(n); + tup = hp; + while (n--) { + *hp++ = BIF_ARG_2; + } + while(is_list(list)) { + Eterm* cons; + Eterm hd; + Eterm* tp; + Eterm index; + Uint index_val; + + cons = list_val(list); + hd = CAR(cons); + list = CDR(cons); + if (is_not_tuple_arity(hd, 2)) { + goto error; + } + tp = tuple_val(hd); + if (is_not_small(index = tp[1])) { + goto error; + } + if ((index_val = unsigned_val(index) - 1) < limit) { + tup[index_val] = tp[2]; + } else { + goto error; + } + } + if (is_not_nil(list)) { + goto error; + } + BIF_RET(res); +} + + +/**********************************************************************/ + +BIF_RETTYPE append_element_2(BIF_ALIST_2) +{ + Eterm* ptr; + Eterm* hp; + Uint arity; + Eterm res; + + if (is_not_tuple(BIF_ARG_1)) { + BIF_ERROR(BIF_P, BADARG); + } + ptr = tuple_val(BIF_ARG_1); + arity = arityval(*ptr); + hp = HAlloc(BIF_P, arity + 2); + res = make_tuple(hp); + *hp = make_arityval(arity+1); + while (arity--) { + *++hp = *++ptr; + } + *++hp = BIF_ARG_2; + BIF_RET(res); +} + +/**********************************************************************/ + +/* convert an atom to a list of ascii integer */ + +BIF_RETTYPE atom_to_list_1(BIF_ALIST_1) +{ + Uint need; + Eterm* hp; + Atom* ap; + + if (is_not_atom(BIF_ARG_1)) + BIF_ERROR(BIF_P, BADARG); + + /* read data from atom table */ + ap = atom_tab(atom_val(BIF_ARG_1)); + if (ap->len == 0) + BIF_RET(NIL); /* the empty atom */ + need = ap->len*2; + hp = HAlloc(BIF_P, need); + BIF_RET(buf_to_intlist(&hp,(char*)ap->name,ap->len, NIL)); +} + +/**********************************************************************/ + +/* convert a list of ascii integers to an atom */ + +BIF_RETTYPE list_to_atom_1(BIF_ALIST_1) +{ + Eterm res; + char *buf = (char *) erts_alloc(ERTS_ALC_T_TMP, MAX_ATOM_LENGTH); + int i = intlist_to_buf(BIF_ARG_1, buf, MAX_ATOM_LENGTH); + + if (i < 0) { + erts_free(ERTS_ALC_T_TMP, (void *) buf); + i = list_length(BIF_ARG_1); + if (i > MAX_ATOM_LENGTH) { + BIF_ERROR(BIF_P, SYSTEM_LIMIT); + } + BIF_ERROR(BIF_P, BADARG); + } + res = am_atom_put(buf, i); + erts_free(ERTS_ALC_T_TMP, (void *) buf); + BIF_RET(res); +} + +/* conditionally convert a list of ascii integers to an atom */ + +BIF_RETTYPE list_to_existing_atom_1(BIF_ALIST_1) +{ + int i; + char *buf = (char *) erts_alloc(ERTS_ALC_T_TMP, MAX_ATOM_LENGTH); + + if ((i = intlist_to_buf(BIF_ARG_1, buf, MAX_ATOM_LENGTH)) < 0) { + error: + erts_free(ERTS_ALC_T_TMP, (void *) buf); + BIF_ERROR(BIF_P, BADARG); + } else { + Eterm a; + + if (erts_atom_get(buf, i, &a)) { + erts_free(ERTS_ALC_T_TMP, (void *) buf); + BIF_RET(a); + } else { + goto error; + } + } +} + + +/**********************************************************************/ + +/* convert an integer to a list of ascii integers */ + +BIF_RETTYPE integer_to_list_1(BIF_ALIST_1) +{ + Eterm* hp; + Uint need; + + if (is_not_integer(BIF_ARG_1)) { + BIF_ERROR(BIF_P, BADARG); + } + + if (is_small(BIF_ARG_1)) { + char *c; + int n; + struct Sint_buf ibuf; + + c = Sint_to_buf(signed_val(BIF_ARG_1), &ibuf); + n = sys_strlen(c); + need = 2*n; + hp = HAlloc(BIF_P, need); + BIF_RET(buf_to_intlist(&hp, c, n, NIL)); + } + else { + int n = big_decimal_estimate(BIF_ARG_1); + Eterm res; + Eterm* hp_end; + + need = 2*n; + hp = HAlloc(BIF_P, need); + hp_end = hp + need; + res = erts_big_to_list(BIF_ARG_1, &hp); + HRelease(BIF_P,hp_end,hp); + BIF_RET(res); + } +} + +/**********************************************************************/ + +/* convert a list of ascii ascii integer value to an integer */ + + +#define LTI_BAD_STRUCTURE 0 +#define LTI_NO_INTEGER 1 +#define LTI_SOME_INTEGER 2 +#define LTI_ALL_INTEGER 3 + +static int do_list_to_integer(Process *p, Eterm orig_list, + Eterm *integer, Eterm *rest) +{ + Sint i = 0; + int skip = 0; + int neg = 0; + int n = 0; + int m; + int lg2; + Eterm res; + Eterm* hp; + Eterm *hp_end; + Eterm lst = orig_list; + Eterm tail = lst; + int error_res = LTI_BAD_STRUCTURE; + + if (is_nil(lst)) { + error_res = LTI_NO_INTEGER; + error: + *rest = tail; + *integer = make_small(0); + return error_res; + } + if (is_not_list(lst)) + goto error; + + /* if first char is a '-' then it is a negative integer */ + if (CAR(list_val(lst)) == make_small('-')) { + neg = 1; + skip = 1; + lst = CDR(list_val(lst)); + if (is_not_list(lst)) { + tail = lst; + error_res = LTI_NO_INTEGER; + goto error; + } + } else if (CAR(list_val(lst)) == make_small('+')) { + /* ignore plus */ + skip = 1; + lst = CDR(list_val(lst)); + if (is_not_list(lst)) { + tail = lst; + error_res = LTI_NO_INTEGER; + goto error; + } + } + + /* Calculate size and do type check */ + + while(1) { + if (is_not_small(CAR(list_val(lst)))) { + break; + } + if (unsigned_val(CAR(list_val(lst))) < '0' || + unsigned_val(CAR(list_val(lst))) > '9') { + break; + } + i = i * 10; + i = i + unsigned_val(CAR(list_val(lst))) - '0'; + n++; + lst = CDR(list_val(lst)); + if (is_nil(lst)) { + break; + } + if (is_not_list(lst)) { + break; + } + } + + tail = lst; + if (!n) { + error_res = LTI_NO_INTEGER; + goto error; + } + + + /* If n <= 8 then we know it's a small int + ** since 2^27 = 134217728. If n > 8 then we must + ** construct a bignum and let that routine do the checking + */ + + if (n <= SMALL_DIGITS) { /* It must be small */ + if (neg) i = -i; + res = make_small(i); + } else { + lg2 = (n+1)*230/69+1; + m = (lg2+D_EXP-1)/D_EXP; /* number of digits */ + m = BIG_NEED_SIZE(m); /* number of words + thing */ + + hp = HAlloc(p, m); + hp_end = hp + m; + + lst = orig_list; + if (skip) + lst = CDR(list_val(lst)); + + /* load first digits (at least one digit) */ + if ((i = (n % D_DECIMAL_EXP)) == 0) + i = D_DECIMAL_EXP; + n -= i; + m = 0; + while(i--) { + m = 10*m + (unsigned_val(CAR(list_val(lst))) - '0'); + lst = CDR(list_val(lst)); + } + res = small_to_big(m, hp); /* load first digits */ + + while(n) { + i = D_DECIMAL_EXP; + n -= D_DECIMAL_EXP; + m = 0; + while(i--) { + m = 10*m + (unsigned_val(CAR(list_val(lst))) - '0'); + lst = CDR(list_val(lst)); + } + if (is_small(res)) + res = small_to_big(signed_val(res), hp); + res = big_times_small(res, D_DECIMAL_BASE, hp); + if (is_small(res)) + res = small_to_big(signed_val(res), hp); + res = big_plus_small(res, m, hp); + } + + if (is_big(res)) /* check if small */ + res = big_plus_small(res, 0, hp); /* includes conversion to small */ + + if (neg) { + if (is_small(res)) + res = make_small(-signed_val(res)); + else { + Uint *big = big_val(res); /* point to thing */ + *big = bignum_header_neg(*big); + } + } + + if (is_big(res)) { + hp += (big_arity(res)+1); + } + HRelease(p,hp_end,hp); + } + *integer = res; + *rest = tail; + if (tail != NIL) { + return LTI_SOME_INTEGER; + } + return LTI_ALL_INTEGER; +} +BIF_RETTYPE string_to_integer_1(BIF_ALIST_1) +{ + Eterm res; + Eterm tail; + Eterm *hp; + /* must be a list */ + switch (do_list_to_integer(BIF_P,BIF_ARG_1,&res,&tail)) { + /* HAlloc after do_list_to_integer as it + might HAlloc itself (bignum) */ + case LTI_BAD_STRUCTURE: + hp = HAlloc(BIF_P,3); + BIF_RET(TUPLE2(hp, am_error, am_not_a_list)); + case LTI_NO_INTEGER: + hp = HAlloc(BIF_P,3); + BIF_RET(TUPLE2(hp, am_error, am_no_integer)); + default: + hp = HAlloc(BIF_P,3); + BIF_RET(TUPLE2(hp, res, tail)); + } +} + + +BIF_RETTYPE list_to_integer_1(BIF_ALIST_1) +{ + Eterm res; + Eterm dummy; + /* must be a list */ + + if (do_list_to_integer(BIF_P,BIF_ARG_1,&res,&dummy) != LTI_ALL_INTEGER) { + BIF_ERROR(BIF_P,BADARG); + } + BIF_RET(res); + } + +/**********************************************************************/ + +/* convert a float to a list of ascii characters */ + +BIF_RETTYPE float_to_list_1(BIF_ALIST_1) +{ + int i; + Uint need; + Eterm* hp; + FloatDef f; + char fbuf[30]; + + /* check the arguments */ + if (is_not_float(BIF_ARG_1)) + BIF_ERROR(BIF_P, BADARG); + GET_DOUBLE(BIF_ARG_1, f); + if ((i = sys_double_to_chars(f.fd, fbuf)) <= 0) + BIF_ERROR(BIF_P, EXC_INTERNAL_ERROR); + need = i*2; + hp = HAlloc(BIF_P, need); + BIF_RET(buf_to_intlist(&hp, fbuf, i, NIL)); + } + +/**********************************************************************/ + +/* convert a list of ascii integer values e's +'s and -'s to a float */ + + +#define SIGN 0 +#define INT 1 +#define FRAC 2 +#define EXP_SIGN 3 +#define EXP0 4 +#define EXP1 5 +#define END 6 + +#define IS_DOT(x) (unsigned_val((x)) == '.' || unsigned_val((x)) == ',') +#define IS_E(x) (unsigned_val((x)) == 'e' || unsigned_val((x)) == 'E') +#define IS_DIGIT(x) (unsigned_val((x)) >= '0' && unsigned_val((x)) <= '9') +#define SAVE_E(xi,xim,xl,xlm) ((xim)=(xi), (xlm)=(xl)) +#define LOAD_E(xi,xim,xl,xlm) ((xi)=(xim), (xl)=(xlm)) + +#define STRING_TO_FLOAT_BUF_INC_SZ (128) +BIF_RETTYPE string_to_float_1(BIF_ALIST_1) +{ + Eterm orig = BIF_ARG_1; + Eterm list = orig; + Eterm list_mem = list; + int i = 0; + int i_mem = 0; + Eterm* hp; + Eterm error_res = NIL; + int part = SIGN; /* expect a + or - (or a digit) first */ + FloatDef f; + Eterm tup; + byte *buf = NULL; + Uint bufsz = STRING_TO_FLOAT_BUF_INC_SZ; + + /* check it's a valid list to start with */ + if (is_nil(list)) { + error_res = am_no_float; + error: + if (buf) + erts_free(ERTS_ALC_T_TMP, (void *) buf); + hp = HAlloc(BIF_P, 3); + BIF_RET(TUPLE2(hp, am_error, error_res)); + } + if (is_not_list(list)) { + error_res = am_not_a_list; + goto error; + } + + buf = (byte *) erts_alloc(ERTS_ALC_T_TMP, bufsz); + + /* + The float might start with a SIGN (+ | -). It must contain an integer + part, INT, followed by a delimiter (. | ,) and a fractional, FRAC, + part. The float might also contain an exponent. If e or E indicates + this we will look for a possible EXP_SIGN (+ | -) followed by the + exponential number, EXP. (EXP0 is the first digit and EXP1 the rest). + + When we encounter an expected e or E, we can't tell if it's part of + the float or the rest of the string. We save the current position + with SAVE_E. If we later find out it was not part of the float, we + restore the position (end of the float) with LOAD_E. + */ + while(1) { + if (is_not_small(CAR(list_val(list)))) + goto back_to_e; + if (CAR(list_val(list)) == make_small('-')) { + switch (part) { + case SIGN: /* expect integer part next */ + part = INT; + break; + case EXP_SIGN: /* expect first digit in exp */ + part = EXP0; + break; + case EXP0: /* example: "2.3e--" */ + LOAD_E(i, i_mem, list, list_mem); + default: /* unexpected - done */ + part = END; + } + } else if (CAR(list_val(list)) == make_small('+')) { + switch (part) { + case SIGN: /* expect integer part next */ + part = INT; + goto skip; + case EXP_SIGN: /* expect first digit in exp */ + part = EXP0; + break; + case EXP0: /* example: "2.3e++" */ + LOAD_E(i, i_mem, list, list_mem); + default: /* unexpected - done */ + part = END; + } + } else if (IS_DOT(CAR(list_val(list)))) { /* . or , */ + switch (part) { + case INT: /* expect fractional part next */ + part = FRAC; + break; + case EXP_SIGN: /* example: "2.3e." */ + LOAD_E(i, i_mem, list, list_mem); + case EXP0: /* example: "2.3e+." */ + LOAD_E(i, i_mem, list, list_mem); + default: /* unexpected - done */ + part = END; + } + } else if (IS_E(CAR(list_val(list)))) { /* e or E */ + switch (part) { + case FRAC: /* expect a + or - (or a digit) next */ + /* + remember the position of e in case we find out later + that it was not part of the float, e.g. "2.3eh?" + */ + SAVE_E(i, i_mem, list, list_mem); + part = EXP_SIGN; + break; + case EXP0: /* example: "2.3e+e" */ + case EXP_SIGN: /* example: "2.3ee" */ + LOAD_E(i, i_mem, list, list_mem); + case INT: /* would like this to be ok, example "2e2", + but it's not compatible with list_to_float */ + default: /* unexpected - done */ + part = END; + } + } else if (IS_DIGIT(CAR(list_val(list)))) { /* digit */ + switch (part) { + case SIGN: /* got initial digit in integer part */ + part = INT; /* expect more digits to follow */ + break; + case EXP_SIGN: /* expect exponential part */ + case EXP0: /* expect rest of exponential */ + part = EXP1; + break; + } + } else /* character not part of float - done */ + goto back_to_e; + + if (part == END) { + if (i < 3) { /* we require a fractional part */ + error_res = am_no_float; + goto error; + } + break; + } + + buf[i++] = unsigned_val(CAR(list_val(list))); + + if (i == bufsz - 1) + buf = (byte *) erts_realloc(ERTS_ALC_T_TMP, + (void *) buf, + bufsz += STRING_TO_FLOAT_BUF_INC_SZ); + skip: + list = CDR(list_val(list)); /* next element */ + + if (is_nil(list)) + goto back_to_e; + + if (is_not_list(list)) { + back_to_e: + if (part == EXP_SIGN || part == EXP0) { + LOAD_E(i, i_mem, list, list_mem); + } + break; + } + } + + if (i == 0) { /* no float first in list */ + error_res = am_no_float; + goto error; + } + + buf[i] = '\0'; /* null terminal */ + ASSERT(bufsz >= i + 1); + if (sys_chars_to_double((char*) buf, &f.fd) != 0) { + error_res = am_no_float; + goto error; + } + hp = HAlloc(BIF_P, FLOAT_SIZE_OBJECT + 3); + tup = TUPLE2(hp+FLOAT_SIZE_OBJECT, make_float(hp), list); + PUT_DOUBLE(f, hp); + erts_free(ERTS_ALC_T_TMP, (void *) buf); + BIF_RET(tup); +} + + +BIF_RETTYPE list_to_float_1(BIF_ALIST_1) +{ + int i; + FloatDef f; + Eterm res; + Eterm* hp; + char *buf = NULL; + + i = list_length(BIF_ARG_1); + if (i < 0) { + badarg: + if (buf) + erts_free(ERTS_ALC_T_TMP, (void *) buf); + BIF_ERROR(BIF_P, BADARG); + } + + buf = (char *) erts_alloc(ERTS_ALC_T_TMP, i + 1); + + if (intlist_to_buf(BIF_ARG_1, buf, i) < 0) + goto badarg; + buf[i] = '\0'; /* null terminal */ + + if (sys_chars_to_double(buf, &f.fd) != 0) + goto badarg; + hp = HAlloc(BIF_P, FLOAT_SIZE_OBJECT); + res = make_float(hp); + PUT_DOUBLE(f, hp); + erts_free(ERTS_ALC_T_TMP, (void *) buf); + BIF_RET(res); +} + +/**********************************************************************/ + +/* convert a tuple to a list */ + +BIF_RETTYPE tuple_to_list_1(BIF_ALIST_1) +{ + Uint n; + Eterm *tupleptr; + Eterm list = NIL; + Eterm* hp; + + if (is_not_tuple(BIF_ARG_1)) { + BIF_ERROR(BIF_P, BADARG); + } + + tupleptr = tuple_val(BIF_ARG_1); + n = arityval(*tupleptr); + hp = HAlloc(BIF_P, 2 * n); + tupleptr++; + + while(n--) { + list = CONS(hp, tupleptr[n], list); + hp += 2; + } + BIF_RET(list); +} + +/**********************************************************************/ + +/* convert a list to a tuple */ + +BIF_RETTYPE list_to_tuple_1(BIF_ALIST_1) +{ + Eterm list = BIF_ARG_1; + Eterm* cons; + Eterm res; + Eterm* hp; + int len; + + if ((len = list_length(list)) < 0) { + BIF_ERROR(BIF_P, BADARG); + } + + hp = HAlloc(BIF_P, len+1); + res = make_tuple(hp); + *hp++ = make_arityval(len); + while(is_list(list)) { + cons = list_val(list); + *hp++ = CAR(cons); + list = CDR(cons); + } + BIF_RET(res); +} + +/**********************************************************************/ + +/* return the pid of our own process, in most cases this has been replaced by + a machine instruction */ + +BIF_RETTYPE self_0(BIF_ALIST_0) +{ + BIF_RET(BIF_P->id); +} + +/**********************************************************************/ + +/* + New representation of refs in R9, see erl_term.h + + In the first data word, only the usual 18 bits are used. Ordinarily, + in "long refs" all words are used (in other words, practically never + wrap around), but for compatibility with older nodes, "short refs" + exist. Short refs come into being by being converted from the old + external format for refs (tag REFERENCE_EXT). Short refs are + converted back to the old external format. + + When converting a long ref to the external format in the case of + preparing for sending to an older node, the ref is truncated by only + using the first word (with 18 significant bits), and using the old tag + REFERENCE_EXT. + + When comparing refs or different size, only the parts up to the length + of the shorter operand are used. This has the desirable effect that a + long ref sent to an old node and back will be treated as equal to + the original, although some of the bits have been lost. + + The hash value for a ref always considers only the first word, since + in the above scenario, the original and the copy should have the same + hash value. +*/ + +static Uint32 reference0; /* Initialized in erts_init_bif */ +static Uint32 reference1; +static Uint32 reference2; +static erts_smp_spinlock_t make_ref_lock; +static erts_smp_mtx_t ports_snapshot_mtx; +erts_smp_atomic_t erts_dead_ports_ptr; /* To store dying ports during snapshot */ + +Eterm erts_make_ref_in_buffer(Eterm buffer[REF_THING_SIZE]) +{ + Eterm* hp = buffer; + Uint32 ref0, ref1, ref2; + + erts_smp_spin_lock(&make_ref_lock); + + reference0++; + if (reference0 >= MAX_REFERENCE) { + reference0 = 0; + reference1++; + if (reference1 == 0) { + reference2++; + } + } + + ref0 = reference0; + ref1 = reference1; + ref2 = reference2; + + erts_smp_spin_unlock(&make_ref_lock); + + write_ref_thing(hp, ref0, ref1, ref2); + return make_internal_ref(hp); +} + +Eterm erts_make_ref(Process *p) +{ + Eterm* hp; + + ERTS_SMP_LC_ASSERT(ERTS_PROC_LOCK_MAIN & erts_proc_lc_my_proc_locks(p)); + + hp = HAlloc(p, REF_THING_SIZE); + return erts_make_ref_in_buffer(hp); +} + +BIF_RETTYPE make_ref_0(BIF_ALIST_0) +{ + return erts_make_ref(BIF_P); +} + +/**********************************************************************/ + +/* return the time of day */ + +BIF_RETTYPE time_0(BIF_ALIST_0) +{ + int hour, minute, second; + Eterm* hp; + + get_time(&hour, &minute, &second); + hp = HAlloc(BIF_P, 4); /* {hour, minute, second} + arity */ + BIF_RET(TUPLE3(hp, make_small(hour), make_small(minute), + make_small(second))); +} +/**********************************************************************/ + +/* return the date */ + +BIF_RETTYPE date_0(BIF_ALIST_0) +{ + int year, month, day; + Eterm* hp; + + get_date(&year, &month, &day); + hp = HAlloc(BIF_P, 4); /* {year, month, day} + arity */ + BIF_RET(TUPLE3(hp, make_small(year), make_small(month), make_small(day))); +} + +/**********************************************************************/ + +/* return the universal time */ + +BIF_RETTYPE universaltime_0(BIF_ALIST_0) +{ + int year, month, day; + int hour, minute, second; + Eterm res1, res2; + Eterm* hp; + + /* read the clock */ + get_universaltime(&year, &month, &day, &hour, &minute, &second); + + hp = HAlloc(BIF_P, 4+4+3); + + /* and return the tuple */ + res1 = TUPLE3(hp,make_small(year),make_small(month),make_small(day)); + hp += 4; + res2 = TUPLE3(hp,make_small(hour),make_small(minute),make_small(second)); + hp += 4; + BIF_RET(TUPLE2(hp, res1, res2)); + } + +/**********************************************************************/ + +/* return the universal time */ + +BIF_RETTYPE localtime_0(BIF_ALIST_0) +{ + int year, month, day; + int hour, minute, second; + Eterm res1, res2; + Eterm* hp; + + /* read the clock */ + get_localtime(&year, &month, &day, &hour, &minute, &second); + + hp = HAlloc(BIF_P, 4+4+3); + + /* and return the tuple */ + res1 = TUPLE3(hp,make_small(year),make_small(month),make_small(day)); + hp += 4; + res2 = TUPLE3(hp,make_small(hour),make_small(minute),make_small(second)); + hp += 4; + BIF_RET(TUPLE2(hp, res1, res2)); +} +/**********************************************************************/ + +/* type check and extract components from a tuple on form: {{Y,M,D},{H,M,S}} */ +static int +time_to_parts(Eterm date, Sint* year, Sint* month, Sint* day, + Sint* hour, Sint* minute, Sint* second) +{ + Eterm* t1; + Eterm* t2; + + if (is_not_tuple(date)) { + return 0; + } + t1 = tuple_val(date); + if (arityval(t1[0]) !=2 || + is_not_tuple(t1[1]) || is_not_tuple(t1[2])) + return 0; + t2 = tuple_val(t1[1]); + t1 = tuple_val(t1[2]); + if (arityval(t2[0]) != 3 || + is_not_small(t2[1]) || is_not_small(t2[2]) || is_not_small(t2[3])) + return 0; + *year = signed_val(t2[1]); + *month = signed_val(t2[2]); + *day = signed_val(t2[3]); + if (arityval(t1[0]) != 3 || + is_not_small(t1[1]) || is_not_small(t1[2]) || is_not_small(t1[3])) + return 0; + *hour = signed_val(t1[1]); + *minute = signed_val(t1[2]); + *second = signed_val(t1[3]); + return 1; +} + + +/* return the universal time */ + +BIF_RETTYPE +localtime_to_universaltime_2(Process *p, Eterm localtime, Eterm dst) +{ + Sint year, month, day; + Sint hour, minute, second; + int isdst; + Eterm res1, res2; + Eterm* hp; + + if (dst == am_true) isdst = 1; + else if (dst == am_false) isdst = 0; + else if (dst == am_undefined) isdst = -1; + else goto error; + + if (!time_to_parts(localtime, &year, &month, &day, + &hour, &minute, &second)) goto error; + if (!local_to_univ(&year, &month, &day, + &hour, &minute, &second, isdst)) goto error; + + hp = HAlloc(p, 4+4+3); + res1 = TUPLE3(hp,make_small(year),make_small(month), + make_small(day)); + hp += 4; + res2 = TUPLE3(hp,make_small(hour),make_small(minute), + make_small(second)); + hp += 4; + BIF_RET(TUPLE2(hp, res1, res2)); + error: + BIF_ERROR(p, BADARG); + } + + +/**********************************************************************/ + +/* return the universal time */ + +BIF_RETTYPE universaltime_to_localtime_1(BIF_ALIST_1) +{ + Sint year, month, day; + Sint hour, minute, second; + Eterm res1, res2; + Eterm* hp; + + if (!time_to_parts(BIF_ARG_1, &year, &month, &day, + &hour, &minute, &second)) + BIF_ERROR(BIF_P, BADARG); + if (!univ_to_local(&year, &month, &day, + &hour, &minute, &second)) + BIF_ERROR(BIF_P, BADARG); + + hp = HAlloc(BIF_P, 4+4+3); + res1 = TUPLE3(hp,make_small(year),make_small(month), + make_small(day)); + hp += 4; + res2 = TUPLE3(hp,make_small(hour),make_small(minute), + make_small(second)); + hp += 4; + BIF_RET(TUPLE2(hp, res1, res2)); +} + +/**********************************************************************/ + + + /* return a timestamp */ +BIF_RETTYPE now_0(BIF_ALIST_0) +{ + Uint megasec, sec, microsec; + Eterm* hp; + + get_now(&megasec, &sec, µsec); + hp = HAlloc(BIF_P, 4); + BIF_RET(TUPLE3(hp, make_small(megasec), make_small(sec), + make_small(microsec))); +} + +/**********************************************************************/ + +BIF_RETTYPE garbage_collect_1(BIF_ALIST_1) +{ + int reds; + Process *rp; + + if (is_not_pid(BIF_ARG_1)) { + BIF_ERROR(BIF_P, BADARG); + } + + rp = erts_pid2proc_not_running(BIF_P, ERTS_PROC_LOCK_MAIN, + BIF_ARG_1, ERTS_PROC_LOCK_MAIN); + if (!rp) + BIF_RET(am_false); + if (rp == ERTS_PROC_LOCK_BUSY) + ERTS_BIF_YIELD1(bif_export[BIF_garbage_collect_1], BIF_P, BIF_ARG_1); + + /* The GC cost is taken for the process executing this BIF. */ + + FLAGS(rp) |= F_NEED_FULLSWEEP; + reds = erts_garbage_collect(rp, 0, rp->arg_reg, rp->arity); + + if (BIF_P != rp) + erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_MAIN); + + BIF_RET2(am_true, reds); +} + +BIF_RETTYPE garbage_collect_0(BIF_ALIST_0) +{ + int reds; + + FLAGS(BIF_P) |= F_NEED_FULLSWEEP; + reds = erts_garbage_collect(BIF_P, 0, NULL, 0); + BIF_RET2(am_true, reds); +} + +/**********************************************************************/ +/* Perform garbage collection of the message area */ + +BIF_RETTYPE garbage_collect_message_area_0(BIF_ALIST_0) +{ +#if defined(HYBRID) && !defined(INCREMENTAL) + int reds = 0; + + FLAGS(BIF_P) |= F_NEED_FULLSWEEP; + reds = erts_global_garbage_collect(BIF_P, 0, NULL, 0); + BIF_RET2(am_true, reds); +#else + BIF_RET(am_false); +#endif +} + +/**********************************************************************/ +/* Return a list of active ports */ + +BIF_RETTYPE ports_0(BIF_ALIST_0) +{ + Eterm res = NIL; + Eterm* port_buf = erts_alloc(ERTS_ALC_T_TMP, + sizeof(Eterm)*erts_max_ports); + Eterm* pp = port_buf; + Eterm* dead_ports; + int alive, dead; + Uint32 next_ss; + + /* To get a consistent snapshot... + * We add alive ports from start of the buffer + * while dying ports are added from the other end by the killing threads. + */ + + erts_smp_mtx_lock(&ports_snapshot_mtx); /* One snapshot at a time */ + + erts_smp_atomic_set(&erts_dead_ports_ptr, (long) (port_buf + erts_max_ports)); + + next_ss = erts_smp_atomic_inctest(&erts_ports_snapshot); + + if (erts_smp_atomic_read(&erts_ports_alive) > 0) { + long i; + for (i = erts_max_ports-1; i >= 0; i--) { + Port* prt = &erts_port[i]; + erts_smp_port_state_lock(prt); + if (!(prt->status & ERTS_PORT_SFLGS_DEAD) + && prt->snapshot != next_ss) { + ASSERT(prt->snapshot == next_ss - 1); + *pp++ = prt->id; + prt->snapshot = next_ss; /* Consumed by this snapshot */ + } + erts_smp_port_state_unlock(prt); + } + } + + dead_ports = (Eterm*)erts_smp_atomic_xchg(&erts_dead_ports_ptr, + (long)NULL); + erts_smp_mtx_unlock(&ports_snapshot_mtx); + + ASSERT(pp <= dead_ports); + + alive = pp - port_buf; + dead = port_buf + erts_max_ports - dead_ports; + + ASSERT((alive+dead) <= erts_max_ports); + + if (alive+dead > 0) { + long i; + Eterm *hp = HAlloc(BIF_P, (alive+dead)*2); + + for (i = 0; i < alive; i++) { + res = CONS(hp, port_buf[i], res); + hp += 2; + } + for (i = 0; i < dead; i++) { + res = CONS(hp, dead_ports[i], res); + hp += 2; + } + } + + erts_free(ERTS_ALC_T_TMP, port_buf); + + BIF_RET(res); +} + +/**********************************************************************/ + +BIF_RETTYPE throw_1(BIF_ALIST_1) +{ + BIF_P->fvalue = BIF_ARG_1; + BIF_ERROR(BIF_P, EXC_THROWN); +} + +/**********************************************************************/ + + +/* + * Non-standard, undocumented, dirty BIF, meant for debugging. + * + */ +BIF_RETTYPE display_1(BIF_ALIST_1) +{ + erts_printf("%.*T\n", INT_MAX, BIF_ARG_1); + BIF_RET(am_true); +} + +/* + * erts_debug:display/1 is for debugging erlang:display/1 + */ +BIF_RETTYPE erts_debug_display_1(BIF_ALIST_1) +{ + int pres; + Eterm res; + Eterm *hp; + erts_dsprintf_buf_t *dsbufp = erts_create_tmp_dsbuf(64); + pres = erts_dsprintf(dsbufp, "%.*T\n", INT_MAX, BIF_ARG_1); + if (pres < 0) + erl_exit(1, "Failed to convert term to string: %d (s)\n", + -pres, erl_errno_id(-pres)); + hp = HAlloc(BIF_P, 2*dsbufp->str_len); /* we need length * 2 heap words */ + res = buf_to_intlist(&hp, dsbufp->str, dsbufp->str_len, NIL); + erts_printf("%s", dsbufp->str); + erts_destroy_tmp_dsbuf(dsbufp); + BIF_RET(res); +} + + +Eterm +display_string_1(Process* p, Eterm string) +{ + int len = is_string(string); + char *str; + + if (len <= 0) { + BIF_ERROR(p, BADARG); + } + str = (char *) erts_alloc(ERTS_ALC_T_TMP, sizeof(char)*(len + 1)); + if (intlist_to_buf(string, str, len) != len) + erl_exit(1, "%s:%d: Internal error\n", __FILE__, __LINE__); + str[len] = '\0'; + erts_fprintf(stderr, "%s", str); + erts_free(ERTS_ALC_T_TMP, (void *) str); + BIF_RET(am_true); +} + +Eterm +display_nl_0(Process* p) +{ + erts_fprintf(stderr, "\n"); + BIF_RET(am_true); +} + +/**********************************************************************/ + +/* stop the system */ +/* ARGSUSED */ +BIF_RETTYPE halt_0(BIF_ALIST_0) +{ + VERBOSE(DEBUG_SYSTEM,("System halted by BIF halt/0\n")); + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN); + erl_exit(0, ""); + return NIL; /* Pedantic (lint does not know about erl_exit) */ +} + +/**********************************************************************/ + +#define MSG_SIZE 200 + +/* stop the system with exit code */ +/* ARGSUSED */ +BIF_RETTYPE halt_1(BIF_ALIST_1) +{ + Sint code; + static char msg[MSG_SIZE]; + int i; + + if (is_small(BIF_ARG_1) && (code = signed_val(BIF_ARG_1)) >= 0) { + VERBOSE(DEBUG_SYSTEM,("System halted by BIF halt(%d)\n", code)); + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN); + erl_exit(-code, ""); + } else if (is_string(BIF_ARG_1) || BIF_ARG_1 == NIL) { + if ((i = intlist_to_buf(BIF_ARG_1, msg, MSG_SIZE-1)) < 0) { + goto error; + } + msg[i] = '\0'; + VERBOSE(DEBUG_SYSTEM,("System halted by BIF halt(%s)\n", msg)); + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN); + erl_exit(ERTS_DUMP_EXIT, "%s\n", msg); + } else { + error: + BIF_ERROR(BIF_P, BADARG); + } + return NIL; /* Pedantic (lint does not know about erl_exit) */ +} + +BIF_RETTYPE function_exported_3(BIF_ALIST_3) +{ + if (is_not_atom(BIF_ARG_1) || + is_not_atom(BIF_ARG_2) || + is_not_small(BIF_ARG_3)) { + BIF_ERROR(BIF_P, BADARG); + } + if (erts_find_function(BIF_ARG_1, BIF_ARG_2, signed_val(BIF_ARG_3)) == NULL) { + BIF_RET(am_false); + } + BIF_RET(am_true); +} + +/**********************************************************************/ + +BIF_RETTYPE is_builtin_3(Process* p, Eterm Mod, Eterm Name, Eterm Arity) +{ + if (is_not_atom(Mod) || is_not_atom(Name) || is_not_small(Arity)) { + BIF_ERROR(p, BADARG); + } + BIF_RET(erts_is_builtin(Mod, Name, signed_val(Arity)) ? + am_true : am_false); +} + +/**********************************************************************/ + +/* NOTE: Cannot be used in all *_to_list() bifs. erts_dsprintf() prints + * some terms on other formats than what is desired as results + * from *_to_list() bifs. + */ + +static Eterm +term2list_dsprintf(Process *p, Eterm term) +{ + int pres; + Eterm res; + Eterm *hp; + erts_dsprintf_buf_t *dsbufp = erts_create_tmp_dsbuf(64); + pres = erts_dsprintf(dsbufp, "%T", term); + if (pres < 0) + erl_exit(1, "Failed to convert term to list: %d (s)\n", + -pres, erl_errno_id(-pres)); + hp = HAlloc(p, 2*dsbufp->str_len); /* we need length * 2 heap words */ + res = buf_to_intlist(&hp, dsbufp->str, dsbufp->str_len, NIL); + erts_destroy_tmp_dsbuf(dsbufp); + return res; +} + +BIF_RETTYPE ref_to_list_1(BIF_ALIST_1) +{ + if (is_not_ref(BIF_ARG_1)) + BIF_ERROR(BIF_P, BADARG); + BIF_RET(term2list_dsprintf(BIF_P, BIF_ARG_1)); +} + +BIF_RETTYPE make_fun_3(BIF_ALIST_3) +{ + Eterm* hp; + Sint arity; + + if (is_not_atom(BIF_ARG_1) || is_not_atom(BIF_ARG_2) || is_not_small(BIF_ARG_3)) { + error: + BIF_ERROR(BIF_P, BADARG); + } + arity = signed_val(BIF_ARG_3); + if (arity < 0) { + goto error; + } + hp = HAlloc(BIF_P, 2); + hp[0] = HEADER_EXPORT; + hp[1] = (Eterm) erts_export_get_or_make_stub(BIF_ARG_1, BIF_ARG_2, (Uint) arity); + BIF_RET(make_export(hp)); +} + +Eterm +fun_to_list_1(Process* p, Eterm fun) +{ + if (is_not_any_fun(fun)) + BIF_ERROR(p, BADARG); + BIF_RET(term2list_dsprintf(p, fun)); +} + +/**********************************************************************/ + +/* convert a pid to an erlang list (for the linked cons cells) of the form + 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).externals; + etp->node = enp; + etp->data.ui[0] = make_pid_data(c, b); + + MSO(BIF_P).externals = etp; + erts_deref_dist_entry(dep); + BIF_RET(make_external_pid(etp)); + } + + bad: + if (dep) + erts_deref_dist_entry(dep); + if (buf) + erts_free(ERTS_ALC_T_TMP, (void *) buf); + BIF_ERROR(BIF_P, BADARG); +} + +/**********************************************************************/ + +BIF_RETTYPE group_leader_0(BIF_ALIST_0) +{ + BIF_RET(BIF_P->group_leader); +} + +/**********************************************************************/ +/* arg1 == leader, arg2 == new member */ + +BIF_RETTYPE group_leader_2(BIF_ALIST_2) +{ + Process* new_member; + + if (is_not_pid(BIF_ARG_1)) { + BIF_ERROR(BIF_P, BADARG); + } + + if (is_external_pid(BIF_ARG_2)) { + DistEntry *dep; + int code; + ErtsDSigData dsd; + dep = external_pid_dist_entry(BIF_ARG_2); + if(dep == erts_this_dist_entry) + BIF_ERROR(BIF_P, BADARG); + + code = erts_dsig_prepare(&dsd, dep, BIF_P, ERTS_DSP_NO_LOCK, 0); + switch (code) { + case ERTS_DSIG_PREP_NOT_ALIVE: + BIF_RET(am_true); + case ERTS_DSIG_PREP_NOT_CONNECTED: + BIF_TRAP2(dgroup_leader_trap, BIF_P, BIF_ARG_1, BIF_ARG_2); + case ERTS_DSIG_PREP_CONNECTED: + code = erts_dsig_send_group_leader(&dsd, BIF_ARG_1, BIF_ARG_2); + if (code == ERTS_DSIG_SEND_YIELD) + ERTS_BIF_YIELD_RETURN(BIF_P, am_true); + BIF_RET(am_true); + default: + ASSERT(! "Invalid dsig prepare result"); + BIF_ERROR(BIF_P, EXC_INTERNAL_ERROR); + } + } + else if (is_internal_pid(BIF_ARG_2)) { + int await_x; + ErtsProcLocks locks = ERTS_PROC_LOCK_MAIN|ERTS_PROC_LOCK_STATUS; + new_member = erts_pid2proc_nropt(BIF_P, ERTS_PROC_LOCK_MAIN, + BIF_ARG_2, locks); + if (!new_member) + BIF_ERROR(BIF_P, BADARG); + + if (new_member == ERTS_PROC_LOCK_BUSY) + ERTS_BIF_YIELD2(bif_export[BIF_group_leader_2], BIF_P, + BIF_ARG_1, BIF_ARG_2); + + await_x = (new_member != BIF_P + && ERTS_PROC_PENDING_EXIT(new_member)); + if (!await_x) { + if (is_immed(BIF_ARG_1)) + new_member->group_leader = BIF_ARG_1; + else { + locks &= ~ERTS_PROC_LOCK_STATUS; + erts_smp_proc_unlock(new_member, ERTS_PROC_LOCK_STATUS); + new_member->group_leader = STORE_NC_IN_PROC(new_member, + BIF_ARG_1); + } + } + + if (new_member == BIF_P) + locks &= ~ERTS_PROC_LOCK_MAIN; + if (locks) + erts_smp_proc_unlock(new_member, locks); + + if (await_x) { + /* Wait for new_member to terminate; then badarg */ + Eterm args[2] = {BIF_ARG_1, BIF_ARG_2}; + ERTS_BIF_AWAIT_X_APPLY_TRAP(BIF_P, + BIF_ARG_2, + am_erlang, + am_group_leader, + args, + 2); + } + + BIF_RET(am_true); + } + else { + BIF_ERROR(BIF_P, BADARG); + } +} + +BIF_RETTYPE system_flag_2(BIF_ALIST_2) +{ + Sint n; + + if (BIF_ARG_1 == am_multi_scheduling) { + if (BIF_ARG_2 == am_block || BIF_ARG_2 == am_unblock) { +#ifndef ERTS_SMP + BIF_RET(am_disabled); +#else + if (erts_no_schedulers == 1) + BIF_RET(am_disabled); + else { + switch (erts_block_multi_scheduling(BIF_P, + ERTS_PROC_LOCK_MAIN, + BIF_ARG_2 == am_block, + 0)) { + case ERTS_SCHDLR_SSPND_DONE_MSCHED_BLOCKED: + BIF_RET(am_blocked); + case ERTS_SCHDLR_SSPND_YIELD_DONE_MSCHED_BLOCKED: + ERTS_BIF_YIELD_RETURN_X(BIF_P, am_blocked, + am_multi_scheduling); + case ERTS_SCHDLR_SSPND_DONE: + BIF_RET(am_enabled); + case ERTS_SCHDLR_SSPND_YIELD_RESTART: + ERTS_VBUMP_ALL_REDS(BIF_P); + BIF_TRAP2(bif_export[BIF_system_flag_2], + BIF_P, BIF_ARG_1, BIF_ARG_2); + case ERTS_SCHDLR_SSPND_YIELD_DONE: + ERTS_BIF_YIELD_RETURN_X(BIF_P, am_enabled, + am_multi_scheduling); + case ERTS_SCHDLR_SSPND_EINVAL: + goto error; + default: + ASSERT(0); + BIF_ERROR(BIF_P, EXC_INTERNAL_ERROR); + break; + } + } +#endif + } + } else if (BIF_ARG_1 == am_schedulers_online) { +#ifndef ERTS_SMP + if (BIF_ARG_2 != make_small(1)) + goto error; + else + BIF_RET(make_small(1)); +#else + Sint old_no; + if (!is_small(BIF_ARG_2)) + goto error; + switch (erts_set_schedulers_online(BIF_P, + ERTS_PROC_LOCK_MAIN, + signed_val(BIF_ARG_2), + &old_no)) { + case ERTS_SCHDLR_SSPND_DONE: + BIF_RET(make_small(old_no)); + case ERTS_SCHDLR_SSPND_YIELD_RESTART: + ERTS_VBUMP_ALL_REDS(BIF_P); + BIF_TRAP2(bif_export[BIF_system_flag_2], + BIF_P, BIF_ARG_1, BIF_ARG_2); + case ERTS_SCHDLR_SSPND_YIELD_DONE: + ERTS_BIF_YIELD_RETURN_X(BIF_P, make_small(old_no), + am_schedulers_online); + case ERTS_SCHDLR_SSPND_EINVAL: + goto error; + default: + ASSERT(0); + BIF_ERROR(BIF_P, EXC_INTERNAL_ERROR); + break; + } +#endif + } else if (BIF_ARG_1 == am_fullsweep_after) { + Uint16 nval; + Uint oval; + if (!is_small(BIF_ARG_2) || (n = signed_val(BIF_ARG_2)) < 0) { + goto error; + } + nval = (n > (Sint) ((Uint16) -1)) ? ((Uint16) -1) : ((Uint16) n); + oval = (Uint) erts_smp_atomic_xchg(&erts_max_gen_gcs, (long) nval); + BIF_RET(make_small(oval)); + } else if (BIF_ARG_1 == am_min_heap_size) { + int oval = H_MIN_SIZE; + if (!is_small(BIF_ARG_2) || (n = signed_val(BIF_ARG_2)) < 0) { + goto error; + } + H_MIN_SIZE = erts_next_heap_size(n, 0); + BIF_RET(make_small(oval)); + } else if (BIF_ARG_1 == am_display_items) { + int oval = display_items; + if (!is_small(BIF_ARG_2) || (n = signed_val(BIF_ARG_2)) < 0) { + goto error; + } + display_items = n < 32 ? 32 : n; + BIF_RET(make_small(oval)); + } else if (BIF_ARG_1 == am_debug_flags) { + BIF_RET(am_true); + } else if (BIF_ARG_1 == am_backtrace_depth) { + int oval = erts_backtrace_depth; + if (!is_small(BIF_ARG_2) || (n = signed_val(BIF_ARG_2)) < 0) { + goto error; + } + if (n > MAX_BACKTRACE_SIZE) n = MAX_BACKTRACE_SIZE; + erts_backtrace_depth = n; + BIF_RET(make_small(oval)); + } else if (BIF_ARG_1 == am_trace_control_word) { + BIF_RET(db_set_trace_control_word_1(BIF_P, BIF_ARG_2)); + } else if (BIF_ARG_1 == am_sequential_tracer) { + Eterm old_value = erts_set_system_seq_tracer(BIF_P, + ERTS_PROC_LOCK_MAIN, + BIF_ARG_2); + if (old_value != THE_NON_VALUE) { + BIF_RET(old_value); + } + } else if (BIF_ARG_1 == make_small(1)) { + Uint i; + ErlMessage* mp; + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN); + erts_smp_block_system(0); + + for (i = 0; i < erts_max_processes; i++) { + if (process_tab[i] != (Process*) 0) { + Process* p = process_tab[i]; + p->seq_trace_token = NIL; + p->seq_trace_clock = 0; + p->seq_trace_lastcnt = 0; + ERTS_SMP_MSGQ_MV_INQ2PRIVQ(p); + mp = p->msg.first; + while(mp != NULL) { + ERL_MESSAGE_TOKEN(mp) = NIL; + mp = mp->next; + } + } + } + + erts_smp_release_system(); + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_MAIN); + + BIF_RET(am_true); + } else if (ERTS_IS_ATOM_STR("scheduling_statistics", BIF_ARG_1)) { + int what; + if (ERTS_IS_ATOM_STR("disable", BIF_ARG_2)) + what = ERTS_SCHED_STAT_MODIFY_DISABLE; + else if (ERTS_IS_ATOM_STR("enable", BIF_ARG_2)) + what = ERTS_SCHED_STAT_MODIFY_ENABLE; + else if (ERTS_IS_ATOM_STR("clear", BIF_ARG_2)) + what = ERTS_SCHED_STAT_MODIFY_CLEAR; + else + goto error; + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN); + erts_sched_stat_modify(what); + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_MAIN); + BIF_RET(am_true); + } else if (ERTS_IS_ATOM_STR("internal_cpu_topology", BIF_ARG_1)) { + Eterm res = erts_set_cpu_topology(BIF_P, BIF_ARG_2); + if (is_value(res)) + BIF_RET(res); + } else if (ERTS_IS_ATOM_STR("cpu_topology", BIF_ARG_1)) { + BIF_TRAP1(set_cpu_topology_trap, BIF_P, BIF_ARG_2); + } else if (ERTS_IS_ATOM_STR("scheduler_bind_type", BIF_ARG_1)) { + return erts_bind_schedulers(BIF_P, BIF_ARG_2); + } + error: + BIF_ERROR(BIF_P, BADARG); +} + +/**********************************************************************/ + +BIF_RETTYPE hash_2(BIF_ALIST_2) +{ + Uint32 hash; + Sint range; + + if (is_not_small(BIF_ARG_2)) { + BIF_ERROR(BIF_P, BADARG); + } + if ((range = signed_val(BIF_ARG_2)) <= 0) { /* [1..MAX_SMALL] */ + BIF_ERROR(BIF_P, BADARG); + } +#ifdef ARCH_64 + if (range > ((1L << 27) - 1)) + BIF_ERROR(BIF_P, BADARG); +#endif + hash = make_broken_hash(BIF_ARG_1); + BIF_RET(make_small(1 + (hash % range))); /* [1..range] */ +} + +BIF_RETTYPE phash_2(BIF_ALIST_2) +{ + Uint32 hash; + Uint32 final_hash; + Uint32 range; + + /* Check for special case 2^32 */ + if (term_equals_2pow32(BIF_ARG_2)) { + range = 0; + } else { + Uint u; + if (!term_to_Uint(BIF_ARG_2, &u) || ((u >> 16) >> 16) != 0 || !u) { + BIF_ERROR(BIF_P, BADARG); + } + range = (Uint32) u; + } + hash = make_hash(BIF_ARG_1); + if (range) { + final_hash = 1 + (hash % range); /* [1..range] */ + } else if ((final_hash = hash + 1) == 0) { + /* + * XXX In this case, there will still be a ArithAlloc() in erts_mixed_plus(). + */ + BIF_RET(erts_mixed_plus(BIF_P, + erts_make_integer(hash, BIF_P), + make_small(1))); + } + + BIF_RET(erts_make_integer(final_hash, BIF_P)); +} + +BIF_RETTYPE phash2_1(BIF_ALIST_1) +{ + Uint32 hash; + + hash = make_hash2(BIF_ARG_1); + BIF_RET(make_small(hash & ((1L << 27) - 1))); +} + +BIF_RETTYPE phash2_2(BIF_ALIST_2) +{ + Uint32 hash; + Uint32 final_hash; + Uint32 range; + + /* Check for special case 2^32 */ + if (term_equals_2pow32(BIF_ARG_2)) { + range = 0; + } else { + Uint u; + if (!term_to_Uint(BIF_ARG_2, &u) || ((u >> 16) >> 16) != 0 || !u) { + BIF_ERROR(BIF_P, BADARG); + } + range = (Uint32) u; + } + hash = make_hash2(BIF_ARG_1); + if (range) { + final_hash = hash % range; /* [0..range-1] */ + } else { + final_hash = hash; + } + /* + * Return either a small or a big. Use the heap for bigs if there is room. + */ +#ifdef ARCH_64 + BIF_RET(make_small(final_hash)); +#else + if (IS_USMALL(0, final_hash)) { + BIF_RET(make_small(final_hash)); + } else { + Eterm* hp = HAlloc(BIF_P, BIG_UINT_HEAP_SIZE); + BIF_RET(uint_to_big(final_hash, hp)); + } +#endif +} + +BIF_RETTYPE bump_reductions_1(BIF_ALIST_1) +{ + Sint reds; + + if (is_not_small(BIF_ARG_1) || ((reds = signed_val(BIF_ARG_1)) < 0)) { + BIF_ERROR(BIF_P, BADARG); + } + + if (reds > CONTEXT_REDS) { + reds = CONTEXT_REDS; + } + BIF_RET2(am_true, reds); +} + +/* + * Processes doing yield on return in a bif ends up in bif_return_trap(). + */ +static BIF_RETTYPE bif_return_trap( +#ifdef DEBUG + BIF_ALIST_2 +#else + BIF_ALIST_1 +#endif + ) +{ +#ifdef DEBUG + switch (BIF_ARG_2) { + case am_multi_scheduling: +#ifdef ERTS_SMP + erts_dbg_multi_scheduling_return_trap(BIF_P, BIF_ARG_1); +#endif + break; + case am_schedulers_online: + break; + default: + break; + } +#endif + + BIF_RET(BIF_ARG_1); +} + +/* + * NOTE: The erts_bif_prep_await_proc_exit_*() functions are + * tightly coupled with the implementation of erlang:await_proc_exit/3. + * The erts_bif_prep_await_proc_exit_*() functions can safely call + * skip_current_msgq() since they know that erlang:await_proc_exit/3 + * unconditionally will do a monitor and then unconditionally will + * wait for the corresponding 'DOWN' message in a receive, and no other + * receive is done before this receive. This optimization removes an + * unnecessary scan of the currently existing message queue (which + * can be large). If the erlang:await_proc_exit/3 implementation + * is changed so that the above isn't true, nasty bugs in later + * receives, etc, may appear. + */ + +static ERTS_INLINE int +skip_current_msgq(Process *c_p) +{ + int res; +#if defined(ERTS_ENABLE_LOCK_CHECK) && defined(ERTS_SMP) + erts_proc_lc_chk_only_proc_main(c_p); +#endif + + erts_smp_proc_lock(c_p, ERTS_PROC_LOCKS_MSG_RECEIVE); + if (ERTS_PROC_PENDING_EXIT(c_p)) { + KILL_CATCHES(c_p); + c_p->freason = EXC_EXIT; + res = 0; + } + else { + ERTS_SMP_MSGQ_MV_INQ2PRIVQ(c_p); + c_p->msg.save = c_p->msg.last; + res = 1; + } + erts_smp_proc_unlock(c_p, ERTS_PROC_LOCKS_MSG_RECEIVE); + return res; +} + +void +erts_bif_prep_await_proc_exit_data_trap(Process *c_p, Eterm pid, Eterm ret) +{ + if (skip_current_msgq(c_p)) { + Eterm unused; + ERTS_BIF_PREP_TRAP3(unused, await_proc_exit_trap, c_p, pid, am_data, ret); + } +} + +void +erts_bif_prep_await_proc_exit_reason_trap(Process *c_p, Eterm pid) +{ + if (skip_current_msgq(c_p)) { + Eterm unused; + ERTS_BIF_PREP_TRAP3(unused, await_proc_exit_trap, c_p, + pid, am_reason, am_undefined); + } +} + +void +erts_bif_prep_await_proc_exit_apply_trap(Process *c_p, + Eterm pid, + Eterm module, + Eterm function, + Eterm args[], + int nargs) +{ + ASSERT(is_atom(module) && is_atom(function)); + if (skip_current_msgq(c_p)) { + Eterm unused; + Eterm term; + Eterm *hp; + int i; + + hp = HAlloc(c_p, 4+2*nargs); + term = NIL; + for (i = nargs-1; i >= 0; i--) { + term = CONS(hp, args[i], term); + hp += 2; + } + term = TUPLE3(hp, module, function, term); + ERTS_BIF_PREP_TRAP3(unused, await_proc_exit_trap, c_p, pid, am_apply, term); + } +} + +Export bif_return_trap_export; + +void erts_init_bif(void) +{ + reference0 = 0; + reference1 = 0; + reference2 = 0; + + erts_smp_spinlock_init(&make_ref_lock, "make_ref"); + erts_smp_mtx_init(&ports_snapshot_mtx, "ports_snapshot"); + erts_smp_atomic_init(&erts_dead_ports_ptr, (long)NULL); + + /* + * bif_return_trap/1 is a hidden BIF that bifs that need to + * yield the calling process traps to. The only thing it does: + * return the value passed as argument. + */ + sys_memset((void *) &bif_return_trap_export, 0, sizeof(Export)); + bif_return_trap_export.address = &bif_return_trap_export.code[3]; + bif_return_trap_export.code[0] = am_erlang; + bif_return_trap_export.code[1] = am_bif_return_trap; +#ifdef DEBUG + bif_return_trap_export.code[2] = 2; +#else + bif_return_trap_export.code[2] = 1; +#endif + bif_return_trap_export.code[3] = (Eterm) em_apply_bif; + bif_return_trap_export.code[4] = (Eterm) &bif_return_trap; + + flush_monitor_message_trap = erts_export_put(am_erlang, + am_flush_monitor_message, + 2); + + set_cpu_topology_trap = erts_export_put(am_erlang, + am_set_cpu_topology, + 1); + erts_format_cpu_topology_trap = erts_export_put(am_erlang, + am_format_cpu_topology, + 1); + await_proc_exit_trap = erts_export_put(am_erlang,am_await_proc_exit,3); +} + +BIF_RETTYPE blocking_read_file_1(BIF_ALIST_1) +{ + Eterm bin; + Eterm* hp; + byte *buff; + int i, buff_size; + FILE *file; + struct stat file_info; + char *filename = NULL; + + i = list_length(BIF_ARG_1); + if (i < 0) { + BIF_ERROR(BIF_P, BADARG); + } + filename = erts_alloc(ERTS_ALC_T_TMP, i + 1); + if (intlist_to_buf(BIF_ARG_1, filename, i) != i) + erl_exit(1, "%s:%d: Internal error\n", __FILE__, __LINE__); + filename[i] = '\0'; + + hp = HAlloc(BIF_P, 3); + + file = fopen(filename, "r"); + if(file == NULL){ + erts_free(ERTS_ALC_T_TMP, (void *) filename); + BIF_RET(TUPLE2(hp, am_error, am_nofile)); + } + + stat(filename, &file_info); + erts_free(ERTS_ALC_T_TMP, (void *) filename); + + buff_size = file_info.st_size; + buff = (byte *) erts_alloc_fnf(ERTS_ALC_T_TMP, buff_size); + if (!buff) { + fclose(file); + BIF_RET(TUPLE2(hp, am_error, am_allocator)); + } + fread(buff, 1, buff_size, file); + fclose(file); + bin = new_binary(BIF_P, buff, buff_size); + erts_free(ERTS_ALC_T_TMP, (void *) buff); + + BIF_RET(TUPLE2(hp, am_ok, bin)); +} +#ifdef HARDDEBUG +/* +You'll need this line in bif.tab to be able to use this debug bif + +bif erlang:send_to_logger/2 + +*/ +BIF_RETTYPE send_to_logger_2(BIF_ALIST_2) +{ + byte *buf; + int len; + if (!is_atom(BIF_ARG_1) || !(is_list(BIF_ARG_2) || + is_nil(BIF_ARG_1))) { + BIF_ERROR(BIF_P,BADARG); + } + len = io_list_len(BIF_ARG_2); + if (len < 0) + BIF_ERROR(BIF_P,BADARG); + else if (len == 0) + buf = ""; + else { +#ifdef DEBUG + int len2; +#endif + buf = (byte *) erts_alloc(ERTS_ALC_T_TMP, len+1); +#ifdef DEBUG + len2 = +#else + (void) +#endif + io_list_to_buf(BIF_ARG_2, buf, len); + ASSERT(len2 == len); + buf[len] = '\0'; + switch (BIF_ARG_1) { + case am_info: + erts_send_info_to_logger(BIF_P->group_leader, buf, len); + break; + case am_warning: + erts_send_warning_to_logger(BIF_P->group_leader, buf, len); + break; + case am_error: + erts_send_error_to_logger(BIF_P->group_leader, buf, len); + break; + default: + { + BIF_ERROR(BIF_P,BADARG); + } + } + erts_free(ERTS_ALC_T_TMP, (void *) buf); + } + BIF_RET(am_true); +} +#endif /* HARDDEBUG */ + +BIF_RETTYPE get_module_info_1(BIF_ALIST_1) +{ + Eterm ret = erts_module_info_0(BIF_P, BIF_ARG_1); + + if (is_non_value(ret)) { + BIF_ERROR(BIF_P, BADARG); + } + BIF_RET(ret); +} + + +BIF_RETTYPE get_module_info_2(BIF_ALIST_2) +{ + Eterm ret = erts_module_info_1(BIF_P, BIF_ARG_1, BIF_ARG_2); + + if (is_non_value(ret)) { + BIF_ERROR(BIF_P, BADARG); + } + BIF_RET(ret); +} diff --git a/erts/emulator/beam/bif.h b/erts/emulator/beam/bif.h new file mode 100644 index 0000000000..05e9b78c28 --- /dev/null +++ b/erts/emulator/beam/bif.h @@ -0,0 +1,386 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifndef __BIF_H__ +#define __BIF_H__ + +extern Export* erts_format_cpu_topology_trap; + +#define BIF_RETTYPE Eterm + +#define BIF_P A__p + +#define BIF_ALIST_0 Process* A__p +#define BIF_ALIST_1 Process* A__p, Eterm A_1 +#define BIF_ALIST_2 Process* A__p, Eterm A_1, Eterm A_2 +#define BIF_ALIST_3 Process* A__p, Eterm A_1, Eterm A_2, Eterm A_3 + +#define BIF_ARG_1 A_1 +#define BIF_ARG_2 A_2 +#define BIF_ARG_3 A_3 + +#define BUMP_ALL_REDS(p) do { \ + if (!ERTS_PROC_GET_SAVED_CALLS_BUF((p))) \ + (p)->fcalls = 0; \ + else \ + (p)->fcalls = -CONTEXT_REDS; \ +} while(0) + + +#define ERTS_VBUMP_ALL_REDS(p) \ +do { \ + if (!ERTS_PROC_GET_SAVED_CALLS_BUF((p))) { \ + if ((p)->fcalls > 0) \ + ERTS_PROC_GET_SCHDATA((p))->virtual_reds += (p)->fcalls; \ + (p)->fcalls = 0; \ + } \ + else { \ + if ((p)->fcalls > -CONTEXT_REDS) \ + ERTS_PROC_GET_SCHDATA((p))->virtual_reds \ + += ((p)->fcalls - (-CONTEXT_REDS)); \ + (p)->fcalls = -CONTEXT_REDS; \ + } \ +} while(0) + +#define BUMP_REDS(p, gc) do { \ + (p)->fcalls -= (gc); \ + if ((p)->fcalls < 0) { \ + if (!ERTS_PROC_GET_SAVED_CALLS_BUF((p))) \ + (p)->fcalls = 0; \ + else if ((p)->fcalls < -CONTEXT_REDS) \ + (p)->fcalls = -CONTEXT_REDS; \ + } \ +} while(0) + + +#define ERTS_VBUMP_REDS(p, reds) \ +do { \ + if (!ERTS_PROC_GET_SAVED_CALLS_BUF((p))) { \ + if ((p)->fcalls >= reds) { \ + (p)->fcalls -= reds; \ + ERTS_PROC_GET_SCHDATA((p))->virtual_reds += reds; \ + } \ + else { \ + if ((p)->fcalls > 0) \ + ERTS_PROC_GET_SCHDATA((p))->virtual_reds += (p)->fcalls;\ + (p)->fcalls = 0; \ + } \ + } \ + else { \ + if ((p)->fcalls >= reds - CONTEXT_REDS) { \ + (p)->fcalls -= reds; \ + ERTS_PROC_GET_SCHDATA((p))->virtual_reds += reds; \ + } \ + else { \ + if ((p)->fcalls > -CONTEXT_REDS) \ + ERTS_PROC_GET_SCHDATA((p))->virtual_reds \ + += (p)->fcalls - (-CONTEXT_REDS); \ + (p)->fcalls = -CONTEXT_REDS; \ + } \ + } \ +} while(0) + +#define ERTS_BIF_REDS_LEFT(p) \ + (ERTS_PROC_GET_SAVED_CALLS_BUF((p)) \ + ? ((p)->fcalls > -CONTEXT_REDS ? ((p)->fcalls - (-CONTEXT_REDS)) : 0)\ + : ((p)->fcalls > 0 ? (p)->fcalls : 0)) + +#define BIF_RET2(x, gc) do { \ + BUMP_REDS(BIF_P, (gc)); \ + return (x); \ +} while(0) + +#define BIF_RET(x) return (x) + +#define ERTS_BIF_PREP_RET(Ret, Val) ((Ret) = (Val)) + +#define BIF_ERROR(p,r) do { \ + (p)->freason = r; \ + return THE_NON_VALUE; \ +} while(0) + +#define ERTS_BIF_PREP_ERROR(Ret, Proc, Reason) \ +do { \ + (Proc)->freason = (Reason); \ + (Ret) = THE_NON_VALUE; \ +} while (0) + + +#define ERTS_BIF_PREP_TRAP0(Ret, Trap, Proc) \ +do { \ + (Proc)->arity = 0; \ + (Proc)->def_arg_reg[3] = (Eterm) (Trap->address); \ + (Proc)->freason = TRAP; \ + (Ret) = THE_NON_VALUE; \ +} while (0) + +#define ERTS_BIF_PREP_TRAP1(Ret, Trap, Proc, A0) \ +do { \ + (Proc)->arity = 1; \ + (Proc)->def_arg_reg[0] = (Eterm) (A0); \ + (Proc)->def_arg_reg[3] = (Eterm) ((Trap)->address); \ + (Proc)->freason = TRAP; \ + (Ret) = THE_NON_VALUE; \ +} while (0) + +#define ERTS_BIF_PREP_TRAP2(Ret, Trap, Proc, A0, A1) \ +do { \ + (Proc)->arity = 2; \ + (Proc)->def_arg_reg[0] = (Eterm) (A0); \ + (Proc)->def_arg_reg[1] = (Eterm) (A1); \ + (Proc)->def_arg_reg[3] = (Eterm) ((Trap)->address); \ + (Proc)->freason = TRAP; \ + (Ret) = THE_NON_VALUE; \ +} while (0) + +#define ERTS_BIF_PREP_TRAP3(Ret, Trap, Proc, A0, A1, A2)\ +do { \ + (Proc)->arity = 3; \ + (Proc)->def_arg_reg[0] = (Eterm) (A0); \ + (Proc)->def_arg_reg[1] = (Eterm) (A1); \ + (Proc)->def_arg_reg[2] = (Eterm) (A2); \ + (Proc)->def_arg_reg[3] = (Eterm) ((Trap)->address); \ + (Proc)->freason = TRAP; \ + (Ret) = THE_NON_VALUE; \ +} while (0) + +#define BIF_TRAP0(p, Trap_) do { \ + (p)->arity = 0; \ + (p)->def_arg_reg[3] = (Eterm) ((Trap_)->address); \ + (p)->freason = TRAP; \ + return THE_NON_VALUE; \ + } while(0) + +#define BIF_TRAP1(Trap_, p, A0) do { \ + (p)->arity = 1; \ + (p)->def_arg_reg[0] = (A0); \ + (p)->def_arg_reg[3] = (Eterm) ((Trap_)->address); \ + (p)->freason = TRAP; \ + return THE_NON_VALUE; \ + } while(0) + +#define BIF_TRAP2(Trap_, p, A0, A1) do { \ + (p)->arity = 2; \ + (p)->def_arg_reg[0] = (A0); \ + (p)->def_arg_reg[1] = (A1); \ + (p)->def_arg_reg[3] = (Eterm) ((Trap_)->address); \ + (p)->freason = TRAP; \ + return THE_NON_VALUE; \ + } while(0) + +#define BIF_TRAP3(Trap_, p, A0, A1, A2) do { \ + (p)->arity = 3; \ + (p)->def_arg_reg[0] = (A0); \ + (p)->def_arg_reg[1] = (A1); \ + (p)->def_arg_reg[2] = (A2); \ + (p)->def_arg_reg[3] = (Eterm) ((Trap_)->address); \ + (p)->freason = TRAP; \ + return THE_NON_VALUE; \ + } while(0) + +#define BIF_TRAP_CODE_PTR_0(p, Code_) do { \ + (p)->arity = 0; \ + (p)->def_arg_reg[3] = (Eterm) (Code_); \ + (p)->freason = TRAP; \ + return THE_NON_VALUE; \ + } while(0) + +extern Export bif_return_trap_export; +#ifdef DEBUG +#define ERTS_BIF_PREP_YIELD_RETURN_X(RET, P, VAL, DEBUG_VAL) \ +do { \ + ERTS_VBUMP_ALL_REDS(P); \ + ERTS_BIF_PREP_TRAP2(RET, &bif_return_trap_export, (P), (VAL), \ + (DEBUG_VAL)); \ +} while (0) +#else +#define ERTS_BIF_PREP_YIELD_RETURN_X(RET, P, VAL, DEBUG_VAL) \ +do { \ + ERTS_VBUMP_ALL_REDS(P); \ + ERTS_BIF_PREP_TRAP1(RET, &bif_return_trap_export, (P), (VAL)); \ +} while (0) +#endif + +#define ERTS_BIF_PREP_YIELD_RETURN(RET, P, VAL) \ + ERTS_BIF_PREP_YIELD_RETURN_X(RET, (P), (VAL), am_undefined) + +#ifdef DEBUG +#define ERTS_BIF_YIELD_RETURN_X(P, VAL, DEBUG_VAL) \ +do { \ + ERTS_VBUMP_ALL_REDS(P); \ + BIF_TRAP2(&bif_return_trap_export, (P), (VAL), (DEBUG_VAL)); \ +} while (0) +#else +#define ERTS_BIF_YIELD_RETURN_X(P, VAL, DEBUG_VAL) \ +do { \ + ERTS_VBUMP_ALL_REDS(P); \ + BIF_TRAP1(&bif_return_trap_export, (P), (VAL)); \ +} while (0) +#endif + +#define ERTS_BIF_RETURN_YIELD(P) ERTS_VBUMP_ALL_REDS((P)) + +#define ERTS_BIF_YIELD_RETURN(P, VAL) \ + ERTS_BIF_YIELD_RETURN_X((P), (VAL), am_undefined) + +#define ERTS_BIF_PREP_YIELD0(RET, TRP, P) \ +do { \ + ERTS_VBUMP_ALL_REDS((P)); \ + ERTS_BIF_PREP_TRAP0(RET, (TRP), (P)); \ +} while (0) + +#define ERTS_BIF_PREP_YIELD1(RET, TRP, P, A0) \ +do { \ + ERTS_VBUMP_ALL_REDS((P)); \ + ERTS_BIF_PREP_TRAP1(RET, (TRP), (P), (A0)); \ +} while (0) + +#define ERTS_BIF_PREP_YIELD2(RET, TRP, P, A0, A1) \ +do { \ + ERTS_VBUMP_ALL_REDS((P)); \ + ERTS_BIF_PREP_TRAP2(RET, (TRP), (P), (A0), (A1)); \ +} while (0) + +#define ERTS_BIF_PREP_YIELD3(RET, TRP, P, A0, A1, A2) \ +do { \ + ERTS_VBUMP_ALL_REDS((P)); \ + ERTS_BIF_PREP_TRAP3(RET, (TRP), (P), (A0), (A1), (A2)); \ +} while (0) + +#define ERTS_BIF_YIELD0(TRP, P) \ +do { \ + ERTS_VBUMP_ALL_REDS((P)); \ + BIF_TRAP0((TRP), (P)); \ +} while (0) + +#define ERTS_BIF_YIELD1(TRP, P, A0) \ +do { \ + ERTS_VBUMP_ALL_REDS((P)); \ + BIF_TRAP1((TRP), (P), (A0)); \ +} while (0) + +#define ERTS_BIF_YIELD2(TRP, P, A0, A1) \ +do { \ + ERTS_VBUMP_ALL_REDS((P)); \ + BIF_TRAP2((TRP), (P), (A0), (A1)); \ +} while (0) + +#define ERTS_BIF_YIELD3(TRP, P, A0, A1, A2) \ +do { \ + ERTS_VBUMP_ALL_REDS((P)); \ + BIF_TRAP3((TRP), (P), (A0), (A1), (A2)); \ +} while (0) + +#define ERTS_BIF_EXITED(PROC) \ +do { \ + KILL_CATCHES((PROC)); \ + BIF_ERROR((PROC), EXC_EXIT); \ +} while (0) + +#define ERTS_BIF_CHK_EXITED(PROC) \ +do { \ + if (ERTS_PROC_IS_EXITING((PROC))) \ + ERTS_BIF_EXITED((PROC)); \ +} while (0) + +#ifdef ERTS_SMP +#define ERTS_SMP_BIF_CHK_PENDING_EXIT(P, L) \ +do { \ + ERTS_SMP_LC_ASSERT((L) == erts_proc_lc_my_proc_locks((P))); \ + ERTS_SMP_LC_ASSERT(ERTS_PROC_LOCK_MAIN & (L)); \ + if (!((L) & ERTS_PROC_LOCK_STATUS)) \ + erts_smp_proc_lock((P), ERTS_PROC_LOCK_STATUS); \ + if (ERTS_PROC_PENDING_EXIT((P))) { \ + erts_handle_pending_exit((P), (L)|ERTS_PROC_LOCK_STATUS); \ + erts_smp_proc_unlock((P), \ + (((L)|ERTS_PROC_LOCK_STATUS) \ + & ~ERTS_PROC_LOCK_MAIN)); \ + ERTS_BIF_EXITED((P)); \ + } \ + if (!((L) & ERTS_PROC_LOCK_STATUS)) \ + erts_smp_proc_unlock((P), ERTS_PROC_LOCK_STATUS); \ +} while (0) +#else +#define ERTS_SMP_BIF_CHK_PENDING_EXIT(P, L) +#endif + +/* + * The ERTS_BIF_*_AWAIT_X_*_TRAP makros either exits the caller, or + * sets up a trap to erlang:await_proc_exit/3. + * + * The caller is acquired to hold the 'main' lock on C_P. No other locks + * are allowed to be held. + */ + +#define ERTS_BIF_PREP_AWAIT_X_DATA_TRAP(RET, C_P, PID, DATA) \ +do { \ + erts_bif_prep_await_proc_exit_data_trap((C_P), (PID), (DATA)); \ + (RET) = THE_NON_VALUE; \ +} while (0) + +#define ERTS_BIF_PREP_AWAIT_X_REASON_TRAP(RET, C_P, PID) \ +do { \ + erts_bif_prep_await_proc_exit_reason_trap((C_P), (PID)); \ + (RET) = THE_NON_VALUE; \ +} while (0) + +#define ERTS_BIF_PREP_AWAIT_X_APPLY_TRAP(RET, C_P, PID, M, F, A, AN) \ +do { \ + erts_bif_prep_await_proc_exit_apply_trap((C_P), (PID), \ + (M), (F), (A), (AN)); \ + (RET) = THE_NON_VALUE; \ +} while (0) + +#define ERTS_BIF_AWAIT_X_DATA_TRAP(C_P, PID, DATA) \ +do { \ + erts_bif_prep_await_proc_exit_data_trap((C_P), (PID), (DATA)); \ + return THE_NON_VALUE; \ +} while (0) + +#define ERTS_BIF_AWAIT_X_REASON_TRAP(C_P, PID) \ +do { \ + erts_bif_prep_await_proc_exit_reason_trap((C_P), (PID)); \ + return THE_NON_VALUE; \ +} while (0) + +#define ERTS_BIF_AWAIT_X_APPLY_TRAP(C_P, PID, M, F, A, AN) \ +do { \ + erts_bif_prep_await_proc_exit_apply_trap((C_P), (PID), \ + (M), (F), (A), (AN)); \ + return THE_NON_VALUE; \ +} while (0) + +void +erts_bif_prep_await_proc_exit_data_trap(Process *c_p, + Eterm pid, + Eterm data); +void +erts_bif_prep_await_proc_exit_reason_trap(Process *c_p, + Eterm pid); +void +erts_bif_prep_await_proc_exit_apply_trap(Process *c_p, + Eterm pid, + Eterm module, + Eterm function, + Eterm args[], + int nargs); + +#include "erl_bif_table.h" + +#endif diff --git a/erts/emulator/beam/bif.tab b/erts/emulator/beam/bif.tab new file mode 100644 index 0000000000..85a729208f --- /dev/null +++ b/erts/emulator/beam/bif.tab @@ -0,0 +1,761 @@ +# +# %CopyrightBegin% +# +# Copyright Ericsson AB 1996-2009. All Rights Reserved. +# +# The contents of this file are subject to the Erlang Public License, +# Version 1.1, (the "License"); you may not use this file except in +# compliance with the License. You should have received a copy of the +# Erlang Public License along with this software. If not, it can be +# retrieved online at http://www.erlang.org/. +# +# Software distributed under the License is distributed on an "AS IS" +# basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +# the License for the specific language governing rights and limitations +# under the License. +# +# %CopyrightEnd% +# + +# +# File format: +# +# Lines starting with '#' are ignored. +# +# ::= "bif" * | "ubif" * +# ::= ":" "/" +# +# "ubif" is an unwrapped bif, i.e. a bif without a trace wrapper, +# or rather; the trace entry point in the export entry is the same +# as the normal entry point, and no trace wrapper is generated. +# +# Important: Use "ubif" for guard BIFs and operators; use "bif" for ordinary BIFs. +# +# Add new BIFs to the end of the file. Do not bother adding a "packaged BIF name" +# (such as 'erl.lang.number'); if/when packages will be supported we will add +# all those names. +# +# Note: Guards BIFs require special support in the compiler (to be able to actually +# call them from within a guard). +# + +ubif erlang:abs/1 +ubif 'erl.lang.number':abs/1 ebif_abs_1 +bif erlang:adler32/1 +bif 'erl.util.crypt.adler32':sum/1 ebif_adler32_1 +bif erlang:adler32/2 +bif 'erl.util.crypt.adler32':sum/2 ebif_adler32_2 +bif erlang:adler32_combine/3 +bif 'erl.util.crypt.adler32':combine/3 ebif_adler32_combine_3 +bif erlang:apply/3 +bif 'erl.lang':apply/3 ebif_apply_3 +bif erlang:atom_to_list/1 +bif 'erl.lang.atom':to_string/1 ebif_atom_to_string_1 atom_to_list_1 +bif erlang:binary_to_list/1 +bif 'erl.lang.binary':to_list/1 ebif_binary_to_list_1 +bif erlang:binary_to_list/3 +bif 'erl.lang.binary':to_list/3 ebif_binary_to_list_3 +bif erlang:binary_to_term/1 +bif 'erl.lang.binary':to_term/1 ebif_binary_to_term_1 +bif erlang:check_process_code/2 +bif 'erl.system.code':check_process/2 ebif_check_process_code_2 +bif erlang:crc32/1 +bif 'erl.util.crypt.crc32':sum/1 ebif_crc32_1 +bif erlang:crc32/2 +bif 'erl.util.crypt.crc32':sum/2 ebif_crc32_2 +bif erlang:crc32_combine/3 +bif 'erl.util.crypt.crc32':combine/3 ebif_crc32_combine_3 +bif erlang:date/0 +bif 'erl.util.date':today/0 ebif_date_0 +bif erlang:delete_module/1 +bif 'erl.system.code':delete/1 ebif_delete_module_1 +bif erlang:display/1 +bif 'erl.system.debug':display/1 ebif_display_1 +bif erlang:display_string/1 +bif 'erl.system.debug':display_string/1 ebif_display_string_1 +bif erlang:display_nl/0 +bif 'erl.system.debug':display_nl/0 ebif_display_nl_0 +ubif erlang:element/2 +ubif 'erl.lang.tuple':element/2 ebif_element_2 +bif erlang:erase/0 +bif 'erl.lang.proc.pdict':erase/0 ebif_erase_0 +bif erlang:erase/1 +bif 'erl.lang.proc.pdict':erase/1 ebif_erase_1 +bif erlang:exit/1 +bif 'erl.lang':exit/1 ebif_exit_1 +bif erlang:exit/2 +bif 'erl.lang.proc':signal/2 ebif_signal_2 exit_2 +bif erlang:external_size/1 +bif 'erl.lang.term':external_size/1 ebif_external_size_1 +ubif erlang:float/1 +ubif 'erl.lang.number':to_float/1 ebif_to_float_1 float_1 +bif erlang:float_to_list/1 +bif 'erl.lang.float':to_string/1 ebif_float_to_string_1 float_to_list_1 +bif erlang:fun_info/2 +bif 'erl.lang.function':info/2 ebif_fun_info_2 +bif erlang:garbage_collect/0 +bif 'erl.system':garbage_collect/0 ebif_garbage_collect_0 +bif erlang:garbage_collect/1 +bif 'erl.system':garbage_collect/1 ebif_garbage_collect_1 +bif erlang:garbage_collect_message_area/0 +bif 'erl.system':garbage_collect_message_area/0 ebif_garbage_collect_message_area_0 +bif erlang:get/0 +bif 'erl.lang.proc.pdict':get/0 ebif_get_0 +bif erlang:get/1 +bif 'erl.lang.proc.pdict':get/1 ebif_get_1 +bif erlang:get_keys/1 +bif 'erl.lang.proc.pdict':get_keys/1 ebif_get_keys_1 +bif erlang:group_leader/0 +bif 'erl.lang.proc':group_leader/0 ebif_group_leader_0 +bif erlang:group_leader/2 +bif 'erl.lang.proc':set_group_leader/2 ebif_group_leader_2 +bif erlang:halt/0 +bif 'erl.lang.system':halt/0 ebif_halt_0 +bif erlang:halt/1 +bif 'erl.lang.system':halt/1 ebif_halt_1 +bif erlang:phash/2 +bif erlang:phash2/1 +bif erlang:phash2/2 +bif 'erl.lang.term':hash/1 ebif_phash2_1 +bif 'erl.lang.term':hash/2 ebif_phash2_2 +ubif erlang:hd/1 +ubif 'erl.lang.list':hd/1 ebif_hd_1 +bif erlang:integer_to_list/1 +bif 'erl.lang.integer':to_string/1 ebif_integer_to_string_1 integer_to_list_1 +bif erlang:is_alive/0 +bif 'erl.lang.node':is_alive/0 ebif_is_alive_0 +ubif erlang:length/1 +ubif 'erl.lang.list':length/1 ebif_length_1 +bif erlang:link/1 +bif 'erl.lang.proc':link/1 ebif_link_1 +bif erlang:list_to_atom/1 +bif 'erl.lang.atom':from_string/1 ebif_string_to_atom_1 list_to_atom_1 +bif erlang:list_to_binary/1 +bif 'erl.lang.binary':from_list/1 ebif_list_to_binary_1 +bif erlang:list_to_float/1 +bif 'erl.lang.float':from_string/1 ebif_string_to_float_1 list_to_float_1 +bif erlang:list_to_integer/1 +bif 'erl.lang.integer':from_string/1 ebif_string_to_integer_1 list_to_integer_1 +bif erlang:list_to_pid/1 +bif 'erl.lang.proc':string_to_pid/1 ebif_string_to_pid_1 list_to_pid_1 +bif erlang:list_to_tuple/1 +bif 'erl.lang.tuple':from_list/1 ebif_list_to_tuple_1 +bif erlang:load_module/2 +bif 'erl.system.code':load/2 ebif_load_module_2 +bif erlang:loaded/0 +bif 'erl.system.code':loaded/0 ebif_loaded_0 +bif erlang:localtime/0 +bif 'erl.util.date':local/0 ebif_localtime_0 +bif erlang:localtime_to_universaltime/2 +bif 'erl.util.date':local_to_utc/2 ebif_localtime_to_universaltime_2 +bif erlang:make_ref/0 +bif 'erl.lang.ref':new/0 ebif_make_ref_0 +bif erlang:md5/1 +bif 'erl.util.crypt.md5':digest/1 ebif_md5_1 +bif erlang:md5_init/0 +bif 'erl.util.crypt.md5':init/0 ebif_md5_init_0 +bif erlang:md5_update/2 +bif 'erl.util.crypt.md5':update/2 ebif_md5_update_2 +bif erlang:md5_final/1 +bif 'erl.util.crypt.md5':final/1 ebif_md5_final_1 +bif erlang:memory/0 +bif 'erl.lang':memory/0 ebif_memory_0 +bif erlang:memory/1 +bif 'erl.lang':memory/1 ebif_memory_1 +bif erlang:module_loaded/1 +bif 'erl.system.code':is_loaded/1 ebif_is_loaded_1 module_loaded_1 +bif erlang:function_exported/3 +bif 'erl.system.code':is_loaded/3 ebif_is_loaded_3 function_exported_3 +bif erlang:monitor_node/2 +bif 'erl.lang.node':monitor/2 ebif_monitor_node_2 +bif erlang:monitor_node/3 +bif 'erl.lang.node':monitor/3 ebif_monitor_node_3 +ubif erlang:node/1 +ubif 'erl.lang.node':node/1 ebif_node_1 +ubif erlang:node/0 +ubif 'erl.lang.node':node/0 ebif_node_0 +bif erlang:nodes/1 +bif 'erl.lang.node':nodes/1 ebif_nodes_1 +bif erlang:now/0 +bif 'erl.system':now/0 ebif_now_0 + +bif erlang:open_port/2 +bif 'erl.lang.port':open/2 ebif_open_port_2 open_port_2 + +bif erlang:pid_to_list/1 +bif 'erl.lang.proc':pid_to_string/1 ebif_pid_to_string_1 pid_to_list_1 +bif erlang:port_info/1 +bif 'erl.lang.port':info/1 ebif_port_info_1 +bif erlang:port_info/2 +bif 'erl.lang.port':info/2 ebif_port_info_2 +bif erlang:ports/0 +bif 'erl.lang.node':ports/0 ebif_ports_0 +bif erlang:pre_loaded/0 +bif 'erl.system.code':preloaded/0 ebif_pre_loaded_0 +bif erlang:process_flag/2 +bif 'erl.lang.proc':set_flag/2 ebif_process_flag_2 +bif erlang:process_flag/3 +bif 'erl.lang.proc':set_flag/3 ebif_process_flag_3 +bif erlang:process_info/1 +bif 'erl.lang.proc':info/1 ebif_process_info_1 +bif erlang:process_info/2 +bif 'erl.lang.proc':info/2 ebif_process_info_2 +bif erlang:processes/0 +bif 'erl.lang.node':processes/0 ebif_processes_0 +bif erlang:purge_module/1 +bif 'erl.system.code':purge/1 ebif_purge_module_1 +bif erlang:put/2 +bif 'erl.lang.proc.pdict':put/2 ebif_put_2 +bif erlang:register/2 +bif 'erl.lang.node':register/2 ebif_register_2 +bif erlang:registered/0 +bif 'erl.lang.node':registered/0 ebif_registered_0 +ubif erlang:round/1 +ubif 'erl.lang.number':round/1 ebif_round_1 +ubif erlang:self/0 +ubif 'erl.lang.proc':self/0 ebif_self_0 +bif erlang:setelement/3 +bif 'erl.lang.tuple':setelement/3 ebif_setelement_3 +ubif erlang:size/1 +ubif 'erl.lang.term':size/1 ebif_size_1 +bif erlang:spawn/3 +bif 'erl.lang.proc':spawn/3 ebif_spawn_3 +bif erlang:spawn_link/3 +bif 'erl.lang.proc':spawn_link/3 ebif_spawn_link_3 +bif erlang:split_binary/2 +bif 'erl.lang.binary':split/2 ebif_split_binary_2 +bif erlang:statistics/1 +bif 'erl.system':statistics/1 ebif_statistics_1 +bif erlang:term_to_binary/1 +bif 'erl.lang.binary':from_term/1 ebif_term_to_binary_1 +bif erlang:term_to_binary/2 +bif 'erl.lang.binary':from_term/2 ebif_term_to_binary_2 +bif erlang:throw/1 +bif 'erl.lang':throw/1 ebif_throw_1 +bif erlang:time/0 +bif 'erl.util.date':time_of_day/0 ebif_time_0 +ubif erlang:tl/1 +ubif 'erl.lang.list':tl/1 ebif_tl_1 +ubif erlang:trunc/1 +ubif 'erl.lang.number':trunc/1 ebif_trunc_1 +bif erlang:tuple_to_list/1 +bif 'erl.lang.tuple':to_list/1 ebif_tuple_to_list_1 +bif erlang:universaltime/0 +bif 'erl.util.date':utc/0 ebif_universaltime_0 +bif erlang:universaltime_to_localtime/1 +bif 'erl.util.date':utc_to_local/1 ebif_universaltime_to_localtime_1 +bif erlang:unlink/1 +bif 'erl.lang.proc':unlink/1 ebif_unlink_1 +bif erlang:unregister/1 +bif 'erl.lang.node':unregister/1 ebif_unregister_1 +bif erlang:whereis/1 +bif 'erl.lang.node':whereis/1 ebif_whereis_1 +bif erlang:spawn_opt/1 +bif 'erl.lang.proc':spawn_opt/1 ebif_spawn_opt_1 +bif erlang:setnode/2 +bif erlang:setnode/3 +bif erlang:dist_exit/3 + +bif erlang:port_call/2 +bif 'erl.lang.port':call/2 ebif_port_call_2 +bif erlang:port_call/3 +bif 'erl.lang.port':call/3 ebif_port_call_3 +bif erlang:port_command/2 +bif 'erl.lang.port':command/2 ebif_port_command_2 +bif erlang:port_command/3 +bif 'erl.lang.port':command/3 ebif_port_command_3 +bif erlang:port_control/3 +bif 'erl.lang.port':control/3 ebif_port_control_3 +bif erlang:port_close/1 +bif 'erl.lang.port':close/1 ebif_port_close_1 +bif erlang:port_connect/2 +bif 'erl.lang.port':connect/2 ebif_port_connect_2 +bif erlang:port_set_data/2 +bif 'erl.lang.port':set_data/2 ebif_port_set_data_2 +bif erlang:port_get_data/1 +bif 'erl.lang.port':get_data/1 ebif_port_get_data_1 + +# Tracing & debugging. +bif erlang:trace_pattern/2 +bif 'erl.system.debug':trace_pattern/2 ebif_trace_pattern_2 +bif erlang:trace_pattern/3 +bif 'erl.system.debug':trace_pattern/3 ebif_trace_pattern_3 +bif erlang:trace/3 +bif 'erl.system.debug':trace/3 ebif_trace_3 +bif erlang:trace_info/2 +bif 'erl.system.debug':trace_info/2 ebif_trace_info_2 +bif erlang:trace_delivered/1 +bif 'erl.system.debug':trace_delivered/1 ebif_trace_delivered_1 +bif erlang:seq_trace/2 +bif 'erl.system.debug':seq_trace/2 ebif_seq_trace_2 +bif erlang:seq_trace_info/1 +bif 'erl.system.debug':seq_trace_info/1 ebif_seq_trace_info_1 +bif erlang:seq_trace_print/1 +bif 'erl.system.debug':seq_trace_print/1 ebif_seq_trace_print_1 +bif erlang:seq_trace_print/2 +bif 'erl.system.debug':seq_trace_print/2 ebif_seq_trace_print_2 +bif erlang:suspend_process/2 +bif 'erl.system.debug':suspend_process/2 ebif_suspend_process_2 +bif erlang:resume_process/1 +bif 'erl.system.debug':resume_process/1 ebif_resume_process_1 +bif erlang:process_display/2 +bif 'erl.system.debug':process_display/2 ebif_process_display_2 + +bif erlang:bump_reductions/1 +bif 'erl.lang.proc':bump_reductions/1 ebif_bump_reductions_1 + +bif math:cos/1 +bif 'erl.lang.math':cos/1 ebif_math_cos_1 +bif math:cosh/1 +bif 'erl.lang.math':cosh/1 ebif_math_cosh_1 +bif math:sin/1 +bif 'erl.lang.math':sin/1 ebif_math_sin_1 +bif math:sinh/1 +bif 'erl.lang.math':sinh/1 ebif_math_sinh_1 +bif math:tan/1 +bif 'erl.lang.math':tan/1 ebif_math_tan_1 +bif math:tanh/1 +bif 'erl.lang.math':tanh/1 ebif_math_tanh_1 +bif math:acos/1 +bif 'erl.lang.math':acos/1 ebif_math_acos_1 +bif math:acosh/1 +bif 'erl.lang.math':acosh/1 ebif_math_acosh_1 +bif math:asin/1 +bif 'erl.lang.math':asin/1 ebif_math_asin_1 +bif math:asinh/1 +bif 'erl.lang.math':asinh/1 ebif_math_asinh_1 +bif math:atan/1 +bif 'erl.lang.math':atan/1 ebif_math_atan_1 +bif math:atanh/1 +bif 'erl.lang.math':atanh/1 ebif_math_atanh_1 +bif math:erf/1 +bif 'erl.lang.math':erf/1 ebif_math_erf_1 +bif math:erfc/1 +bif 'erl.lang.math':erfc/1 ebif_math_erfc_1 +bif math:exp/1 +bif 'erl.lang.math':exp/1 ebif_math_exp_1 +bif math:log/1 +bif 'erl.lang.math':log/1 ebif_math_log_1 +bif math:log10/1 +bif 'erl.lang.math':log10/1 ebif_math_log10_1 +bif math:sqrt/1 +bif 'erl.lang.math':sqrt/1 ebif_math_sqrt_1 +bif math:atan2/2 +bif 'erl.lang.math':atan2/2 ebif_math_atan2_2 +bif math:pow/2 +bif 'erl.lang.math':pow/2 ebif_math_pow_2 + +bif erlang:start_timer/3 +bif 'erl.lang.timer':start/3 ebif_start_timer_3 +bif erlang:send_after/3 +bif 'erl.lang.timer':send_after/3 ebif_send_after_3 +bif erlang:cancel_timer/1 +bif 'erl.lang.timer':cancel/1 ebif_cancel_timer_1 +bif erlang:read_timer/1 +bif 'erl.lang.timer':read/1 ebif_read_timer_1 + +bif erlang:make_tuple/2 +bif 'erl.lang.tuple':make/2 ebif_make_tuple_2 +bif erlang:append_element/2 +bif 'erl.lang.tuple':append_element/2 ebif_append_element_2 +bif erlang:make_tuple/3 + +bif erlang:system_flag/2 +bif 'erl.system':set_flag/2 ebif_system_flag_2 +bif erlang:system_info/1 +bif 'erl.system':info/1 ebif_system_info_1 +# New in R9C +bif erlang:system_monitor/0 +bif 'erl.system':monitor/0 ebif_system_monitor_0 +bif erlang:system_monitor/1 +bif 'erl.system':monitor/1 ebif_system_monitor_1 +bif erlang:system_monitor/2 +bif 'erl.system':monitor/2 ebif_system_monitor_2 +# Added 2006-11-07 +bif erlang:system_profile/2 +bif 'erl.system':profile/2 ebif_system_profile_2 +# End Added 2006-11-07 +# Added 2007-01-17 +bif erlang:system_profile/0 +bif 'erl.system':profile/0 ebif_system_profile_0 +# End Added 2007-01-17 +bif erlang:ref_to_list/1 +bif 'erl.lang.ref':to_string/1 ebif_ref_to_string_1 ref_to_list_1 +bif erlang:port_to_list/1 +bif 'erl.lang.port':to_string/1 ebif_port_to_string_1 port_to_list_1 +bif erlang:fun_to_list/1 +bif 'erl.lang.function':to_string/1 ebif_fun_to_string_1 fun_to_list_1 + +bif erlang:monitor/2 +bif 'erl.lang.proc':monitor/2 ebif_monitor_2 +bif erlang:demonitor/1 +bif 'erl.lang.proc':demonitor/1 ebif_demonitor_1 +bif erlang:demonitor/2 +bif 'erl.lang.proc':demonitor/2 ebif_demonitor_2 + +bif erlang:is_process_alive/1 +bif 'erl.lang.proc':is_alive/1 ebif_proc_is_alive_1 is_process_alive_1 + +bif erlang:error/1 error_1 +bif 'erl.lang':error/1 ebif_error_1 error_1 +bif erlang:error/2 error_2 +bif 'erl.lang':error/2 ebif_error_2 error_2 +bif erlang:raise/3 raise_3 +bif 'erl.lang':raise/3 ebif_raise_3 raise_3 +bif erlang:get_stacktrace/0 +bif 'erl.lang.proc':get_stacktrace/0 ebif_get_stacktrace_0 + +bif erlang:is_builtin/3 +bif 'erl.system.code':is_builtin/3 ebif_is_builtin_3 + +ubif erlang:'and'/2 +ubif 'erl.lang.bool':'and'/2 ebif_and_2 +ubif erlang:'or'/2 +ubif 'erl.lang.bool':'or'/2 ebif_or_2 +ubif erlang:'xor'/2 +ubif 'erl.lang.bool':'xor'/2 ebif_xor_2 +ubif erlang:'not'/1 +ubif 'erl.lang.bool':'not'/1 ebif_not_1 + +ubif erlang:'>'/2 sgt_2 +ubif 'erl.lang.term':greater/2 ebif_gt_2 sgt_2 +ubif erlang:'>='/2 sge_2 +ubif 'erl.lang.term':greater_or_equal/2 ebif_ge_2 sge_2 +ubif erlang:'<'/2 slt_2 +ubif 'erl.lang.term':less/2 ebif_lt_2 slt_2 +ubif erlang:'=<'/2 sle_2 +ubif 'erl.lang.term':less_or_equal/2 ebif_le_2 sle_2 +ubif erlang:'=:='/2 seq_2 +ubif 'erl.lang.term':equal/2 ebif_eq_2 seq_2 +ubif erlang:'=='/2 seqeq_2 +ubif 'erl.lang.term':arith_equal/2 ebif_areq_2 seqeq_2 +ubif erlang:'=/='/2 sneq_2 +ubif 'erl.lang.term':not_equal/2 ebif_neq_2 sneq_2 +ubif erlang:'/='/2 sneqeq_2 +ubif 'erl.lang.term':not_arith_equal/2 ebif_nareq_2 sneqeq_2 +ubif erlang:'+'/2 splus_2 +ubif 'erl.lang.number':plus/2 ebif_plus_2 splus_2 +ubif erlang:'-'/2 sminus_2 +ubif 'erl.lang.number':minus/2 ebif_minus_2 sminus_2 +ubif erlang:'*'/2 stimes_2 +ubif 'erl.lang.number':multiply/2 ebif_multiply_2 stimes_2 +ubif erlang:'/'/2 div_2 +ubif 'erl.lang.number':divide/2 ebif_divide_2 div_2 +ubif erlang:'div'/2 intdiv_2 +ubif 'erl.lang.integer':'div'/2 ebif_intdiv_2 +ubif erlang:'rem'/2 +ubif 'erl.lang.integer':'rem'/2 ebif_rem_2 +ubif erlang:'bor'/2 +ubif 'erl.lang.integer':'bor'/2 ebif_bor_2 +ubif erlang:'band'/2 +ubif 'erl.lang.integer':'band'/2 ebif_band_2 +ubif erlang:'bxor'/2 +ubif 'erl.lang.integer':'bxor'/2 ebif_bxor_2 +ubif erlang:'bsl'/2 +ubif 'erl.lang.integer':'bsl'/2 ebif_bsl_2 +ubif erlang:'bsr'/2 +ubif 'erl.lang.integer':'bsr'/2 ebif_bsr_2 +ubif erlang:'bnot'/1 +ubif 'erl.lang.integer':'bnot'/1 ebif_bnot_1 +ubif erlang:'-'/1 sminus_1 +ubif 'erl.lang.number':minus/1 ebif_minus_1 sminus_1 +ubif erlang:'+'/1 splus_1 +ubif 'erl.lang.number':plus/1 ebif_plus_1 splus_1 + +# New operators in R8. These were the only operators missing. +# erlang:send/2, erlang:append/2 and erlang:subtract/2 are now also +# defined in erlang.erl, and the C names can be removed when all +# internal references have been updated to the new ebif_... entries. + +bif erlang:'!'/2 ebif_bang_2 +bif 'erl.lang.proc':send/2 ebif_send_2 send_2 +bif erlang:send/2 +bif 'erl.lang':send/3 ebif_send_3 send_3 +bif erlang:send/3 +bif erlang:'++'/2 ebif_plusplus_2 +bif 'erl.lang.list':append/2 ebif_append_2 ebif_plusplus_2 +bif erlang:append/2 +bif erlang:'--'/2 ebif_minusminus_2 +bif 'erl.lang.list':subtract/2 ebif_list_subtract_2 ebif_minusminus_2 +bif erlang:subtract/2 + +ubif erlang:is_atom/1 +ubif 'erl.lang.term':is_atom/1 ebif_is_atom_1 +ubif erlang:is_list/1 +ubif 'erl.lang.term':is_list/1 ebif_is_list_1 +ubif erlang:is_tuple/1 +ubif 'erl.lang.term':is_tuple/1 ebif_is_tuple_1 +ubif erlang:is_float/1 +ubif 'erl.lang.term':is_float/1 ebif_is_float_1 +ubif erlang:is_integer/1 +ubif 'erl.lang.term':is_integer/1 ebif_is_integer_1 +ubif erlang:is_number/1 +ubif 'erl.lang.term':is_number/1 ebif_is_number_1 +ubif erlang:is_pid/1 +ubif 'erl.lang.term':is_pid/1 ebif_is_pid_1 +ubif erlang:is_port/1 +ubif 'erl.lang.term':is_port/1 ebif_is_port_1 +ubif erlang:is_reference/1 +ubif 'erl.lang.term':is_reference/1 ebif_is_reference_1 +ubif erlang:is_binary/1 +ubif 'erl.lang.term':is_binary/1 ebif_is_binary_1 +ubif erlang:is_function/1 +ubif 'erl.lang.term':is_function/1 ebif_is_function_1 +ubif erlang:is_function/2 +ubif 'erl.lang.term':is_function/2 ebif_is_function_2 +ubif erlang:is_record/2 +ubif 'erl.lang.term':is_record/2 ebif_is_record_2 +ubif erlang:is_record/3 +ubif 'erl.lang.term':is_record/3 ebif_is_record_3 + +bif erlang:match_spec_test/3 + +# +# Bifs in ets module. +# + +bif ets:all/0 +bif 'erl.lang.ets':all/0 ebif_ets_all_0 +bif ets:new/2 +bif 'erl.lang.ets':new/2 ebif_ets_new_2 +bif ets:delete/1 +bif 'erl.lang.ets':delete/1 ebif_ets_delete_1 +bif ets:delete/2 +bif 'erl.lang.ets':delete/2 ebif_ets_delete_2 +bif ets:delete_all_objects/1 +bif 'erl.lang.ets':delete_all_objects/1 ebif_ets_delete_all_objects_1 +bif ets:delete_object/2 +bif 'erl.lang.ets':delete_object/2 ebif_ets_delete_object_2 +bif ets:first/1 +bif 'erl.lang.ets':first/1 ebif_ets_first_1 +bif ets:is_compiled_ms/1 +bif 'erl.lang.ets':is_compiled_ms/1 ebif_ets_is_compiled_ms_1 +bif ets:lookup/2 +bif 'erl.lang.ets':lookup/2 ebif_ets_lookup_2 +bif ets:lookup_element/3 +bif 'erl.lang.ets':lookup_element/3 ebif_ets_lookup_element_3 +bif ets:info/1 +bif 'erl.lang.ets':info/1 ebif_ets_info_1 +bif ets:info/2 +bif 'erl.lang.ets':info/2 ebif_ets_info_2 +bif ets:last/1 +bif 'erl.lang.ets':last/1 ebif_ets_last_1 +bif ets:match/1 +bif 'erl.lang.ets':match/1 ebif_ets_match_1 +bif ets:match/2 +bif 'erl.lang.ets':match/2 ebif_ets_match_2 +bif ets:match/3 +bif 'erl.lang.ets':match/3 ebif_ets_match_3 +bif ets:match_object/1 +bif 'erl.lang.ets':match_object/1 ebif_ets_match_object_1 +bif ets:match_object/2 +bif 'erl.lang.ets':match_object/2 ebif_ets_match_object_2 +bif ets:match_object/3 +bif 'erl.lang.ets':match_object/3 ebif_ets_match_object_3 +bif ets:member/2 +bif 'erl.lang.ets':is_key/2 ebif_ets_member_2 +bif ets:next/2 +bif 'erl.lang.ets':next/2 ebif_ets_next_2 +bif ets:prev/2 +bif 'erl.lang.ets':prev/2 ebif_ets_prev_2 +bif ets:insert/2 +bif 'erl.lang.ets':insert/2 ebif_ets_insert_2 +bif ets:insert_new/2 +bif 'erl.lang.ets':insert_new/2 ebif_ets_insert_new_2 +bif ets:rename/2 +bif 'erl.lang.ets':rename/2 ebif_ets_rename_2 +bif ets:safe_fixtable/2 +bif 'erl.lang.ets':fixtable/2 ebif_ets_safe_fixtable_2 +bif ets:slot/2 +bif 'erl.lang.ets':slot/2 ebif_ets_slot_2 +bif ets:update_counter/3 +bif 'erl.lang.ets':update_counter/3 ebif_ets_update_counter_3 +bif ets:select/1 +bif 'erl.lang.ets':select/1 ebif_ets_select_1 +bif ets:select/2 +bif 'erl.lang.ets':select/2 ebif_ets_select_2 +bif ets:select/3 +bif 'erl.lang.ets':select/3 ebif_ets_select_3 +bif ets:select_count/2 +bif 'erl.lang.ets':select/2 ebif_ets_select_count_2 +bif ets:select_reverse/1 +bif 'erl.lang.ets':select_reverse/1 ebif_ets_select_reverse_1 +bif ets:select_reverse/2 +bif 'erl.lang.ets':select_reverse/2 ebif_ets_select_reverse_2 +bif ets:select_reverse/3 +bif 'erl.lang.ets':select_reverse/3 ebif_ets_select_reverse_3 +bif ets:select_delete/2 +bif 'erl.lang.ets':select_delete/2 ebif_ets_select_delete_2 +bif ets:match_spec_compile/1 +bif 'erl.lang.ets':match_spec_compile/1 ebif_ets_match_spec_compile_1 +bif ets:match_spec_run_r/3 +bif 'erl.lang.ets':match_spec_run_r/3 ebif_ets_match_spec_run_r_3 + +# +# Bifs in os module. +# + +bif os:putenv/2 +bif 'erl.system.os':setenv/2 ebif_os_setenv_2 os_putenv_2 +bif os:getenv/0 +bif 'erl.system.os':getenv/0 ebif_os_getenv_0 +bif os:getenv/1 +bif 'erl.system.os':getenv/1 ebif_os_getenv_1 +bif os:getpid/0 +bif 'erl.system.os':pid/0 ebif_os_pid_0 os_getpid_0 +bif os:timestamp/0 +bif 'erl.system.os':timestamp/0 ebif_os_timestamp_0 os_timestamp_0 + +# +# Bifs in the erl_ddll module (the module actually does not exist) +# + +bif erl_ddll:try_load/3 +bif erl_ddll:try_unload/2 +bif erl_ddll:loaded_drivers/0 +bif erl_ddll:info/2 +bif erl_ddll:format_error_int/1 +bif erl_ddll:monitor/2 +bif erl_ddll:demonitor/1 + +# +# Bifs in the re module +# +bif re:compile/1 +bif re:compile/2 +bif re:run/2 +bif re:run/3 + +# +# Bifs in lists module. +# + +bif lists:member/2 +bif 'erl.lang.list':is_element/2 ebif_list_is_element_2 lists_member_2 +bif lists:reverse/2 +bif 'erl.lang.list':reverse/2 ebif_list_reverse_2 lists_reverse_2 +bif lists:keymember/3 +bif 'erl.lang.list.keylist':is_element/3 ebif_keylist_is_element_3 lists_keymember_3 +bif lists:keysearch/3 +bif 'erl.lang.list.keylist':search/3 ebif_keylist_search_3 lists_keysearch_3 +bif lists:keyfind/3 + +# +# Bifs for debugging. +# + +bif erts_debug:disassemble/1 +bif 'erl.system.debug':disassemble/1 ebif_erts_debug_disassemble_1 +bif erts_debug:breakpoint/2 +bif 'erl.system.debug':breakpoint/2 ebif_erts_debug_breakpoint_2 +bif erts_debug:same/2 +bif 'erl.system.debug':same/2 ebif_erts_debug_same_2 +bif erts_debug:flat_size/1 +bif 'erl.system.debug':flat_size/1 ebif_erts_debug_flat_size_1 +bif erts_debug:get_internal_state/1 +bif 'erl.system.debug':get_internal_state/1 ebif_erts_debug_get_internal_state_1 +bif erts_debug:set_internal_state/2 +bif 'erl.system.debug':set_internal_state/2 ebif_erts_debug_set_internal_state_2 +bif erts_debug:display/1 +bif 'erl.system.debug':display/1 ebif_erts_debug_display_1 +bif erts_debug:dist_ext_to_term/2 +bif 'erl.system.debug':dist_ext_to_term/2 ebif_erts_debug_dist_ext_to_term_2 + +# +# Monitor testing bif's... +# +bif erts_debug:dump_monitors/1 +bif erts_debug:dump_links/1 + + +# +# Lock counter bif's +# +bif erts_debug:lock_counters/1 + +# +# New Bifs in R8. +# + +bif code:get_chunk/2 +bif 'erl.system.code':get_chunk/2 ebif_code_get_chunk_2 +bif code:module_md5/1 +bif 'erl.system.code':module_md5/1 ebif_code_module_md5_1 +bif code:make_stub_module/3 +bif 'erl.system.code':make_stub_module/3 ebif_code_make_stub_module_3 +bif code:is_module_native/1 +bif 'erl.system.code':is_native/1 ebif_code_is_native_1 code_is_module_native_1 + +bif erlang:blocking_read_file/1 + +# +# New Bifs in R9C. +# + +bif erlang:hibernate/3 +bif error_logger:warning_map/0 + +# +# New Bifs in R10B. +# +bif erlang:get_module_info/1 +bif erlang:get_module_info/2 +ubif erlang:is_boolean/1 +bif string:to_integer/1 +bif string:to_float/1 +bif erlang:make_fun/3 +bif erlang:iolist_size/1 +bif erlang:iolist_to_binary/1 +bif erlang:list_to_existing_atom/1 + +# +# New Bifs in R12B-0 +# +ubif erlang:is_bitstring/1 +ubif erlang:tuple_size/1 +ubif erlang:byte_size/1 +ubif erlang:bit_size/1 +bif erlang:list_to_bitstring/1 +bif erlang:bitstring_to_list/1 + +# +# New Bifs in R12B-2 +# +bif ets:update_element/3 + +# +# New Bifs in R12B-4 +# +bif erlang:decode_packet/3 + +# +# New Bifs in R12B-5 +# +bif unicode:characters_to_binary/2 +bif unicode:characters_to_list/2 +bif unicode:bin_is_7bit/1 +# +# New Bifs in R13A. +# +bif erlang:atom_to_binary/2 +bif erlang:binary_to_atom/2 +bif erlang:binary_to_existing_atom/2 +bif net_kernel:dflag_unicode_io/1 +# +# New Bifs in R13B-1 +# +bif ets:give_away/3 +bif ets:setopts/2 + +# +# New Bifs in R13B3 +# +bif erlang:load_nif/2 +bif erlang:call_on_load_function/1 +bif erlang:finish_after_on_load/2 + +# +# Obsolete +# + +bif erlang:hash/2 diff --git a/erts/emulator/beam/big.c b/erts/emulator/beam/big.c new file mode 100644 index 0000000000..03c88da8c6 --- /dev/null +++ b/erts/emulator/beam/big.c @@ -0,0 +1,2241 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "big.h" +#include "error.h" +#include "bif.h" + +#define ZERO_DIGITS(v, sz) do { \ + dsize_t _t_sz = sz; \ + ErtsDigit* _t_v = v; \ + while(_t_sz--) *_t_v++ = 0; \ + } while(0) + +#define MOVE_DIGITS(dst, src, sz) do { \ + dsize_t _t_sz = sz; \ + ErtsDigit* _t_dst; \ + ErtsDigit* _t_src; \ + if (dst < src) { \ + _t_dst = dst; \ + _t_src = src; \ + while(_t_sz--) *_t_dst++ = *_t_src++; \ + } \ + else if (dst > src) { \ + _t_dst = (dst)+((sz)-1); \ + _t_src = (src)+((sz)-1); \ + while(_t_sz--) *_t_dst-- = *_t_src--; \ + } \ + } while(0) + +/* add a and b with carry in + out */ +#define DSUMc(a,b,c,s) do { \ + ErtsDigit ___cr = (c); \ + ErtsDigit ___xr = (a)+(___cr); \ + ErtsDigit ___yr = (b); \ + ___cr = (___xr < ___cr); \ + ___xr = ___yr + ___xr; \ + ___cr += (___xr < ___yr); \ + s = ___xr; \ + c = ___cr; \ + } while(0) + +/* add a and b with carry out */ +#define DSUM(a,b,c,s) do { \ + ErtsDigit ___xr = (a); \ + ErtsDigit ___yr = (b); \ + ___xr = ___yr + ___xr; \ + s = ___xr; \ + c = (___xr < ___yr); \ + } while(0) + +#define DSUBb(a,b,r,d) do { \ + ErtsDigit ___cr = (r); \ + ErtsDigit ___xr = (a); \ + ErtsDigit ___yr = (b)+___cr; \ + ___cr = (___yr < ___cr); \ + ___yr = ___xr - ___yr; \ + ___cr += (___yr > ___xr); \ + d = ___yr; \ + r = ___cr; \ + } while(0) + +#define DSUB(a,b,r,d) do { \ + ErtsDigit ___xr = (a); \ + ErtsDigit ___yr = (b); \ + ___yr = ___xr - ___yr; \ + r = (___yr > ___xr); \ + d = ___yr; \ + } while(0) + +/* type a constant as a ErtsDigit - to get shifts correct */ +#define DCONST(n) ((ErtsDigit)(n)) + +/* + * BIG_HAVE_DOUBLE_DIGIT is defined if we have defined + * the type ErtsDoubleDigit which MUST have + * sizeof(ErtsDoubleDigit) >= sizeof(ErtsDigit) + */ +#ifdef BIG_HAVE_DOUBLE_DIGIT + +/* ErtsDoubleDigit => ErtsDigit */ +#define DLOW(x) ((ErtsDigit)(x)) +#define DHIGH(x) ((ErtsDigit)(((ErtsDoubleDigit)(x)) >> D_EXP)) + +/* ErtsDigit => ErtsDoubleDigit */ +#define DLOW2HIGH(x) (((ErtsDoubleDigit)(x)) << D_EXP) +#define DDIGIT(a1,a0) (DLOW2HIGH(a1) + (a0)) + +#define DMULc(a,b,c,p) do { \ + ErtsDoubleDigit _t = ((ErtsDoubleDigit)(a))*(b) + (c); \ + p = DLOW(_t); \ + c = DHIGH(_t); \ + } while(0) +#define DMUL(a,b,c1,c0) do { \ + ErtsDoubleDigit _t = ((ErtsDoubleDigit)(a))*(b); \ + c0 = DLOW(_t); \ + c1 = DHIGH(_t); \ + } while(0) + +#define DDIV(a1,a0,b,q) do { \ + ErtsDoubleDigit _t = DDIGIT((a1),(a0)); \ + q = _t / (b); \ + } while(0) + +#define DDIV2(a1,a0,b1,b0,q) do { \ + ErtsDoubleDigit _t = DDIGIT((a1),(a0)); \ + q = _t / DDIGIT((b1),(b0)); \ + } while(0) + +#define DREM(a1,a0,b,r) do { \ + ErtsDoubleDigit _t = DDIGIT((a1),(a0)); \ + r = _t % (b); \ + } while(0) + +#else + +/* If we do not have double digit then we have some more work to do */ +#define H_EXP (D_EXP >> 1) +#define LO_MASK ((ErtsDigit)((DCONST(1) << H_EXP)-1)) +#define HI_MASK ((ErtsDigit)(LO_MASK << H_EXP)) + +#define DGT(a,b) ((a)>(b)) +#define DEQ(a,b) ((a)==(b)) + +#define D2GT(a1,a0,b1,b0) (DGT(a1,b1) || (((a1)==(b1)) && DGT(a0,b0))) +#define D2EQ(a1,a0,b1,b0) (DEQ(a1,b1) && DEQ(a0,b0)) +#define D2LT(a1,a0,b1,b0) D2GT(b1,b0,a1,a0) +#define D2GTE(a1,a0,b1,b0) (!D2LT(a1,a0,b1,b0)) +#define D2LTE(a1,a0,b1,b0) (!D2GT(a1,a0,b1,b0)) + +// Add (A+B), A=(a1B+a0) B=(b1B+b0) +#define D2ADD(a1,a0,b1,b0,c1,c0) do { \ + ErtsDigit __ci = 0; \ + DSUM(a0,b0,__ci,c0); \ + DSUMc(a1,b1,__ci,c1); \ + } while(0) + +// Subtract (A-B), A=(a1B+a0), B=(b1B+b0) (A>=B) +#define D2SUB(a1,a0,b1,b0,c1,c0) do { \ + ErtsDigit __bi; \ + DSUB(a0,b0,__bi,c0); \ + DSUBb(a1,b1,__bi,c1); \ + } while(0) + + +/* Left shift (multiply by 2) (A <<= 1 where A=a1*B+a0) */ +#define D2LSHIFT1(a1,a0) do { \ + a1 = ((a0) >> (D_EXP-1)) | ((a1)<<1); \ + a0 = (a0) << 1; \ + } while(0) + +/* Right shift (divide by 2) (A >>= 1 where A=a1*B+a0) */ +#define D2RSHIFT1(a1,a0) do { \ + a0 = (((a1) & 1) << (D_EXP-1)) | ((a0)>>1); \ + a1 = ((a1) >> 1); \ + } while(0) + +/* Calculate a*b + d1 and store double prec result in d1, d0 */ +#define DMULc(a,b,d1,d0) do { \ + ErtsHalfDigit __a0 = (a); \ + ErtsHalfDigit __a1 = ((a) >> H_EXP); \ + ErtsHalfDigit __b0 = (b); \ + ErtsHalfDigit __b1 = ((b) >> H_EXP); \ + ErtsDigit __a0b0 = (ErtsDigit)__a0*__b0; \ + ErtsDigit __a0b1 = (ErtsDigit)__a0*__b1; \ + ErtsDigit __a1b0 = (ErtsDigit)__a1*__b0; \ + ErtsDigit __a1b1 = (ErtsDigit)__a1*__b1; \ + ErtsDigit __p0,__p1,__p2,__c0; \ + DSUM(__a0b0,d1,__c0,__p0); \ + DSUM((__c0<>H_EXP),__p2,__p1); \ + DSUM(__p1,__a0b1,__c0,__p1); \ + __p2 += __c0; \ + DSUM(__p1,__a1b0,__c0,__p1); \ + __p2 += __c0; \ + DSUM(__p1,__a1b1<> H_EXP); \ + d0 = (__p1 << H_EXP) | (__p0 & LO_MASK); \ + } while(0) + +#define DMUL(a,b,d1,d0) do { \ + ErtsDigit _ds = 0; \ + DMULc(a,b,_ds,d0); \ + d1 = _ds; \ + } while(0) + +/* Calculate a*(Bb1 + b0) + d2 = a*b1B + a*b0 + d2 */ +#define D2MULc(a,b1,b0,d2,d1,d0) do { \ + DMULc(a, b0, d2, d0); \ + DMULc(a, b1, d2, d1); \ + } while(0) + +/* Calculate s in a = 2^s*a1 */ +/* NOTE since D2PF is used by other macros variables is prefixed bt __ */ +#if D_EXP == 64 +#define D2PF(a, s) do { \ + ErtsDigit __x = (a); \ + int __s = 0; \ + if (__x <= 0x00000000FFFFFFFF) { __s += 32; __x <<= 32; } \ + if (__x <= 0x0000FFFFFFFFFFFF) { __s += 16; __x <<= 16; } \ + if (__x <= 0x00FFFFFFFFFFFFFF) { __s += 8; __x <<= 8; } \ + if (__x <= 0x0FFFFFFFFFFFFFFF) { __s += 4; __x <<= 4; } \ + if (__x <= 0x3FFFFFFFFFFFFFFF) { __s += 2; __x <<= 2; } \ + if (__x <= 0x7FFFFFFFFFFFFFFF) { __s += 1; } \ + s = __s; \ + } while(0) +#elif D_EXP == 32 +#define D2PF(a, s) do { \ + ErtsDigit __x = (a); \ + int __s = 0; \ + if (__x <= 0x0000FFFF) { __s += 16; __x <<= 16; } \ + if (__x <= 0x00FFFFFF) { __s += 8; __x <<= 8; } \ + if (__x <= 0x0FFFFFFF) { __s += 4; __x <<= 4; } \ + if (__x <= 0x3FFFFFFF) { __s += 2; __x <<= 2; } \ + if (__x <= 0x7FFFFFFF) { __s += 1; } \ + s = __s; \ + } while(0) +#elif D_EXP == 16 +#define D2PF(a, s) do { \ + ErtsDigit __x = (a); \ + int __s = 0; \ + if (__x <= 0x00FF) { __s += 8; __x <<= 8; } \ + if (__x <= 0x0FFF) { __s += 4; __x <<= 4; } \ + if (__x <= 0x3FFF) { __s += 2; __x <<= 2; } \ + if (__x <= 0x7FFF) { __s += 1; } \ + s = __s; \ + } while(0) +#elif D_EXP == 8 +#define D2PF(a, s) do { \ + ErtsDigit __x = (a); \ + int __s = 0; \ + if (__x <= 0x0F) { __s += 4; __x <<= 4; } \ + if (__x <= 0x3F) { __s += 2; __x <<= 2; } \ + if (__x <= 0x7F) { __s += 1; } \ + s = _s; \ + } while(0) +#endif + +/* Calculate q = (a1B + a0) / b, assume a1 < b */ +#define DDIVREM(a1,a0,b,q,r) do { \ + ErtsDigit _a1 = (a1); \ + ErtsDigit _a0 = (a0); \ + ErtsDigit _b = (b); \ + ErtsHalfDigit _un1, _un0; \ + ErtsHalfDigit _vn1, _vn0; \ + ErtsDigit _q1, _q0; \ + ErtsDigit _un32, _un21, _un10; \ + ErtsDigit _rh; \ + Sint _s; \ + D2PF(_b, _s); \ + _b = _b << _s; \ + _vn1 = _b >> H_EXP; \ + _vn0 = _b & LO_MASK; \ + _un32 = (_a1 << _s) | ((_a0>>(D_EXP-_s)) & (-_s >> (D_EXP-1))); \ + _un10 = _a0 << _s; \ + _un1 = _un10 >> H_EXP; \ + _un0 = _un10 & LO_MASK; \ + _q1 = _un32/_vn1; \ + _rh = _un32 - _q1*_vn1; \ + while ((_q1 >= (DCONST(1)< (_rh<= (DCONST(1)<= (DCONST(1)< ((_rh<= (DCONST(1)<> _s; \ + q = (_q1<= B */ +#if (SIZEOF_VOID_P == 8) +#define QUOT_LIM 0x7FFFFFFFFFFFFFFF +#else +#define QUOT_LIM 0x7FFFFFFF +#endif + +#define D2DIVREM(a1,a0,b1,b0,q0,r1,r0) do { \ + ErtsDigit _a1 = (a1); \ + ErtsDigit _a0 = (a0); \ + ErtsDigit _b1 = (b1); \ + ErtsDigit _b0 = (b0); \ + ErtsDigit _q = 0; \ + int _as = 1; \ + while(D2GTE(_a1,_a0,_b1,_b0)) { \ + ErtsDigit _q1; \ + ErtsDigit _t2=0, _t1, _t0; \ + if ((_b1 == 1) && (_a1 > 1)) \ + _q1 = _a1 / 2; \ + else if ((_a1 > QUOT_LIM) && (_b1 < _a1)) \ + _q1 = _a1/(_b1+1); \ + else \ + _q1 = _a1/_b1; \ + if (_as<0) \ + _q -= _q1; \ + else \ + _q += _q1; \ + D2MULc(_q1, _b1, _b0, _t2, _t1, _t0); \ + ASSERT(_t2 == 0); \ + if (D2GT(_t1,_t0,_a1,_a0)) { \ + D2SUB(_t1,_t0,_a1,_a0,_a1,_a0); \ + _as = -_as; \ + } \ + else { \ + D2SUB(_a1,_a0,_t1,_t0,_a1,_a0); \ + } \ + } \ + if (_as < 0) { \ + _q--; \ + D2SUB(_b1,_b0,_a1,_a0,_a1,_a0); \ + } \ + q0 = _q; \ + r1 = _a1; \ + r0 = _a0; \ + } while(0) + + +/* Calculate q, r A = Bq+R when assume B>0 */ +#define D2DIVREM_0(a1,a0,b1,b0,q1,q0,r1,r0) do { \ + ErtsDigit _a1 = (a1); \ + ErtsDigit _a0 = (a0); \ + ErtsDigit _b1 = (b1); \ + ErtsDigit _b0 = (b0); \ + if (D2EQ(_a1,_a0,0,0)) { \ + q1 = q0 = 0; \ + r1 = r0 = 0; \ + } \ + else { \ + ErtsDigit _res1 = 0; \ + ErtsDigit _res0 = 0; \ + ErtsDigit _d1 = 0; \ + ErtsDigit _d0 = 1; \ + ErtsDigit _e1 = (1 << (D_EXP-1)); \ + ErtsDigit _e0 = 0; \ + while(_e1 && !(_a1 & _e1)) \ + _e1 >>= 1; \ + if (_e1 == 0) { \ + _e0 = (1 << (D_EXP-1)); \ + while(_e0 && !(_a0 & _e0)) \ + _e0 >>= 1; \ + } \ + if (D2GT(_b1,_b0,0,0)) { \ + while(D2GT(_e1,_e0,_b1,_b0)) { \ + D2LSHIFT1(_b1,_b0); \ + D2LSHIFT1(_d1,_d0); \ + } \ + } \ + do { \ + if (!D2GT(_b1,_b0,_a1,_a0)) { \ + D2SUB(_a1,_a0, _b1, _b0, _a1, _a0); \ + D2ADD(_d1,_d0, _res1,_res0, _res1, _res0); \ + } \ + D2RSHIFT1(_b1,_b0); \ + D2RSHIFT1(_d1,_d0); \ + } while (!D2EQ(_d1,_d0,0,0)); \ + r1 = _a1; \ + r0 = _a0; \ + q1 = _res1; \ + q0 = _res0; \ + } \ + } while(0) + +#define DDIV2(a1,a0,b1,b0,q) do { \ + ErtsDigit _tmp_r1; \ + ErtsDigit _tmp_r0; \ + D2DIVREM(a1,a0,b1,b0,q,_tmp_r1,_tmp_r0); \ + } while(0) + +#endif + +/* +** compare two number vectors +*/ +static int I_comp(ErtsDigit* x, dsize_t xl, ErtsDigit* y, dsize_t yl) +{ + if (xl < yl) + return -1; + else if (xl > yl) + return 1; + else { + if (x == y) + return 0; + x += (xl-1); + y += (yl-1); + while((xl > 0) && (*x == *y)) { + x--; + y--; + xl--; + } + if (xl == 0) + return 0; + return (*x < *y) ? -1 : 1; + } +} + +/* +** Add digits in x and y and store them in r +** assumption: (xl >= yl) +*/ +static dsize_t I_add(ErtsDigit* x, dsize_t xl, ErtsDigit* y, dsize_t yl, ErtsDigit* r) +{ + dsize_t sz = xl; + register ErtsDigit yr, xr; + register ErtsDigit c = 0; + + ASSERT(xl >= yl); + + xl -= yl; + do { + xr = *x++ + c; + yr = *y++; + c = (xr < c); + xr = yr + xr; + c += (xr < yr); + *r++ = xr; + } while(--yl); + + while(xl--) { + xr = *x++ + c; + c = (xr < c); + *r++ = xr; + } + if (c) { + *r = 1; + return sz+1; + } + return sz; +} +/* +** Add a digits in v1 and store result in vr +*/ +static dsize_t D_add(ErtsDigit* x, dsize_t xl, ErtsDigit c, ErtsDigit* r) +{ + dsize_t sz = xl; + register ErtsDigit xr; + + while(xl--) { + xr = *x++ + c; + c = (xr < c); + *r++ = xr; + } + if (c) { + *r = 1; + return sz+1; + } + return sz; +} + +/* +** Subtract digits v2 from v1 and store result in v3 +** Assert I_comp(x, xl, y, yl) >= 0 +** +*/ +static dsize_t I_sub(ErtsDigit* x, dsize_t xl, ErtsDigit* y, dsize_t yl, ErtsDigit* r) +{ + ErtsDigit* r0 = r; + register ErtsDigit yr, xr; + register ErtsDigit c = 0; + + ASSERT(I_comp(x, xl, y, yl) >= 0); + + xl -= yl; + do { + yr = *y++ + c; + xr = *x++; + c = (yr < c); + yr = xr - yr; + c += (yr > xr); + *r++ = yr; + } while(--yl); + + while(xl--) { + xr = *x++; + yr = xr - c; + c = (yr > xr); + *r++ = yr; + } + do { + r--; + } while(*r == 0 && r != r0); + + return (r - r0) + 1; +} + +/* +** Subtract digit d from v1 and store result in vr +*/ +static dsize_t D_sub(ErtsDigit* x, dsize_t xl, ErtsDigit c, ErtsDigit* r) +{ + ErtsDigit* r0 = r; + register ErtsDigit yr, xr; + + ASSERT(I_comp(x, xl, x, 1) >= 0); + + while(xl--) { + xr = *x++; + yr = xr - c; + c = (yr > xr); + *r++ = yr; + } + do { + r--; + } while(*r == 0 && r != r0); + + return (r - r0) + 1; +} + +/* +** subtract Z000...0 - y and store result in r, return new size +*/ +static dsize_t Z_sub(ErtsDigit* y, dsize_t yl, ErtsDigit* r) +{ + ErtsDigit* r0 = r; + register ErtsDigit yr; + register ErtsDigit c = 0; + + while(yl--) { + yr = *y++ + c; + c = (yr < c); + yr = 0 - yr; + c += (yr > 0); + *r++ = yr; + } + do { + r--; + } while(*r == 0 && r != r0); + return (r - r0) + 1; +} + +/* +** Multiply digits in x with digits in y and store in r +** Assumption: digits in r must be 0 (upto the size of x) +*/ +static dsize_t I_mul(ErtsDigit* x, dsize_t xl, ErtsDigit* y, dsize_t yl, ErtsDigit* r) +{ + ErtsDigit* r0 = r; + ErtsDigit* rt = r; + + while(xl--) { + ErtsDigit cp = 0; + ErtsDigit c = 0; + dsize_t n = yl; + ErtsDigit* yt = y; + ErtsDigit d; + ErtsDigit p; + + d = *x; + x++; + rt = r; + + switch(d) { + case 0: + rt = rt + n; + break; + case 1: + while(n--) { + DSUMc(*yt, *rt, c, p); + *rt++ = p; + yt++; + } + break; + case 2: + while(n--) { + p = *yt; + DSUMc(p, p, cp, p); + DSUMc(p, *rt, c, p); + *rt++ = p; + yt++; + } + break; + default: + while(n--) { + DMULc(d,*yt, cp, p); + DSUMc(p,*rt, c, p); + *rt++ = p; + yt++; + } + break; + } + *rt = c + cp; + r++; + } + if (*rt == 0) + return (rt - r0); + else + return (rt - r0) + 1; +} + +/* +** Square digits in x store in r (x & r may point into a common area) +** Assumption: x is destroyed if common area and digits in r are zero +** to the size of xl+1 +*/ + +static dsize_t I_sqr(ErtsDigit* x, dsize_t xl, ErtsDigit* r) +{ + ErtsDigit d_next = *x; + ErtsDigit d; + ErtsDigit* r0 = r; + ErtsDigit* s = r; + + if ((r + xl) == x) /* "Inline" operation */ + *x = 0; + x++; + + while(xl--) { + ErtsDigit* y = x; + ErtsDigit y_0 = 0, y_1 = 0, y_2 = 0, y_3 = 0; + ErtsDigit b0, b1; + ErtsDigit z0, z1, z2; + ErtsDigit t; + dsize_t y_l = xl; + + s = r; + d = d_next; + d_next = *x; + x++; + + DMUL(d, d, b1, b0); + DSUMc(*s, b0, y_3, t); + *s++ = t; + z1 = b1; + while(y_l--) { + DMUL(d, *y, b1, b0); + y++; + DSUMc(b0, b0, y_0, z0); + DSUMc(z0, z1, y_2, z2); + DSUMc(*s, z2, y_3, t); + *s++ = t; + DSUMc(b1, b1, y_1, z1); + } + z0 = y_0; + DSUMc(z0, z1, y_2, z2); + DSUMc(*s, z2, y_3, t); + *s = t; + if (xl != 0) { + s++; + t = (y_1+y_2+y_3); + *s = t; + r += 2; + } + else { + ASSERT((y_1+y_2+y_3) == 0); + } + } + if (*s == 0) + return (s - r0); + else + return (s - r0) + 1; +} + + +/* +** Multiply digits d with digits in x and store in r +*/ +static dsize_t D_mul(ErtsDigit* x, dsize_t xl, ErtsDigit d, ErtsDigit* r) +{ + ErtsDigit c = 0; + dsize_t rl = xl; + ErtsDigit p; + + switch(d) { + case 0: + ZERO_DIGITS(r, 1); + return 1; + case 1: + if (x != r) + MOVE_DIGITS(r, x, xl); + return xl; + case 2: + while(xl--) { + p = *x; + DSUMc(p, p, c, p); + *r++ = p; + x++; + } + break; + default: + while(xl--) { + DMULc(d, *x, c, p); + *r++ = p; + x++; + } + break; + } + if (c == 0) + return rl; + *r = c; + return rl+1; +} + +/* +** Multiply and subtract +** calculate r(i) = x(i) - d*y(i) +** assumption: xl = yl || xl == yl+1 +** +** Return size of r +** 0 means borrow +*/ +static dsize_t D_mulsub(ErtsDigit* x, dsize_t xl, ErtsDigit d, + ErtsDigit* y, dsize_t yl, ErtsDigit* r) +{ + ErtsDigit c = 0; + ErtsDigit b = 0; + ErtsDigit c0; + ErtsDigit* r0 = r; + ErtsDigit s; + + ASSERT(xl == yl || xl == yl+1); + + xl -= yl; + while(yl--) { + DMULc(d, *y, c, c0); + DSUBb(*x, c0, b, s); + *r++ = s; + x++; + y++; + } + if (xl == 0) { + if (c != 0 || b != 0) + return 0; + } + else { /* xl == 1 */ + DSUBb(*x, c, b, s); + *r++ = s; + } + if (b != 0) return 0; + + do { + r--; + } while(*r == 0 && r != r0); + return (r - r0) + 1; +} + +/* +** Divide digits in x with a digit, +** quotient is returned in q and remainder digit in r +** x and q may be equal +*/ +static dsize_t D_div(ErtsDigit* x, dsize_t xl, ErtsDigit d, ErtsDigit* q, ErtsDigit* r) +{ + ErtsDigit* xp = x + (xl-1); + ErtsDigit* qp = q + (xl-1); + dsize_t qsz = xl; + ErtsDigit a1; + + a1 = *xp; + xp--; + + if (d > a1) { + if (xl == 1) { + *r = a1; + *qp = 0; + return 1; + } + qsz--; + qp--; + } + + do { + ErtsDigit q0, a0, b1, b0, b; + + if (d > a1) { + a0 = *xp; + xp--; + } + else { + a0 = a1; a1 = 0; + } + DDIV(a1, a0, d, q0); + DMUL(d, q0, b1, b0); + DSUB(a0,b0, b, a1); + *qp = q0; + qp--; + } while (xp >= x); + + *r = a1; + return qsz; +} + +/* +** Divide digits in x with digits in y and return qutient in q +** and remainder in r +** assume that integer(x) > integer(y) +** Return remainder in x (length int rl) +** Return quotient size +*/ + +static dsize_t I_div(ErtsDigit* x, dsize_t xl, ErtsDigit* y, dsize_t yl, + ErtsDigit* q, ErtsDigit* r, dsize_t* rlp) +{ + ErtsDigit* rp; + ErtsDigit* qp; + ErtsDigit b1 = y[yl-1]; + ErtsDigit b2 = y[yl-2]; + ErtsDigit a1; + ErtsDigit a2; + int r_signed = 0; + dsize_t ql; + dsize_t rl; + + if (x != r) + MOVE_DIGITS(r, x, xl); + rp = r + (xl-yl); + rl = xl; + + ZERO_DIGITS(q, xl-yl+1); + qp = q + (xl-yl); + ql = 0; + + /* Adjust length */ + a1 = rp[yl-1]; + a2 = rp[yl-2]; + if (b1 < a1 || (b1 == a1 && b2 <= a2)) + ql = 1; + + do { + ErtsDigit q0; + dsize_t nsz = yl; + dsize_t nnsz; + + a1 = rp[yl-1]; + a2 = rp[yl-2]; + + if (b1 < a1) + DDIV2(a1,a2,b1,b2,q0); + else if (b1 > a1) { + DDIV(a1,a2,b1,q0); + nsz++; + rp--; + qp--; + ql++; + } + else { /* (b1 == a1) */ + if (b2 <= a2) + q0 = 1; + else { + q0 = D_MASK; + nsz++; + rp--; + qp--; + ql++; + } + } + + if (r_signed) + ql = D_sub(qp, ql, q0, qp); + else + ql = D_add(qp, ql, q0, qp); + + if ((nnsz = D_mulsub(rp, nsz, q0, y, yl, rp)) == 0) { + nnsz = Z_sub(r, rl, r); + if (nsz > (rl-nnsz)) + nnsz = nsz - (rl-nnsz); + else + nnsz = 1; + r_signed = !r_signed; + } + + if ((nnsz == 1) && (*rp == 0)) + nnsz = 0; + rp = rp - (yl-nnsz); + rl -= (nsz-nnsz); + qp = qp - (yl-nnsz); + ql += (yl-nnsz); + } while (I_comp(r, rl, y, yl) >= 0); + + ql -= (q - qp); + qp = q; + + if (rl == 0) + rl = 1; + + while(rl > 1 && r[rl-1] == 0) /* Remove "trailing zeroes" */ + --rl; + + if (r_signed && (rl > 1 || *r != 0)) { + rl = I_sub(y, yl, r, rl, r); + ql = D_sub(qp, ql, 1, qp); + } + + *rlp = rl; + return ql; +} + +/* +** Remainder of digits in x and a digit d +*/ +static ErtsDigit D_rem(ErtsDigit* x, dsize_t xl, ErtsDigit d) +{ + ErtsDigit rem = 0; + + x += (xl-1); + do { + if (rem != 0) + DREM(rem, *x, d, rem); + else + DREM(0, *x, d, rem); + x--; + xl--; + } while(xl > 0); + return rem; +} + +/* +** Remainder of x and y +** +** Assumtions: xl >= yl, yl > 1 +** r must contain at least xl number of digits +*/ +static dsize_t I_rem(ErtsDigit* x, dsize_t xl, ErtsDigit* y, dsize_t yl, ErtsDigit* r) +{ + ErtsDigit* rp; + ErtsDigit b1 = y[yl-1]; + ErtsDigit b2 = y[yl-2]; + ErtsDigit a1; + ErtsDigit a2; + int r_signed = 0; + dsize_t rl; + + if (x != r) + MOVE_DIGITS(r, x, xl); + rp = r + (xl-yl); + rl = xl; + + do { + ErtsDigit q0; + dsize_t nsz = yl; + dsize_t nnsz; + + a1 = rp[yl-1]; + a2 = rp[yl-2]; + + if (b1 < a1) + DDIV2(a1,a2,b1,b2,q0); + else if (b1 > a1) { + DDIV(a1,a2,b1,q0); + nsz++; + rp--; + } + else { /* (b1 == a1) */ + if (b2 <= a2) + q0 = 1; + else { + q0 = D_MASK; + nsz++; + rp--; + } + } + + if ((nnsz = D_mulsub(rp, nsz, q0, y, yl, rp)) == 0) { + nnsz = Z_sub(r, rl, r); + if (nsz > (rl-nnsz)) + nnsz = nsz - (rl-nnsz); + else + nnsz = 1; + r_signed = !r_signed; + } + + if (nnsz == 1 && *rp == 0) + nnsz = 0; + + rp = rp - (yl-nnsz); + rl -= (nsz-nnsz); + } while (I_comp(r, rl, y, yl) >= 0); + + if (rl == 0) + rl = 1; + + while(rl > 1 && r[rl-1] == 0) /* Remove "trailing zeroes" */ + --rl; + + if (r_signed && (rl > 1 || *r != 0)) + rl = I_sub(y, yl, r, rl, r); + return rl; +} + +/* +** Remove trailing digits from bitwise operations +*/ +static dsize_t I_btrail(ErtsDigit* r0, ErtsDigit* r, short sign) +{ + /* convert negative numbers to one complement */ + if (sign) { + dsize_t rl; + ErtsDigit d; + + /* 1 remove all 0xffff words */ + do { + r--; + } while(((d = *r) == D_MASK) && (r != r0)); + + /* 2 complement high digit */ + if (d == D_MASK) + *r = 0; + else { + ErtsDigit prev_mask = 0; + ErtsDigit mask = (DCONST(1) << (D_EXP-1)); + + while((d & mask) == mask) { + prev_mask = mask; + mask = (prev_mask >> 1) | (DCONST(1)<<(D_EXP-1)); + } + *r = ~d & ~prev_mask; + } + rl = (r - r0) + 1; + while(r != r0) { + r--; + *r = ~*r; + } + return D_add(r0, rl, 1, r0); + } + + do { + r--; + } while(*r == 0 && r != r0); + return (r - r0) + 1; +} + +/* +** Bitwise and +*/ +static dsize_t I_band(ErtsDigit* x, dsize_t xl, short xsgn, + ErtsDigit* y, dsize_t yl, short ysgn, ErtsDigit* r) +{ + ErtsDigit* r0 = r; + short sign = xsgn && ysgn; + + ASSERT(xl >= yl); + + xl -= yl; + + if (!xsgn) { + if (!ysgn) { + while(yl--) + *r++ = *x++ & *y++; + } + else { + ErtsDigit b; + ErtsDigit c; + + DSUB(*y,1,b,c); + *r++ = *x++ & ~c; + y++; + yl--; + while(yl--) { + DSUBb(*y,0,b,c); + *r++ = *x++ & ~c; + y++; + } + while (xl--) { + *r++ = *x++; + } + } + } + else { + if (!ysgn) { + ErtsDigit b; + ErtsDigit c; + + DSUB(*x,1,b,c); + *r = ~c & *y; + x++; y++; r++; + yl--; + while(yl--) { + DSUBb(*x,0,b,c); + *r++ = ~c & *y++; + x++; + } + } + else { + ErtsDigit b1, b2; + ErtsDigit c1, c2; + + DSUB(*x,1,b1,c1); + DSUB(*y,1,b2,c2); + *r++ = ~c1 & ~c2; + x++; y++; + yl--; + while(yl--) { + DSUBb(*x,0,b1,c1); + DSUBb(*y,0,b2,c2); + *r++ = ~c1 & ~c2; + x++; y++; + } + while(xl--) + *r++ = ~*x++; + } + } + return I_btrail(r0, r, sign); +} + +/* + * Bitwise 'or'. + */ +static dsize_t +I_bor(ErtsDigit* x, dsize_t xl, short xsgn, ErtsDigit* y, + dsize_t yl, short ysgn, ErtsDigit* r) +{ + ErtsDigit* r0 = r; + short sign = xsgn || ysgn; + + ASSERT(xl >= yl); + + xl -= yl; + + if (!xsgn) { + if (!ysgn) { + while(yl--) + *r++ = *x++ | *y++; + while(xl--) + *r++ = *x++; + } + else { + ErtsDigit b; + ErtsDigit c; + + DSUB(*y,1,b,c); + *r++ = *x++ | ~c; + y++; + yl--; + while(yl--) { + DSUBb(*y,0,b,c); + *r++ = *x++ | ~c; + y++; + } + } + } + else { + if (!ysgn) { + ErtsDigit b; + ErtsDigit c; + + DSUB(*x,1,b,c); + *r++ = ~c | *y++; + x++; + yl--; + while(yl--) { + DSUBb(*x,0,b,c); + *r++ = ~c | *y++; + x++; + } + while(xl--) { + DSUBb(*x,0,b,c); + *r++ = ~c; + x++; + } + } + else { + ErtsDigit b1, b2; + ErtsDigit c1, c2; + + DSUB(*x,1,b1,c1); + DSUB(*y,1,b2,c2); + *r++ = ~c1 | ~c2; + x++; y++; + yl--; + while(yl--) { + DSUBb(*x,0,b1,c1); + DSUBb(*y,0,b2,c2); + *r++ = ~c1 | ~c2; + x++; y++; + } + } + } + return I_btrail(r0, r, sign); +} + +/* +** Bitwise xor +*/ +static dsize_t I_bxor(ErtsDigit* x, dsize_t xl, short xsgn, + ErtsDigit* y, dsize_t yl, short ysgn, ErtsDigit* r) +{ + ErtsDigit* r0 = r; + short sign = xsgn != ysgn; + + ASSERT(xl >= yl); + + xl -= yl; + + if (!xsgn) { + if (!ysgn) { + while(yl--) + *r++ = *x++ ^ *y++; + while(xl--) + *r++ = *x++; + } + else { + ErtsDigit b; + ErtsDigit c; + + DSUB(*y,1,b,c); + *r++ = *x++ ^ ~c; + y++; + yl--; + while(yl--) { + DSUBb(*y,0,b,c); + *r++ = *x++ ^ ~c; + y++; + } + while(xl--) + *r++ = ~*x++; + } + } + else { + if (!ysgn) { + ErtsDigit b; + ErtsDigit c; + + DSUB(*x,1,b,c); + *r++ = ~c ^ *y++; + x++; + yl--; + while(yl--) { + DSUBb(*x,0,b,c); + *r++ = ~c ^ *y++; + x++; + } + while(xl--) + *r++ = ~*x++; + } + else { + ErtsDigit b1, b2; + ErtsDigit c1, c2; + + DSUB(*x,1,b1,c1); + DSUB(*y,1,b2,c2); + *r++ = ~c1 ^ ~c2; + x++; y++; + yl--; + while(yl--) { + DSUBb(*x,0,b1,c1); + DSUBb(*y,0,b2,c2); + *r++ = ~c1 ^ ~c2; + x++; y++; + } + while(xl--) { + *r++ = *x++; + } + } + } + return I_btrail(r0, r, sign); +} + +/* +** Bitwise not simulated as +** bnot -X == (X - 1) +** bnot +X == -(X + 1) +*/ +static dsize_t I_bnot(ErtsDigit* x, dsize_t xl, short xsgn, ErtsDigit* r) +{ + if (xsgn) + return D_add(x, xl, 1, r); + else + return D_sub(x, xl, 1, r); +} + +/* +** Arithmetic left shift or right +*/ +static dsize_t I_lshift(ErtsDigit* x, dsize_t xl, Sint y, + short sign, ErtsDigit* r) +{ + if (y == 0) { + MOVE_DIGITS(r, x, xl); + return xl; + } + else if (xl == 1 && *x == 0) { + *r = 0; + return 1; + } + else { + long ay = (y < 0) ? -y : y; + int bw = ay / D_EXP; + int sw = ay % D_EXP; + dsize_t rl; + ErtsDigit a1=0; + ErtsDigit a0=0; + + if (y > 0) { /* shift left */ + rl = xl + bw + 1; + + while(bw--) + *r++ = 0; + if (sw) { // NOTE! x >> 32 is not = 0! + while(xl--) { + a0 = (*x << sw) | a1; + a1 = (*x >> (D_EXP - sw)); + *r++ = a0; + x++; + } + } + else { + while(xl--) { + *r++ = *x++; + } + } + if (a1 == 0) + return rl-1; + *r = a1; + return rl; + } + else { /* shift right */ + ErtsDigit* r0 = r; + int add_one = 0; + + if (xl <= bw) { + if (sign) + *r = 1; + else + *r = 0; + return 1; + } + + if (sign) { + int zl = bw; + ErtsDigit* z = x; + + while(zl--) { + if (*z != 0) { + add_one = 1; + break; + } + z++; + } + } + + rl = xl - bw; + x += (xl-1); + r += (rl-1); + xl -= bw; + if (sw) { // NOTE! x >> 32 is not = 0! + while(xl--) { + a1 = (*x >> sw) | a0; + a0 = (*x << (D_EXP-sw)); + *r-- = a1; + x--; + } + } + else { + while(xl--) { + *r-- = *x--; + } + } + + if (sign && (a0 != 0)) + add_one = 1; + + if (r[rl] == 0) { + if (rl == 1) { + if (sign) + r[1] = 1; + return 1; + } + rl--; + } + if (add_one) + return D_add(r0, rl, 1, r0); + return rl; + } + } +} + +/* +** Return log(x)/log(2) +*/ +static int I_lg(ErtsDigit* x, dsize_t xl) +{ + dsize_t sz = xl - 1; + ErtsDigit d = x[sz]; + + sz *= D_EXP; + while(d != 0) { + d >>= 1; + sz++; + } + return sz - 1; +} + +/* +** Create bigint on heap if necessary. Like the previously existing +** make_small_or_big(), except for a HAlloc() instead of an +** ArithAlloc(). +** NOTE: Only use erts_make_integer(), when order of heap fragments is +** guaranteed to be correct. +*/ +Eterm +erts_make_integer(Uint x, Process *p) +{ + Eterm* hp; + if (IS_USMALL(0,x)) + return make_small(x); + else { + hp = HAlloc(p, BIG_UINT_HEAP_SIZE); + return uint_to_big(x,hp); + } +} + +/* +** convert Uint to bigint +** (must only be used if x is to big to be stored as a small) +*/ +Eterm uint_to_big(Uint x, Eterm *y) +{ + *y = make_pos_bignum_header(1); + BIG_DIGIT(y, 0) = x; + return make_big(y); +} + + +/* +** convert signed int to bigint +*/ +Eterm small_to_big(Sint x, Eterm *y) +{ + if (x >= 0) { + *y = make_pos_bignum_header(1); + } else { + x = -x; + *y = make_neg_bignum_header(1); + } + BIG_DIGIT(y, 0) = x; + return make_big(y); +} + + +Eterm erts_uint64_to_big(Uint64 x, Eterm **hpp) +{ + Eterm *hp = *hpp; +#ifdef ARCH_32 + if (x >= (((Uint64) 1) << 32)) { + *hp = make_pos_bignum_header(2); + BIG_DIGIT(hp, 0) = (Uint) (x & ((Uint) 0xffffffff)); + BIG_DIGIT(hp, 1) = (Uint) ((x >> 32) & ((Uint) 0xffffffff)); + *hpp += 2; + } + else +#endif + { + *hp = make_pos_bignum_header(1); + BIG_DIGIT(hp, 0) = (Uint) x; + *hpp += 1; + } + return make_big(hp); +} + +Eterm erts_sint64_to_big(Sint64 x, Eterm **hpp) +{ + Eterm *hp = *hpp; + int neg; + if (x >= 0) + neg = 0; + else { + neg = 1; + x = -x; + } +#ifdef ARCH_32 + if (x >= (((Uint64) 1) << 32)) { + if (neg) + *hp = make_neg_bignum_header(2); + else + *hp = make_pos_bignum_header(2); + BIG_DIGIT(hp, 0) = (Uint) (x & ((Uint) 0xffffffff)); + BIG_DIGIT(hp, 1) = (Uint) ((x >> 32) & ((Uint) 0xffffffff)); + *hpp += 2; + } + else +#endif + { + if (neg) + *hp = make_neg_bignum_header(1); + else + *hp = make_pos_bignum_header(1); + BIG_DIGIT(hp, 0) = (Uint) x; + *hpp += 1; + } + return make_big(hp); +} + +/* +** Convert a bignum to a double float +*/ +int +big_to_double(Eterm x, double* resp) +{ + double d = 0.0; + Eterm* xp = big_val(x); + dsize_t xl = BIG_SIZE(xp); + ErtsDigit* s = BIG_V(xp) + xl; + short xsgn = BIG_SIGN(xp); + double dbase = ((double)(D_MASK)+1); +#ifndef NO_FPE_SIGNALS + volatile unsigned long *fpexnp = erts_get_current_fp_exception(); +#endif + __ERTS_SAVE_FP_EXCEPTION(fpexnp); + + __ERTS_FP_CHECK_INIT(fpexnp); + while (xl--) { + d = d * dbase + *--s; + + __ERTS_FP_ERROR(fpexnp, d, __ERTS_RESTORE_FP_EXCEPTION(fpexnp); return -1); + } + + *resp = xsgn ? -d : d; + __ERTS_FP_ERROR(fpexnp,*resp,;); + __ERTS_RESTORE_FP_EXCEPTION(fpexnp); + return 0; +} + + +/* + ** Estimate the number of decimal digits (include sign) + */ +int big_decimal_estimate(Eterm x) +{ + Eterm* xp = big_val(x); + int lg = I_lg(BIG_V(xp), BIG_SIZE(xp)); + int lg10 = ((lg+1)*28/93)+1; + + if (BIG_SIGN(xp)) lg10++; /* add sign */ + return lg10+1; /* add null */ +} + +/* +** Convert a bignum into a string of decimal numbers +*/ + +static void write_big(Eterm x, void (*write_func)(void *, char), void *arg) +{ + Eterm* xp = big_val(x); + ErtsDigit* dx = BIG_V(xp); + dsize_t xl = BIG_SIZE(xp); + short sign = BIG_SIGN(xp); + ErtsDigit rem; + + if (xl == 1 && *dx < D_DECIMAL_BASE) { + rem = *dx; + if (rem == 0) + (*write_func)(arg, '0'); + else { + while(rem) { + (*write_func)(arg, (rem % 10) + '0'); + rem /= 10; + } + } + } + else { + ErtsDigit* tmp = (ErtsDigit*) erts_alloc(ERTS_ALC_T_TMP, + sizeof(ErtsDigit)*xl); + dsize_t tmpl = xl; + + MOVE_DIGITS(tmp, dx, xl); + + while(1) { + tmpl = D_div(tmp, tmpl, D_DECIMAL_BASE, tmp, &rem); + if (tmpl == 1 && *tmp == 0) { + while(rem) { + (*write_func)(arg, (rem % 10)+'0'); + rem /= 10; + } + break; + } + else { + int i = D_DECIMAL_EXP; + while(i--) { + (*write_func)(arg, (rem % 10)+'0'); + rem /= 10; + } + } + } + erts_free(ERTS_ALC_T_TMP, (void *) tmp); + } + + if (sign) + (*write_func)(arg, '-'); +} + +struct big_list__ { + Eterm *hp; + Eterm res; +}; + +static void +write_list(void *arg, char c) +{ + struct big_list__ *blp = (struct big_list__ *) arg; + blp->res = CONS(blp->hp, make_small(c), blp->res); + blp->hp += 2; +} + +Eterm erts_big_to_list(Eterm x, Eterm **hpp) +{ + struct big_list__ bl; + bl.hp = *hpp; + bl.res = NIL; + write_big(x, write_list, (void *) &bl); + *hpp = bl.hp; + return bl.res; +} + +static void +write_string(void *arg, char c) +{ + *(--(*((char **) arg))) = c; +} + +char *erts_big_to_string(Eterm x, char *buf, Uint buf_sz) +{ + char *big_str = buf + buf_sz - 1; + *big_str = '\0'; + write_big(x, write_string, (void *) &big_str); + ASSERT(buf <= big_str && big_str <= buf + buf_sz - 1); + return big_str; +} + +/* +** Normalize a bignum given thing pointer length in digits and a sign +** patch zero if odd length +*/ +static Eterm big_norm(Eterm *x, dsize_t xl, short sign) +{ + Uint arity; + + if (xl == 1) { + Uint y = BIG_DIGIT(x, 0); + + if (D_EXP < SMALL_BITS || IS_USMALL(sign, y)) { + if (sign) + return make_small(-((Sint)y)); + else + return make_small(y); + } + } + + /* __alpha__: This was fixed */ + if ((arity = BIG_NEED_SIZE(xl)-1) > BIG_ARITY_MAX) + return NIL; /* signal error (too big) */ + + if (sign) { + *x = make_neg_bignum_header(arity); + } + else { + *x = make_pos_bignum_header(arity); + } + return make_big(x); +} + +/* +** Compare bignums +*/ +int big_comp(Eterm x, Eterm y) +{ + Eterm* xp = big_val(x); + Eterm* yp = big_val(y); + + if (BIG_SIGN(xp) == BIG_SIGN(yp)) { + int c = I_comp(BIG_V(xp), BIG_SIZE(xp), BIG_V(yp), BIG_SIZE(yp)); + if (BIG_SIGN(xp)) + return -c; + else + return c; + } + else + return BIG_SIGN(xp) ? -1 : 1; +} + +/* +** Unsigned compare +*/ +int big_ucomp(Eterm x, Eterm y) +{ + Eterm* xp = big_val(x); + Eterm* yp = big_val(y); + + return I_comp(BIG_V(xp), BIG_SIZE(xp), BIG_V(yp), BIG_SIZE(yp)); +} + +/* +** Return number of bytes in the bignum +*/ +dsize_t big_bytes(Eterm x) +{ + Eterm* xp = big_val(x); + dsize_t sz = BIG_SIZE(xp); + ErtsDigit d = BIG_DIGIT(xp, sz-1); + + sz = (sz-1) * sizeof(ErtsDigit); + while (d != 0) { + ++sz; + d >>= 8; + } + return sz; +} + +/* +** Load a bignum from bytes +** xsz is the number of bytes in xp +*/ +Eterm bytes_to_big(byte *xp, dsize_t xsz, int xsgn, Eterm *r) +{ + ErtsDigit* rwp = BIG_V(r); + dsize_t rsz = 0; + ErtsDigit d; + int i; + + while(xsz >= sizeof(ErtsDigit)) { + d = 0; + for(i = sizeof(ErtsDigit); --i >= 0;) + d = (d << 8) | xp[i]; + *rwp = d; + rwp++; + xsz -= sizeof(ErtsDigit); + xp += sizeof(ErtsDigit); + rsz++; + } + + if (xsz > 0) { + d = 0; + for(i = xsz; --i >= 0;) + d = (d << 8) | xp[i]; + *rwp = d; + rwp++; + rsz++; + } + return big_norm(r, rsz, (short) xsgn); +} + +/* +** Store digits in the array of bytes pointed to by p +*/ +byte* big_to_bytes(Eterm x, byte *p) +{ + ErtsDigit* xr = big_v(x); + dsize_t xl = big_size(x); + ErtsDigit d; + int i; + + while(xl > 1) { + d = *xr; + xr++; + for(i = 0; i < sizeof(ErtsDigit); ++i) { + p[i] = d & 0xff; + d >>= 8; + } + p += sizeof(ErtsDigit); + xl--; + } + d = *xr; + do { + *p++ = d & 0xff; + d >>= 8; + } while (d != 0); + return p; +} + +/* + * Converts a positive term (small or bignum) to an Uint. + * + * Fails returning 0 if the term is neither a small nor a bignum, + * if it's negative, or the big number does not fit in an Uint; + * in addition the error reason, BADARG or SYSTEM_LIMIT, will be + * stored in *up. + * + * Otherwise returns a non-zero value and the converted number + * in *up. + */ + +int +term_to_Uint(Eterm term, Uint *up) +{ + if (is_small(term)) { + Sint i = signed_val(term); + if (i < 0) { + *up = BADARG; + return 0; + } + *up = (Uint) i; + return 1; + } else if (is_big(term)) { + ErtsDigit* xr = big_v(term); + dsize_t xl = big_size(term); + Uint uval = 0; + int n = 0; + + if (big_sign(term)) { + *up = BADARG; + return 0; + } else if (xl*D_EXP > sizeof(Uint)*8) { + *up = SYSTEM_LIMIT; + return 0; + } + while (xl-- > 0) { + uval |= ((Uint)(*xr++)) << n; + n += D_EXP; + } + *up = uval; + return 1; + } else { + *up = BADARG; + return 0; + } +} + +int term_to_Sint(Eterm term, Sint *sp) +{ + if (is_small(term)) { + *sp = signed_val(term); + return 1; + } else if (is_big(term)) { + ErtsDigit* xr = big_v(term); + dsize_t xl = big_size(term); + int sign = big_sign(term); + Uint uval = 0; + int n = 0; + + if (xl*D_EXP > sizeof(Uint)*8) { + return 0; + } + while (xl-- > 0) { + uval |= ((Uint)(*xr++)) << n; + n += D_EXP; + } + if (sign) { + uval = -uval; + if ((Sint)uval > 0) + return 0; + } else { + if ((Sint)uval < 0) + return 0; + } + *sp = uval; + return 1; + } else { + return 0; + } +} + +/* +** Add and subtract +*/ +static Eterm B_plus_minus(ErtsDigit *x, dsize_t xl, short xsgn, + ErtsDigit *y, dsize_t yl, short ysgn, Eterm *r) +{ + if (xsgn == ysgn) { + if (xl > yl) + return big_norm(r, I_add(x,xl,y,yl,BIG_V(r)), xsgn); + else + return big_norm(r, I_add(y,yl,x,xl,BIG_V(r)), xsgn); + } + else { + int comp = I_comp(x, xl, y, yl); + if (comp == 0) + return make_small(0); + else if (comp > 0) + return big_norm(r, I_sub(x,xl,y,yl,BIG_V(r)), xsgn); + else + return big_norm(r, I_sub(y,yl,x,xl,BIG_V(r)), ysgn); + } +} + +/* +** Add bignums +*/ +Eterm big_plus(Eterm x, Eterm y, Eterm *r) +{ + Eterm* xp = big_val(x); + Eterm* yp = big_val(y); + + return B_plus_minus(BIG_V(xp),BIG_SIZE(xp),(short) BIG_SIGN(xp), + BIG_V(yp),BIG_SIZE(yp),(short) BIG_SIGN(yp), r); +} + +/* +** Subtract bignums +*/ + +Eterm big_minus(Eterm x, Eterm y, Eterm *r) +{ + Eterm* xp = big_val(x); + Eterm* yp = big_val(y); + + return B_plus_minus(BIG_V(xp),BIG_SIZE(xp),(short) BIG_SIGN(xp), + BIG_V(yp),BIG_SIZE(yp),(short) !BIG_SIGN(yp), r); +} + +/* +** Subtract a digit from big number +*/ +Eterm big_minus_small(Eterm x, Eterm y, Eterm *r) +{ + Eterm* xp = big_val(x); + + if (BIG_SIGN(xp)) + return big_norm(r, D_add(BIG_V(xp),BIG_SIZE(xp), (ErtsDigit) y, BIG_V(r)), + (short) BIG_SIGN(xp)); + else + return big_norm(r, D_sub(BIG_V(xp),BIG_SIZE(xp), (ErtsDigit) y, BIG_V(r)), + (short) BIG_SIGN(xp)); +} + +/* +** Multiply smallnums +*/ + +Eterm small_times(Sint x, Sint y, Eterm *r) +{ + short sign = (x<0) != (y<0); + ErtsDigit xu = (x > 0) ? x : -x; + ErtsDigit yu = (y > 0) ? y : -y; + ErtsDigit d1=0; + ErtsDigit d0; + Uint arity; + + DMULc(xu, yu, d1, d0); + + if (!d1 && ((D_EXP < SMALL_BITS) || IS_USMALL(sign, d0))) { + if (sign) + return make_small(-((Sint)d0)); + else + return make_small(d0); + } + + BIG_DIGIT(r,0) = d0; + arity = d1 ? 2 : 1; + if (sign) + *r = make_neg_bignum_header(arity); + else + *r = make_pos_bignum_header(arity); + if (d1) + BIG_DIGIT(r,1) = d1; + return make_big(r); +} + +/* +** Multiply bignums +*/ + +Eterm big_times(Eterm x, Eterm y, Eterm *r) +{ + Eterm* xp = big_val(x); + Eterm* yp = big_val(y); + + short sign = BIG_SIGN(xp) != BIG_SIGN(yp); + dsize_t xsz = BIG_SIZE(xp); + dsize_t ysz = BIG_SIZE(yp); + dsize_t rsz; + + if (ysz == 1) + rsz = D_mul(BIG_V(xp), xsz, BIG_DIGIT(yp, 0), BIG_V(r)); + else if (xsz == 1) + rsz = D_mul(BIG_V(yp), ysz, BIG_DIGIT(xp, 0), BIG_V(r)); + else if (xp == yp) { + ZERO_DIGITS(BIG_V(r), xsz+1); + rsz = I_sqr(BIG_V(xp), xsz, BIG_V(r)); + } + else if (xsz >= ysz) { + ZERO_DIGITS(BIG_V(r), xsz); + rsz = I_mul(BIG_V(xp), xsz, BIG_V(yp), ysz, BIG_V(r)); + } + else { + ZERO_DIGITS(BIG_V(r), ysz); + rsz = I_mul(BIG_V(yp), ysz, BIG_V(xp), xsz, BIG_V(r)); + } + return big_norm(r, rsz, sign); +} + + +/* +** Divide bignums +*/ + +Eterm big_div(Eterm x, Eterm y, Eterm *q) +{ + Eterm* xp = big_val(x); + Eterm* yp = big_val(y); + + short sign = BIG_SIGN(xp) != BIG_SIGN(yp); + dsize_t xsz = BIG_SIZE(xp); + dsize_t ysz = BIG_SIZE(yp); + dsize_t qsz; + + if (ysz == 1) { + ErtsDigit rem; + qsz = D_div(BIG_V(xp), xsz, BIG_DIGIT(yp,0), BIG_V(q), &rem); + } + else { + Eterm* remp; + dsize_t rem_sz; + + qsz = xsz - ysz + 1; + remp = q + BIG_NEED_SIZE(qsz); + qsz = I_div(BIG_V(xp), xsz, BIG_V(yp), ysz, BIG_V(q), BIG_V(remp), + &rem_sz); + } + return big_norm(q, qsz, sign); +} + +/* +** Remainder +*/ +Eterm big_rem(Eterm x, Eterm y, Eterm *r) +{ + Eterm* xp = big_val(x); + Eterm* yp = big_val(y); + short sign = BIG_SIGN(xp); + dsize_t xsz = BIG_SIZE(xp); + dsize_t ysz = BIG_SIZE(yp); + + if (ysz == 1) { + ErtsDigit rem; + rem = D_rem(BIG_V(xp), xsz, BIG_DIGIT(yp,0)); + if (IS_USMALL(sign, rem)) { + if (sign) + return make_small(-(Sint)rem); + else + return make_small(rem); + } + else { + if (sign) + *r = make_neg_bignum_header(1); + else + *r = make_pos_bignum_header(1); + BIG_DIGIT(r, 0) = rem; + return make_big(r); + } + } + else { + dsize_t rsz = I_rem(BIG_V(xp), xsz, BIG_V(yp), ysz, BIG_V(r)); + return big_norm(r, rsz, sign); + } +} + +Eterm big_neg(Eterm x, Eterm *r) +{ + Eterm* xp = big_val(x); + dsize_t xsz = BIG_SIZE(xp); + short xsgn = BIG_SIGN(xp); + + MOVE_DIGITS(BIG_V(r), BIG_V(xp), xsz); + return big_norm(r, xsz, (short) !xsgn); +} + +Eterm big_band(Eterm x, Eterm y, Eterm *r) +{ + Eterm* xp = big_val(x); + Eterm* yp = big_val(y); + + short xsgn = BIG_SIGN(xp); + short ysgn = BIG_SIGN(yp); + short sign = xsgn && ysgn; + dsize_t xsz = BIG_SIZE(xp); + dsize_t ysz = BIG_SIZE(yp); + + if (xsz >= ysz) + return big_norm(r,I_band(BIG_V(xp),xsz,xsgn, + BIG_V(yp),ysz,ysgn, + BIG_V(r)),sign); + else + return big_norm(r,I_band(BIG_V(yp),ysz,ysgn, + BIG_V(xp),xsz,xsgn, + BIG_V(r)),sign); +} + + +Eterm big_bor(Eterm x, Eterm y, Eterm *r) +{ + Eterm* xp = big_val(x); + Eterm* yp = big_val(y); + short xsgn = BIG_SIGN(xp); + short ysgn = BIG_SIGN(yp); + short sign = (xsgn || ysgn); + dsize_t xsz = BIG_SIZE(xp); + dsize_t ysz = BIG_SIZE(yp); + + if (xsz >= ysz) + return big_norm(r,I_bor(BIG_V(xp),xsz,xsgn, + BIG_V(yp),ysz,ysgn, + BIG_V(r)),sign); + else + return big_norm(r,I_bor(BIG_V(yp),ysz,ysgn, + BIG_V(xp),xsz,xsgn, + BIG_V(r)),sign); +} + + +Eterm big_bxor(Eterm x, Eterm y, Eterm *r) +{ + Eterm* xp = big_val(x); + Eterm* yp = big_val(y); + short xsgn = BIG_SIGN(xp); + short ysgn = BIG_SIGN(yp); + short sign = (xsgn != ysgn); + dsize_t xsz = BIG_SIZE(xp); + dsize_t ysz = BIG_SIZE(yp); + + if (xsz >= ysz) + return big_norm(r,I_bxor(BIG_V(xp),xsz,xsgn, + BIG_V(yp),ysz,ysgn, + BIG_V(r)),sign); + else + return big_norm(r,I_bxor(BIG_V(yp),ysz,ysgn, + BIG_V(xp),xsz,xsgn, + BIG_V(r)),sign); +} + +Eterm big_bnot(Eterm x, Eterm *r) +{ + Eterm* xp = big_val(x); + short sign = !BIG_SIGN(xp); + dsize_t xsz = BIG_SIZE(xp); + + return big_norm(r, I_bnot(BIG_V(xp), xsz, sign, BIG_V(r)), sign); +} + +Eterm big_lshift(Eterm x, Sint y, Eterm *r) +{ + Eterm* xp = big_val(x); + short sign = BIG_SIGN(xp); + dsize_t xsz = BIG_SIZE(xp); + + return big_norm(r, I_lshift(BIG_V(xp), xsz, y, sign, BIG_V(r)), sign); +} + + +/* add unsigned small int y to x */ + +Eterm big_plus_small(Eterm x, Uint y, Eterm *r) +{ + Eterm* xp = big_val(x); + + if (BIG_SIGN(xp)) + return big_norm(r, D_sub(BIG_V(xp),BIG_SIZE(xp), (ErtsDigit) y, + BIG_V(r)), (short) BIG_SIGN(xp)); + else + return big_norm(r, D_add(BIG_V(xp),BIG_SIZE(xp), (ErtsDigit) y, + BIG_V(r)), (short) BIG_SIGN(xp)); +} + +Eterm big_times_small(Eterm x, Uint y, Eterm *r) +{ + Eterm* xp = big_val(x); + + return big_norm(r, D_mul(BIG_V(xp),BIG_SIZE(xp), (ErtsDigit) y, + BIG_V(r)), (short) BIG_SIGN(xp)); +} + +/* +** Expects the big to fit. +*/ +Uint32 big_to_uint32(Eterm b) +{ + Uint u; + if (!term_to_Uint(b, &u)) { + ASSERT(0); + return 0; + } + return u; +} + +/* + * Check if a fixnum or bignum equals 2^32. + */ +int term_equals_2pow32(Eterm x) +{ + if (sizeof(Uint) > 4) { + Uint u; + if (!term_to_Uint(x, &u)) + return 0; + return (u & 0xFFFFFFFF) == 0 && ((u >> 16) >> 16) == 1; + } else { + Eterm *bp; + if (!is_big(x)) + return 0; + bp = big_val(x); +#if D_EXP == 16 // 16 bit platfrom not really supported!!! + return (BIG_SIZE(bp) == 3) && !BIG_DIGIT(bp,0) && !BIG_DIGIT(bp,1) && + BIG_DIGIT(bp,2) == 1; +#elif D_EXP == 32 + return (BIG_SIZE(bp) == 2) && !BIG_DIGIT(bp,0) && + BIG_DIGIT(bp,1) == 1; +#elif D_EXP == 64 + return (BIG_SIZE(bp) == 1) && + ((BIG_DIGIT(bp,0) & 0xffffffff) == 0) && + ((BIG_DIGIT(bp,0) >> 32) == 1); +#endif + return 0; + } +} diff --git a/erts/emulator/beam/big.h b/erts/emulator/beam/big.h new file mode 100644 index 0000000000..b8e38d482c --- /dev/null +++ b/erts/emulator/beam/big.h @@ -0,0 +1,155 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifndef __BIG_H__ +#define __BIG_H__ + +#ifndef __SYS_H__ +#include "sys.h" +#endif + +#ifndef __CONFIG_H__ +#include "erl_vm.h" +#endif + +#ifndef __GLOBAL_H__ +#include "global.h" +#endif + +typedef Uint ErtsDigit; + +#if (SIZEOF_VOID_P == 4) && defined(SIZEOF_LONG_LONG) && (SIZEOF_LONG_LONG == 8) +/* Assume 32-bit machine with long long support */ +typedef Uint64 ErtsDoubleDigit; +typedef Uint16 ErtsHalfDigit; +#define BIG_HAVE_DOUBLE_DIGIT 1 + +#elif (SIZEOF_VOID_P == 4) +/* Assume 32-bit machine with no long support */ +#undef BIG_HAVE_DOUBLE_DIGIT +typedef Uint16 ErtsHalfDigit; + +#elif (SIZEOF_VOID_P == 8) +/* Assume 64-bit machine, does it exist 128 bit long long long ? */ +#undef BIG_HAVE_DOUBLE_DIGIT +typedef Uint32 ErtsHalfDigit; +#else +#error "can not determine machine size" +#endif + +#define D_DECIMAL_EXP 9 +#define D_DECIMAL_BASE 1000000000 + +typedef Uint dsize_t; /* Vector size type */ + +#define D_EXP (SIZEOF_VOID_P*8) +#define D_MASK ((ErtsDigit)(-1)) /* D_BASE-1 */ + +/* macros for bignum objects */ +#define big_v(x) BIG_V(big_val(x)) +#define big_sign(x) BIG_SIGN(big_val(x)) +#define big_arity(x) BIG_ARITY(big_val(x)) +#define big_digit(x,i) BIG_DIGIT(big_val(x),i) +#define big_size(x) BIG_SIZE(big_val(x)) + + +/* macros for thing pointers */ + +#define BIG_V(xp) ((ErtsDigit*)((xp)+1)) +#define BIG_SIGN(xp) (!!bignum_header_is_neg(*xp)) +#define BIG_ARITY(xp) ((Uint)bignum_header_arity(*(xp))) +#define BIG_DIGIT(xp,i) *(BIG_V(xp)+(i)) +#define BIG_DIGITS_PER_WORD (sizeof(Uint)/sizeof(ErtsDigit)) + +#define BIG_SIZE(xp) BIG_ARITY(xp) + +/* Check for small */ +#define IS_USMALL(sgn,x) ((sgn) ? ((x) <= MAX_SMALL+1) : ((x) <= MAX_SMALL)) +#define IS_SSMALL(x) (((x) >= MIN_SMALL) && ((x) <= MAX_SMALL)) + +/* The heap size needed for a bignum */ +#define BIG_NEED_SIZE(x) ((x) + 1) + +#define BIG_UINT_HEAP_SIZE (1 + 1) /* always, since sizeof(Uint) <= sizeof(Eterm) */ + +#ifdef ARCH_32 + +#define ERTS_UINT64_BIG_HEAP_SIZE__(X) \ + ((X) >= (((Uint64) 1) << 32) ? (1 + 2) : (1 + 1)) +#define ERTS_SINT64_HEAP_SIZE(X) \ + (IS_SSMALL((X)) \ + ? 0 \ + : ERTS_UINT64_BIG_HEAP_SIZE__((X) >= 0 ? (X) : -(X))) +#define ERTS_UINT64_HEAP_SIZE(X) \ + (IS_USMALL(0, (X)) ? 0 : ERTS_UINT64_BIG_HEAP_SIZE__((X))) + +#else + +#define ERTS_SINT64_HEAP_SIZE(X) \ + (IS_SSMALL((X)) ? 0 : (1 + 1)) +#define ERTS_UINT64_HEAP_SIZE(X) \ + (IS_USMALL(0, (X)) ? 0 : (1 + 1)) + +#endif + +int big_decimal_estimate(Eterm); +Eterm erts_big_to_list(Eterm, Eterm**); +char *erts_big_to_string(Eterm x, char *buf, Uint buf_sz); + +Eterm small_times(Sint, Sint, Eterm*); + +Eterm big_plus(Eterm, Eterm, Eterm*); +Eterm big_minus(Eterm, Eterm, Eterm*); +Eterm big_times(Eterm, Eterm, Eterm*); +Eterm big_div(Eterm, Eterm, Eterm*); +Eterm big_rem(Eterm, Eterm, Eterm*); +Eterm big_neg(Eterm, Eterm*); + +Eterm big_minus_small(Eterm, Uint, Eterm*); +Eterm big_plus_small(Eterm, Uint, Eterm*); +Eterm big_times_small(Eterm, Uint, Eterm*); + +Eterm big_band(Eterm, Eterm, Eterm*); +Eterm big_bor(Eterm, Eterm, Eterm*); +Eterm big_bxor(Eterm, Eterm, Eterm*); +Eterm big_bnot(Eterm, Eterm*); + +Eterm big_lshift(Eterm, Sint, Eterm*); +int big_comp (Eterm, Eterm); +int big_ucomp (Eterm, Eterm); +int big_to_double(Eterm x, double* resp); +Eterm small_to_big(Sint, Eterm*); +Eterm uint_to_big(Uint, Eterm*); +Eterm erts_make_integer(Uint, Process *); + +dsize_t big_bytes(Eterm); +Eterm bytes_to_big(byte*, dsize_t, int, Eterm*); +byte* big_to_bytes(Eterm, byte*); + +int term_to_Uint(Eterm, Uint*); +int term_to_Sint(Eterm, Sint*); + +Uint32 big_to_uint32(Eterm b); +int term_equals_2pow32(Eterm); + +Eterm erts_uint64_to_big(Uint64, Eterm **); +Eterm erts_sint64_to_big(Sint64, Eterm **); + +#endif + diff --git a/erts/emulator/beam/binary.c b/erts/emulator/beam/binary.c new file mode 100644 index 0000000000..49bc0d6457 --- /dev/null +++ b/erts/emulator/beam/binary.c @@ -0,0 +1,677 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "erl_process.h" +#include "error.h" +#include "bif.h" +#include "big.h" +#include "erl_binary.h" +#include "erl_bits.h" + +#ifdef DEBUG +static int list_to_bitstr_buf(Eterm obj, char* buf, int len); +#else +static int list_to_bitstr_buf(Eterm obj, char* buf); +#endif +static Sint bitstr_list_len(Eterm obj); + +void +erts_init_binary(void) +{ + /* Verify Binary alignment... */ + if ((((Uint) &((Binary *) 0)->orig_bytes[0]) % ((Uint) 8)) != 0) { + /* I assume that any compiler should be able to optimize this + away. If not, this test is not very expensive... */ + erl_exit(ERTS_ABORT_EXIT, + "Internal error: Address of orig_bytes[0] of a Binary" + "is *not* 8-byte aligned\n"); + } +} + +/* + * Create a brand new binary from scratch. + */ + +Eterm +new_binary(Process *p, byte *buf, int len) +{ + ProcBin* pb; + Binary* bptr; + + if (len <= ERL_ONHEAP_BIN_LIMIT) { + ErlHeapBin* hb = (ErlHeapBin *) HAlloc(p, heap_bin_size(len)); + hb->thing_word = header_heap_bin(len); + hb->size = len; + if (buf != NULL) { + sys_memcpy(hb->data, buf, len); + } + return make_binary(hb); + } + + /* + * Allocate the binary struct itself. + */ + bptr = erts_bin_nrml_alloc(len); + bptr->flags = 0; + bptr->orig_size = len; + erts_refc_init(&bptr->refc, 1); + if (buf != NULL) { + sys_memcpy(bptr->orig_bytes, buf, len); + } + + /* + * Now allocate the ProcBin on the heap. + */ + pb = (ProcBin *) HAlloc(p, PROC_BIN_SIZE); + pb->thing_word = HEADER_PROC_BIN; + pb->size = len; + pb->next = MSO(p).mso; + MSO(p).mso = pb; + pb->val = bptr; + pb->bytes = (byte*) bptr->orig_bytes; + pb->flags = 0; + + /* + * Miscellanous updates. Return the tagged binary. + */ + MSO(p).overhead += pb->size / sizeof(Eterm); + return make_binary(pb); +} + +/* + * When heap binary is not desired... + */ + +Eterm erts_new_mso_binary(Process *p, byte *buf, int len) +{ + ProcBin* pb; + Binary* bptr; + + /* + * Allocate the binary struct itself. + */ + bptr = erts_bin_nrml_alloc(len); + bptr->flags = 0; + bptr->orig_size = len; + erts_refc_init(&bptr->refc, 1); + if (buf != NULL) { + sys_memcpy(bptr->orig_bytes, buf, len); + } + + /* + * Now allocate the ProcBin on the heap. + */ + pb = (ProcBin *) HAlloc(p, PROC_BIN_SIZE); + pb->thing_word = HEADER_PROC_BIN; + pb->size = len; + pb->next = MSO(p).mso; + MSO(p).mso = pb; + pb->val = bptr; + pb->bytes = (byte*) bptr->orig_bytes; + pb->flags = 0; + + /* + * Miscellanous updates. Return the tagged binary. + */ + MSO(p).overhead += pb->size / sizeof(Eterm); + return make_binary(pb); +} + +/* + * Create a brand new binary from scratch on the heap. + */ + +Eterm +erts_new_heap_binary(Process *p, byte *buf, int len, byte** datap) +{ + ErlHeapBin* hb = (ErlHeapBin *) HAlloc(p, heap_bin_size(len)); + + hb->thing_word = header_heap_bin(len); + hb->size = len; + if (buf != NULL) { + sys_memcpy(hb->data, buf, len); + } + *datap = (byte*) hb->data; + return make_binary(hb); +} + +Eterm +erts_realloc_binary(Eterm bin, size_t size) +{ + Eterm* bval = binary_val(bin); + + if (thing_subtag(*bval) == HEAP_BINARY_SUBTAG) { + ASSERT(size <= binary_size(bin)); + binary_size(bin) = size; + } else { /* REFC */ + ProcBin* pb = (ProcBin *) bval; + Binary* newbin = erts_bin_realloc(pb->val, size); + newbin->orig_size = size; + pb->val = newbin; + pb->size = size; + pb->bytes = (byte*) newbin->orig_bytes; + pb->flags = 0; + bin = make_binary(pb); + } + return bin; +} + +byte* +erts_get_aligned_binary_bytes(Eterm bin, byte** base_ptr) +{ + byte* bytes; + Eterm* real_bin; + Uint byte_size; + Uint offs = 0; + Uint bit_offs = 0; + + if (is_not_binary(bin)) { + return NULL; + } + byte_size = binary_size(bin); + real_bin = binary_val(bin); + if (*real_bin == HEADER_SUB_BIN) { + ErlSubBin* sb = (ErlSubBin *) real_bin; + if (sb->bitsize) { + return NULL; + } + 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) { + byte* buf = (byte *) erts_alloc(ERTS_ALC_T_TMP, byte_size); + + erts_copy_bits(bytes, bit_offs, 1, buf, 0, 1, byte_size*8); + *base_ptr = buf; + bytes = buf; + } + return bytes; +} + +static Eterm +bin_bytes_to_list(Eterm previous, Eterm* hp, byte* bytes, Uint size, Uint bitoffs) +{ + if (bitoffs == 0) { + while (size) { + previous = CONS(hp, make_small(bytes[--size]), previous); + hp += 2; + } + } else { + byte present; + byte next; + next = bytes[size]; + while (size) { + present = next; + next = bytes[--size]; + previous = CONS(hp, make_small(((present >> (8-bitoffs)) | + (next << bitoffs)) & 255), previous); + hp += 2; + } + } + return previous; +} + + +BIF_RETTYPE binary_to_list_1(BIF_ALIST_1) +{ + Eterm real_bin; + Uint offset; + Uint size; + Uint bitsize; + Uint bitoffs; + + if (is_not_binary(BIF_ARG_1)) { + goto error; + } + size = binary_size(BIF_ARG_1); + ERTS_GET_REAL_BIN(BIF_ARG_1, real_bin, offset, bitoffs, bitsize); + if (bitsize != 0) { + goto error; + } + if (size == 0) { + BIF_RET(NIL); + } else { + Eterm* hp = HAlloc(BIF_P, 2 * size); + byte* bytes = binary_bytes(real_bin)+offset; + + BIF_RET(bin_bytes_to_list(NIL, hp, bytes, size, bitoffs)); + } + + error: + BIF_ERROR(BIF_P, BADARG); +} + +BIF_RETTYPE binary_to_list_3(BIF_ALIST_3) +{ + byte* bytes; + Uint size; + Uint bitoffs; + Uint bitsize; + Uint i; + Uint start; + Uint stop; + Eterm* hp; + + if (is_not_binary(BIF_ARG_1)) { + goto error; + } + if (!term_to_Uint(BIF_ARG_2, &start) || !term_to_Uint(BIF_ARG_3, &stop)) { + goto error; + } + size = binary_size(BIF_ARG_1); + ERTS_GET_BINARY_BYTES(BIF_ARG_1, bytes, bitoffs, bitsize); + if (start < 1 || start > size || stop < 1 || + stop > size || stop < start ) { + goto error; + } + i = stop-start+1; + hp = HAlloc(BIF_P, 2*i); + BIF_RET(bin_bytes_to_list(NIL, hp, bytes+start-1, i, bitoffs)); + + error: + BIF_ERROR(BIF_P, BADARG); +} + +BIF_RETTYPE bitstring_to_list_1(BIF_ALIST_1) +{ + Eterm real_bin; + Uint offset; + Uint size; + Uint bitsize; + Uint bitoffs; + byte* bytes; + Eterm previous = NIL; + Eterm* hp; + + if (is_not_binary(BIF_ARG_1)) { + BIF_ERROR(BIF_P, BADARG); + } + size = binary_size(BIF_ARG_1); + ERTS_GET_REAL_BIN(BIF_ARG_1, real_bin, offset, bitoffs, bitsize); + bytes = binary_bytes(real_bin)+offset; + if (bitsize == 0) { + hp = HAlloc(BIF_P, 2 * size); + } else if (size == 0) { + hp = HAlloc(BIF_P, 2); + BIF_RET(CONS(hp,BIF_ARG_1,NIL)); + } else { + ErlSubBin* last; + + hp = HAlloc(BIF_P, ERL_SUB_BIN_SIZE+2+2*size); + last = (ErlSubBin *) hp; + last->thing_word = HEADER_SUB_BIN; + last->size = 0; + last->bitsize = bitsize; + last->offs = offset+size; + last->bitoffs = bitoffs; + last->orig = real_bin; + last->is_writable = 0; + hp += ERL_SUB_BIN_SIZE; + previous = CONS(hp, make_binary(last), previous); + hp += 2; + } + BIF_RET(bin_bytes_to_list(previous, hp, bytes, size, bitoffs)); +} + + +/* Turn a possibly deep list of ints (and binaries) into */ +/* One large binary object */ + +BIF_RETTYPE list_to_binary_1(BIF_ALIST_1) +{ + Eterm bin; + int i; + int offset; + byte* bytes; + if (is_nil(BIF_ARG_1)) { + BIF_RET(new_binary(BIF_P,(byte*)"",0)); + } + if (is_not_list(BIF_ARG_1)) { + goto error; + } + if ((i = io_list_len(BIF_ARG_1)) < 0) { + goto error; + } + bin = new_binary(BIF_P, (byte *)NULL, i); + bytes = binary_bytes(bin); + offset = io_list_to_buf(BIF_ARG_1, (char*) bytes, i); + ASSERT(offset == 0); + BIF_RET(bin); + + error: + BIF_ERROR(BIF_P, BADARG); +} + +/* Turn a possibly deep list of ints (and binaries) into */ +/* One large binary object */ + +BIF_RETTYPE iolist_to_binary_1(BIF_ALIST_1) +{ + Eterm bin; + int i; + int offset; + byte* bytes; + + if (is_binary(BIF_ARG_1)) { + BIF_RET(BIF_ARG_1); + } + if (is_nil(BIF_ARG_1)) { + BIF_RET(new_binary(BIF_P,(byte*)"",0)); + } + if (is_not_list(BIF_ARG_1)) { + goto error; + } + if ((i = io_list_len(BIF_ARG_1)) < 0) { + goto error; + } + bin = new_binary(BIF_P, (byte *)NULL, i); + bytes = binary_bytes(bin); + offset = io_list_to_buf(BIF_ARG_1, (char*) bytes, i); + ASSERT(offset == 0); + BIF_RET(bin); + + error: + BIF_ERROR(BIF_P, BADARG); +} + +BIF_RETTYPE list_to_bitstring_1(BIF_ALIST_1) +{ + Eterm bin; + int i,offset; + byte* bytes; + ErlSubBin* sb1; + Eterm* hp; + + if (is_nil(BIF_ARG_1)) { + BIF_RET(new_binary(BIF_P,(byte*)"",0)); + } + if (is_not_list(BIF_ARG_1)) { + goto error; + } + if ((i = bitstr_list_len(BIF_ARG_1)) < 0) { + goto error; + } + bin = new_binary(BIF_P, (byte *)NULL, i); + bytes = binary_bytes(bin); +#ifdef DEBUG + offset = list_to_bitstr_buf(BIF_ARG_1, (char*) bytes, i); +#else + offset = list_to_bitstr_buf(BIF_ARG_1, (char*) bytes); +#endif + ASSERT(offset >= 0); + if (offset > 0) { + hp = HAlloc(BIF_P, ERL_SUB_BIN_SIZE); + sb1 = (ErlSubBin *) hp; + sb1->thing_word = HEADER_SUB_BIN; + sb1->size = i-1; + sb1->offs = 0; + sb1->orig = bin; + sb1->bitoffs = 0; + sb1->bitsize = offset; + sb1->is_writable = 0; + hp += ERL_SUB_BIN_SIZE; + bin = make_binary(sb1); + } + + BIF_RET(bin); + + error: + BIF_ERROR(BIF_P, BADARG); +} + +BIF_RETTYPE split_binary_2(BIF_ALIST_2) +{ + Uint pos; + ErlSubBin* sb1; + ErlSubBin* sb2; + size_t orig_size; + Eterm orig; + Uint offset; + Uint bit_offset; + Uint bit_size; + Eterm* hp; + + if (is_not_binary(BIF_ARG_1)) { + goto error; + } + if (!term_to_Uint(BIF_ARG_2, &pos)) { + goto error; + } + if ((orig_size = binary_size(BIF_ARG_1)) < pos) { + goto error; + } + hp = HAlloc(BIF_P, 2*ERL_SUB_BIN_SIZE+3); + ERTS_GET_REAL_BIN(BIF_ARG_1, orig, offset, bit_offset, bit_size); + sb1 = (ErlSubBin *) hp; + sb1->thing_word = HEADER_SUB_BIN; + sb1->size = pos; + sb1->offs = offset; + sb1->orig = orig; + sb1->bitoffs = bit_offset; + sb1->bitsize = 0; + sb1->is_writable = 0; + hp += ERL_SUB_BIN_SIZE; + + sb2 = (ErlSubBin *) hp; + sb2->thing_word = HEADER_SUB_BIN; + sb2->size = orig_size - pos; + sb2->offs = offset + pos; + sb2->orig = orig; + sb2->bitoffs = bit_offset; + sb2->bitsize = bit_size; /* The extra bits go into the second binary. */ + sb2->is_writable = 0; + hp += ERL_SUB_BIN_SIZE; + + return TUPLE2(hp, make_binary(sb1), make_binary(sb2)); + + error: + BIF_ERROR(BIF_P, BADARG); +} + +void +erts_cleanup_mso(ProcBin* pb) +{ + while (pb != NULL) { + ProcBin* next = pb->next; + if (erts_refc_dectest(&pb->val->refc, 0) == 0) + erts_bin_free(pb->val); + pb = next; + } +} + +/* + * Local functions. + */ + +/* + * The input list is assumed to be type-correct and the buffer is + * assumed to be of sufficient size. Those assumptions are verified in + * the DEBUG-built emulator. + */ +static int +#ifdef DEBUG +list_to_bitstr_buf(Eterm obj, char* buf, int len) +#else +list_to_bitstr_buf(Eterm obj, char* buf) +#endif +{ + Eterm* objp; + int offset = 0; + DECLARE_ESTACK(s); + goto L_again; + + while (!ESTACK_ISEMPTY(s)) { + obj = ESTACK_POP(s); + L_again: + if (is_list(obj)) { + L_iter_list: + objp = list_val(obj); + obj = CAR(objp); + if (is_byte(obj)) { + ASSERT(len > 0); + if (offset == 0) { + *buf++ = unsigned_val(obj); + } else { + *buf = (char)((unsigned_val(obj) >> offset) | + ((*buf >> (8-offset)) << (8-offset))); + buf++; + *buf = (unsigned_val(obj) << (8-offset)); + } +#ifdef DEBUG + len--; +#endif + } else if (is_binary(obj)) { + byte* bptr; + size_t size = binary_size(obj); + Uint bitsize; + Uint bitoffs; + Uint num_bits; + + ASSERT(size <= len); + ERTS_GET_BINARY_BYTES(obj, bptr, bitoffs, bitsize); + num_bits = 8*size+bitsize; + copy_binary_to_buffer(buf, offset, bptr, bitoffs, num_bits); + offset += bitsize; + buf += size + (offset>7); +#ifdef DEBUG + len -= size + (offset>7); +#endif + offset = offset & 7; + } else if (is_list(obj)) { + ESTACK_PUSH(s, CDR(objp)); + goto L_iter_list; /* on head */ + } else { + ASSERT(is_nil(obj)); + } + + obj = CDR(objp); + if (is_list(obj)) { + goto L_iter_list; /* on tail */ + } else if (is_binary(obj)) { + byte* bptr; + size_t size = binary_size(obj); + Uint bitsize; + Uint bitoffs; + Uint num_bits; + + ASSERT(size <= len); + ERTS_GET_BINARY_BYTES(obj, bptr, bitoffs, bitsize); + num_bits = 8*size+bitsize; + copy_binary_to_buffer(buf, offset, bptr, bitoffs, num_bits); + offset += bitsize; + buf += size+(offset>7); +#ifdef DEBUG + len -= size+(offset>7); +#endif + offset = offset & 7; + } else { + ASSERT(is_nil(obj)); + } + } else if (is_binary(obj)) { + byte* bptr; + size_t size = binary_size(obj); + Uint bitsize; + Uint bitoffs; + Uint num_bits; + + ASSERT(size <= len); + ERTS_GET_BINARY_BYTES(obj, bptr, bitoffs, bitsize); + num_bits = 8*size+bitsize; + copy_binary_to_buffer(buf, offset, bptr, bitoffs, num_bits); + offset += bitsize; + buf += size + (offset>7); +#ifdef DEBUG + len -= size + (offset>7); +#endif + offset = offset & 7; + } else { + ASSERT(is_nil(obj)); + } + } + + DESTROY_ESTACK(s); + return offset; +} + +static Sint +bitstr_list_len(Eterm obj) +{ + Eterm* objp; + Uint len = 0; + Uint offs = 0; + DECLARE_ESTACK(s); + goto L_again; + + while (!ESTACK_ISEMPTY(s)) { + obj = ESTACK_POP(s); + L_again: + if (is_list(obj)) { + L_iter_list: + objp = list_val(obj); + /* Head */ + obj = CAR(objp); + if (is_byte(obj)) { + len++; + } else if (is_binary(obj)) { + len += binary_size(obj); + offs += binary_bitsize(obj); + } else if (is_list(obj)) { + ESTACK_PUSH(s, CDR(objp)); + goto L_iter_list; /* on head */ + } else if (is_not_nil(obj)) { + goto L_type_error; + } + /* Tail */ + obj = CDR(objp); + if (is_list(obj)) + goto L_iter_list; /* on tail */ + else if (is_binary(obj)) { + len += binary_size(obj); + offs += binary_bitsize(obj); + } else if (is_not_nil(obj)) { + goto L_type_error; + } + } else if (is_binary(obj)) { + len += binary_size(obj); + offs += binary_bitsize(obj); + } else if (is_not_nil(obj)) { + goto L_type_error; + } + } + + DESTROY_ESTACK(s); + return (Sint) (len + (offs/8) + ((offs % 8) != 0)); + + L_type_error: + DESTROY_ESTACK(s); + return (Sint) -1; +} diff --git a/erts/emulator/beam/break.c b/erts/emulator/beam/break.c new file mode 100644 index 0000000000..5ea47e16f5 --- /dev/null +++ b/erts/emulator/beam/break.c @@ -0,0 +1,747 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ +/* This File contains functions which are called if a user hits ^C */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "erl_process.h" +#include "version.h" +#include "error.h" +#include "version.h" +#include "erl_db.h" +#include "bif.h" +#include "erl_version.h" +#include "hash.h" +#include "atom.h" +#include "beam_load.h" +#include "erl_instrument.h" +#include "erl_bif_timer.h" + +#ifdef _OSE_ +#include "time.h" +#endif + +/* Forward declarations -- should really appear somewhere else */ +static void process_killer(void); +void do_break(void); +void erl_crash_dump_v(char *file, int line, char* fmt, va_list args); +void erl_crash_dump(char* file, int line, char* fmt, ...); + +#ifdef DEBUG +static void bin_check(void); +#endif + +static void print_garb_info(int to, void *to_arg, Process* p); +#ifdef OPPROF +static void dump_frequencies(void); +#endif + +static void dump_attributes(int to, void *to_arg, byte* ptr, int size); + +extern char* erts_system_version[]; + +static void +port_info(int to, void *to_arg) +{ + int i; + for (i = 0; i < erts_max_ports; i++) + print_port_info(to, to_arg, i); +} + +void +process_info(int to, void *to_arg) +{ + int i; + for (i = 0; i < erts_max_processes; i++) { + if ((process_tab[i] != NULL) && (process_tab[i]->i != ENULL)) { + if (process_tab[i]->status != P_EXITING) + print_process_info(to, to_arg, process_tab[i]); + } + } + + port_info(to, to_arg); +} + +static void +process_killer(void) +{ + int i, j; + Process* rp; + + erts_printf("\n\nProcess Information\n\n"); + erts_printf("--------------------------------------------------\n"); + for (i = erts_max_processes-1; i >= 0; i--) { + if (((rp = process_tab[i]) != NULL) && rp->i != ENULL) { + int br; + print_process_info(ERTS_PRINT_STDOUT, NULL, rp); + erts_printf("(k)ill (n)ext (r)eturn:\n"); + while(1) { + if ((j = sys_get_key(0)) <= 0) + halt_0(0); + switch(j) { + case 'k': + if (rp->status == P_WAITING) { + Uint32 rp_locks = ERTS_PROC_LOCKS_XSIG_SEND; + erts_smp_proc_inc_refc(rp); + erts_smp_proc_lock(rp, rp_locks); + (void) erts_send_exit_signal(NULL, + NIL, + rp, + &rp_locks, + am_kill, + NIL, + NULL, + 0); + erts_smp_proc_unlock(rp, rp_locks); + erts_smp_proc_dec_refc(rp); + } + else + erts_printf("Can only kill WAITING processes this way\n"); + + case 'n': br = 1; break; + case 'r': return; + default: return; + } + if (br == 1) break; + } + } + } +} + +typedef struct { + int is_first; + int to; + void *to_arg; +} PrintMonitorContext; + +static void doit_print_link(ErtsLink *lnk, void *vpcontext) +{ + PrintMonitorContext *pcontext = vpcontext; + int to = pcontext->to; + void *to_arg = pcontext->to_arg; + + if (pcontext->is_first) { + pcontext->is_first = 0; + erts_print(to, to_arg, "%T", lnk->pid); + } else { + erts_print(to, to_arg, ", %T", lnk->pid); + } +} + + +static void doit_print_monitor(ErtsMonitor *mon, void *vpcontext) +{ + PrintMonitorContext *pcontext = vpcontext; + int to = pcontext->to; + void *to_arg = pcontext->to_arg; + char *prefix = ", "; + + if (pcontext->is_first) { + pcontext->is_first = 0; + prefix = ""; + } + + if (mon->type == MON_ORIGIN) { + if (is_atom(mon->pid)) { /* dist by name */ + ASSERT(is_node_name_atom(mon->pid)); + erts_print(to, to_arg, "%s{to,{%T,%T},%T}", prefix, mon->name, + mon->pid, mon->ref); + erts_print(to, to_arg,"}"); + } else if (is_atom(mon->name)){ /* local by name */ + erts_print(to, to_arg, "%s{to,{%T,%T},%T}", prefix, mon->name, + erts_this_dist_entry->sysname, mon->ref); + } else { /* local and distributed by pid */ + erts_print(to, to_arg, "%s{to,%T,%T}", prefix, mon->pid, mon->ref); + } + } else { /* MON_TARGET */ + erts_print(to, to_arg, "%s{from,%T,%T}", prefix, mon->pid, mon->ref); + } +} + +/* Display info about an individual Erlang process */ +void +print_process_info(int to, void *to_arg, Process *p) +{ + int garbing = 0; + int running = 0; + struct saved_calls *scb; + + /* display the PID */ + erts_print(to, to_arg, "=proc:%T\n", p->id); + + /* Display the state */ + erts_print(to, to_arg, "State: "); + switch (p->status) { + case P_FREE: + erts_print(to, to_arg, "Non Existing\n"); /* Should never happen */ + break; + case P_RUNABLE: + erts_print(to, to_arg, "Scheduled\n"); + break; + case P_WAITING: + erts_print(to, to_arg, "Waiting\n"); + break; + case P_SUSPENDED: + erts_print(to, to_arg, "Suspended\n"); + break; + case P_RUNNING: + erts_print(to, to_arg, "Running\n"); + running = 1; + break; + case P_EXITING: + erts_print(to, to_arg, "Exiting\n"); + break; + case P_GARBING: + erts_print(to, to_arg, "Garbing\n"); + garbing = 1; + running = 1; + break; + } + + /* + * If the process is registered as a global process, display the + * registered name + */ + if (p->reg != NULL) + erts_print(to, to_arg, "Name: %T\n", p->reg->name); + + /* + * Display the initial function name + */ + erts_print(to, to_arg, "Spawned as: %T:%T/%bpu\n", + p->initial[INITIAL_MOD], + p->initial[INITIAL_FUN], + p->initial[INITIAL_ARI]); + + if (p->current != NULL) { + if (running) { + erts_print(to, to_arg, "Last scheduled in for: "); + } else { + erts_print(to, to_arg, "Current call: "); + } + erts_print(to, to_arg, "%T:%T/%bpu\n", + p->current[0], + p->current[1], + p->current[2]); + } + + erts_print(to, to_arg, "Spawned by: %T\n", p->parent); + + erts_print(to, to_arg, "Started: %s", ctime((time_t*)&p->started.tv_sec)); + ERTS_SMP_MSGQ_MV_INQ2PRIVQ(p); + erts_print(to, to_arg, "Message queue length: %d\n", p->msg.len); + + /* display the message queue only if there is anything in it */ + if (!ERTS_IS_CRASH_DUMPING && p->msg.first != NULL && !garbing) { + ErlMessage* mp; + erts_print(to, to_arg, "Message queue: ["); + for (mp = p->msg.first; mp; mp = mp->next) + erts_print(to, to_arg, mp->next ? "%T," : "%T", ERL_MESSAGE_TERM(mp)); + erts_print(to, to_arg, "]\n"); + } + + { + long s = 0; + int frags = 0; + ErlHeapFragment *m = p->mbuf; + while (m != NULL) { + frags++; + s += m->size; + m = m->next; + } + erts_print(to, to_arg, "Number of heap fragments: %d\n", frags); + } + erts_print(to, to_arg, "Heap fragment data: %bpu\n", MBUF_SIZE(p)); + + scb = ERTS_PROC_GET_SAVED_CALLS_BUF(p); + if (scb) { + int i, j; + + erts_print(to, to_arg, "Last calls:"); + for (i = 0; i < scb->n; i++) { + erts_print(to, to_arg, " "); + j = scb->cur - i - 1; + if (j < 0) + j += scb->len; + if (scb->ct[j] == &exp_send) + erts_print(to, to_arg, "send"); + else if (scb->ct[j] == &exp_receive) + erts_print(to, to_arg, "'receive'"); + else if (scb->ct[j] == &exp_timeout) + erts_print(to, to_arg, "timeout"); + else + erts_print(to, to_arg, "%T:%T/%bpu\n", + scb->ct[j]->code[0], + scb->ct[j]->code[1], + scb->ct[j]->code[2]); + } + erts_print(to, to_arg, "\n"); + } + + /* display the links only if there are any*/ + if (p->nlinks != NULL || p->monitors != NULL) { + PrintMonitorContext context = {1,to}; + erts_print(to, to_arg,"Link list: ["); + erts_doforall_links(p->nlinks, &doit_print_link, &context); + erts_doforall_monitors(p->monitors, &doit_print_monitor, &context); + erts_print(to, to_arg,"]\n"); + } + + if (!ERTS_IS_CRASH_DUMPING) { + + /* and the dictionary */ + if (p->dictionary != NULL && !garbing) { + erts_print(to, to_arg, "Dictionary: "); + erts_dictionary_dump(to, to_arg, p->dictionary); + erts_print(to, to_arg, "\n"); + } + } + + /* print the number of reductions etc */ + erts_print(to, to_arg, "Reductions: %bpu\n", p->reds); + + erts_print(to, to_arg, "Stack+heap: %bpu\n", p->heap_sz); + erts_print(to, to_arg, "OldHeap: %bpu\n", + (OLD_HEAP(p) == NULL) ? 0 : + (unsigned)(OLD_HEND(p) - OLD_HEAP(p)) ); + erts_print(to, to_arg, "Heap unused: %bpu\n", (p->hend - p->htop)); + erts_print(to, to_arg, "OldHeap unused: %bpu\n", + (OLD_HEAP(p) == NULL) ? 0 : (OLD_HEND(p) - OLD_HEAP(p)) ); + + if (garbing) { + print_garb_info(to, to_arg, p); + } + + if (ERTS_IS_CRASH_DUMPING) { + erts_program_counter_info(to, to_arg, p); + } else { + erts_print(to, to_arg, "Stack dump:\n"); +#ifdef ERTS_SMP + if (!garbing) +#endif + erts_stack_dump(to, to_arg, p); + } +} + +static void +print_garb_info(int to, void *to_arg, Process* p) +{ + /* ERTS_SMP: A scheduler is probably concurrently doing gc... */ +#ifndef ERTS_SMP + erts_print(to, to_arg, "New heap start: %bpX\n", p->heap); + erts_print(to, to_arg, "New heap top: %bpX\n", p->htop); + erts_print(to, to_arg, "Stack top: %bpX\n", p->stop); + erts_print(to, to_arg, "Stack end: %bpX\n", p->hend); + erts_print(to, to_arg, "Old heap start: %bpX\n", OLD_HEAP(p)); + erts_print(to, to_arg, "Old heap top: %bpX\n", OLD_HTOP(p)); + erts_print(to, to_arg, "Old heap end: %bpX\n", OLD_HEND(p)); +#endif +} + +void +info(int to, void *to_arg) +{ + erts_memory(&to, to_arg, NULL, THE_NON_VALUE); + atom_info(to, to_arg); + module_info(to, to_arg); + export_info(to, to_arg); + register_info(to, to_arg); + erts_fun_info(to, to_arg); + erts_node_table_info(to, to_arg); + erts_dist_table_info(to, to_arg); + erts_allocated_areas(&to, to_arg, NULL); + erts_allocator_info(to, to_arg); + +} + +void +loaded(int to, void *to_arg) +{ + int i; + int old = 0; + int cur = 0; + Eterm* code; + + /* + * Calculate and print totals. + */ + for (i = 0; i < module_code_size(); i++) { + if (module_code(i) != NULL && + ((module_code(i)->code_length != 0) || + (module_code(i)->old_code_length != 0))) { + cur += module_code(i)->code_length; + if (module_code(i)->old_code_length != 0) { + old += module_code(i)->old_code_length; + } + } + } + erts_print(to, to_arg, "Current code: %d\n", cur); + erts_print(to, to_arg, "Old code: %d\n", old); + + /* + * Print one line per module. + */ + + for (i = 0; i < module_code_size(); i++) { + if (!ERTS_IS_CRASH_DUMPING) { + /* + * Interactive dump; keep it brief. + */ + if (module_code(i) != NULL && + ((module_code(i)->code_length != 0) || + (module_code(i)->old_code_length != 0))) { + erts_print(to, to_arg, "%T", make_atom(module_code(i)->module)); + cur += module_code(i)->code_length; + erts_print(to, to_arg, " %d", module_code(i)->code_length ); + if (module_code(i)->old_code_length != 0) { + erts_print(to, to_arg, " (%d old)", + module_code(i)->old_code_length ); + old += module_code(i)->old_code_length; + } + erts_print(to, to_arg, "\n"); + } + } else { + /* + * To crash dump; make it parseable. + */ + if (module_code(i) != NULL && + ((module_code(i)->code_length != 0) || + (module_code(i)->old_code_length != 0))) { + erts_print(to, to_arg, "=mod:"); + erts_print(to, to_arg, "%T", make_atom(module_code(i)->module)); + erts_print(to, to_arg, "\n"); + erts_print(to, to_arg, "Current size: %d\n", + module_code(i)->code_length); + code = module_code(i)->code; + if (code != NULL && code[MI_ATTR_PTR]) { + erts_print(to, to_arg, "Current attributes: "); + dump_attributes(to, to_arg, (byte *) code[MI_ATTR_PTR], + code[MI_ATTR_SIZE]); + } + if (code != NULL && code[MI_COMPILE_PTR]) { + erts_print(to, to_arg, "Current compilation info: "); + dump_attributes(to, to_arg, (byte *) code[MI_COMPILE_PTR], + code[MI_COMPILE_SIZE]); + } + + if (module_code(i)->old_code_length != 0) { + erts_print(to, to_arg, "Old size: %d\n", module_code(i)->old_code_length); + code = module_code(i)->old_code; + if (code[MI_ATTR_PTR]) { + erts_print(to, to_arg, "Old attributes: "); + dump_attributes(to, to_arg, (byte *) code[MI_ATTR_PTR], + code[MI_ATTR_SIZE]); + } + if (code[MI_COMPILE_PTR]) { + erts_print(to, to_arg, "Old compilation info: "); + dump_attributes(to, to_arg, (byte *) code[MI_COMPILE_PTR], + code[MI_COMPILE_SIZE]); + } + } + } + } + } +} + + +static void +dump_attributes(int to, void *to_arg, byte* ptr, int size) +{ + while (size-- > 0) { + erts_print(to, to_arg, "%02X", *ptr++); + } + erts_print(to, to_arg, "\n"); +} + + +void +do_break(void) +{ + int i; +#ifdef __WIN32__ + char *mode; /* enough for storing "window" */ + + /* check if we're in console mode and, if so, + halt immediately if break is called */ + mode = erts_read_env("ERL_CONSOLE_MODE"); + if (mode && strcmp(mode, "window") != 0) + erl_exit(0, ""); + erts_free_read_env(mode); +#endif /* __WIN32__ */ + + erts_printf("\n" + "BREAK: (a)bort (c)ontinue (p)roc info (i)nfo (l)oaded\n" + " (v)ersion (k)ill (D)b-tables (d)istribution\n"); + + while (1) { + if ((i = sys_get_key(0)) <= 0) + erl_exit(0, ""); + switch (i) { + case 'q': + case 'a': + case '*': /* + * The asterisk is an read error on windows, + * where sys_get_key isn't that great in console mode. + * The usual reason for a read error is Ctrl-C. Treat this as + * 'a' to avoid infinite loop. + */ + erl_exit(0, ""); + case 'A': /* Halt generating crash dump */ + erl_exit(1, "Crash dump requested by user"); + case 'c': + return; + case 'p': + process_info(ERTS_PRINT_STDOUT, NULL); + return; + case 'm': + return; + case 'o': + port_info(ERTS_PRINT_STDOUT, NULL); + return; + case 'i': + info(ERTS_PRINT_STDOUT, NULL); + return; + case 'l': + loaded(ERTS_PRINT_STDOUT, NULL); + return; + case 'v': + erts_printf("Erlang (%s) emulator version " + ERLANG_VERSION "\n", + EMULATOR); + erts_printf("Compiled on " ERLANG_COMPILE_DATE "\n"); + return; + case 'd': + distribution_info(ERTS_PRINT_STDOUT, NULL); + return; + case 'D': + db_info(ERTS_PRINT_STDOUT, NULL, 1); + return; + case 'k': + process_killer(); + return; +#ifdef OPPROF + case 'X': + dump_frequencies(); + return; + case 'x': + { + int i; + for (i = 0; i <= HIGHEST_OP; i++) { + if (opc[i].name != NULL) { + erts_printf("%-16s %8d\n", opc[i].name, opc[i].count); + } + } + } + return; + case 'z': + { + int i; + for (i = 0; i <= HIGHEST_OP; i++) + opc[i].count = 0; + } + return; +#endif +#ifdef DEBUG + case 't': + p_slpq(); + return; + case 'b': + bin_check(); + return; + case 'C': + abort(); +#endif + case '\n': + continue; + default: + erts_printf("Eh?\n\n"); + } + } + +} + + +#ifdef OPPROF +static void +dump_frequencies(void) +{ + int i; + FILE* fp; + time_t now; + static char name[] = "op_freq.dump"; + + fp = fopen(name, "w"); + if (fp == NULL) { + fprintf(stderr, "Failed to open %s for writing\n", name); + return; + } + + time(&now); + fprintf(fp, "# Generated %s\n", ctime(&now)); + + for (i = 0; i <= HIGHEST_OP; i++) { + if (opc[i].name != NULL) { + fprintf(fp, "%s %d\n", opc[i].name, opc[i].count); + } + } + fclose(fp); + erts_printf("Frequencies dumped to %s\n", name); +} +#endif + + +#ifdef DEBUG + +static void +bin_check(void) +{ + Process *rp; + ProcBin *bp; + int i, printed; + + for (i=0; i < erts_max_processes; i++) { + if ((rp = process_tab[i]) == NULL) + continue; + if (!(bp = rp->off_heap.mso)) + continue; + printed = 0; + while (bp) { + if (printed == 0) { + erts_printf("Process %T holding binary data \n", rp->id); + printed = 1; + } + erts_printf("0x%08lx orig_size: %ld, norefs = %ld\n", + (unsigned long)bp->val, + (long)bp->val->orig_size, + erts_smp_atomic_read(&bp->val->refc)); + + bp = bp->next; + } + if (printed == 1) + erts_printf("--------------------------------------\n"); + } + /* db_bin_check() has to be rewritten for the AVL trees... */ + /*db_bin_check();*/ +} + +#endif + +/* XXX THIS SHOULD BE IN SYSTEM !!!! */ +void +erl_crash_dump_v(char *file, int line, char* fmt, va_list args) +{ + int fd; + time_t now; + size_t dumpnamebufsize = MAXPATHLEN; + char dumpnamebuf[MAXPATHLEN]; + char* dumpname; + + if (ERTS_IS_CRASH_DUMPING) + return; + + /* Wait for all threads to block. If all threads haven't blocked + * after a minute, we go anyway and hope for the best... + * + * We do not release system again. We expect an exit() or abort() after + * dump has been written. + * + * NOTE: We allow gc therefore it is important not to lock *any* + * process locks. + */ + erts_smp_emergency_block_system(60000, ERTS_BS_FLG_ALLOW_GC); + /* Either worked or not... */ + + /* Allow us to pass certain places without locking... */ +#ifdef ERTS_SMP + erts_smp_atomic_inc(&erts_writing_erl_crash_dump); +#else + erts_writing_erl_crash_dump = 1; +#endif + + erts_sys_prepare_crash_dump(); + + if (erts_sys_getenv("ERL_CRASH_DUMP",&dumpnamebuf[0],&dumpnamebufsize) != 0) + dumpname = "erl_crash.dump"; + else + dumpname = &dumpnamebuf[0]; + + fd = open(dumpname,O_WRONLY | O_CREAT | O_TRUNC,0640); + if (fd < 0) + return; /* Can't create the crash dump, skip it */ + + time(&now); + erts_fdprintf(fd, "=erl_crash_dump:0.1\n%s", ctime(&now)); + + if (file != NULL) + erts_fdprintf(fd, "The error occurred in file %s, line %d\n", file, line); + + if (fmt != NULL && *fmt != '\0') { + erts_fdprintf(fd, "Slogan: "); + erts_vfdprintf(fd, fmt, args); + } + erts_fdprintf(fd, "System version: "); + erts_print_system_version(fd, NULL, NULL); + erts_fdprintf(fd, "%s\n", "Compiled: " ERLANG_COMPILE_DATE); + erts_fdprintf(fd, "Atoms: %d\n", atom_table_size()); + info(fd, NULL); /* General system info */ + if (process_tab != NULL) /* XXX true at init */ + process_info(fd, NULL); /* Info about each process and port */ + db_info(fd, NULL, 0); + erts_print_bif_timer_info(fd, NULL); + distribution_info(fd, NULL); + erts_fdprintf(fd, "=loaded_modules\n"); + loaded(fd, NULL); + erts_dump_fun_entries(fd, NULL); + erts_deep_process_dump(fd, NULL); + erts_fdprintf(fd, "=atoms\n"); + dump_atoms(fd, NULL); + + /* Keep the instrumentation data at the end of the dump */ + if (erts_instr_memory_map || erts_instr_stat) { + erts_fdprintf(fd, "=instr_data\n"); + + if (erts_instr_stat) { + erts_fdprintf(fd, "=memory_status\n"); + erts_instr_dump_stat_to_fd(fd, 0); + } + if (erts_instr_memory_map) { + erts_fdprintf(fd, "=memory_map\n"); + erts_instr_dump_memory_map_to_fd(fd); + } + } + + erts_fdprintf(fd, "=end\n"); + close(fd); + erts_fprintf(stderr,"\nCrash dump was written to: %s\n", dumpname); +} + +void +erl_crash_dump(char* file, int line, char* fmt, ...) +{ + va_list args; + + va_start(args, fmt); + erl_crash_dump_v(file, line, fmt, args); + va_end(args); +} diff --git a/erts/emulator/beam/copy.c b/erts/emulator/beam/copy.c new file mode 100644 index 0000000000..0a5050b1fe --- /dev/null +++ b/erts/emulator/beam/copy.c @@ -0,0 +1,981 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "erl_process.h" +#include "erl_gc.h" +#include "erl_nmgc.h" +#include "big.h" +#include "erl_binary.h" +#include "erl_bits.h" + +#ifdef HYBRID +MA_STACK_DECLARE(src); +MA_STACK_DECLARE(dst); +MA_STACK_DECLARE(offset); +#endif + +void +init_copy(void) +{ +#ifdef HYBRID + MA_STACK_ALLOC(src); + MA_STACK_ALLOC(dst); + MA_STACK_ALLOC(offset); +#endif +} + +/* + * Copy object "obj" to process p. + */ +Eterm +copy_object(Eterm obj, Process* to) +{ + Uint size = size_object(obj); + Eterm* hp = HAlloc(to, size); + Eterm res; + + res = copy_struct(obj, size, &hp, &to->off_heap); +#ifdef DEBUG + if (eq(obj, res) == 0) { + erl_exit(ERTS_ABORT_EXIT, "copy not equal to source\n"); + } +#endif + return res; +} + +/* + * Return the "flat" size of the object. + */ + +Uint +size_object(Eterm obj) +{ + Uint sum = 0; + Eterm* ptr; + int arity; + + DECLARE_ESTACK(s); + for (;;) { + switch (primary_tag(obj)) { + case TAG_PRIMARY_LIST: + sum += 2; + ptr = list_val(obj); + obj = *ptr++; + if (!IS_CONST(obj)) { + ESTACK_PUSH(s, obj); + } + obj = *ptr; + break; + case TAG_PRIMARY_BOXED: + { + Eterm hdr = *boxed_val(obj); + ASSERT(is_header(hdr)); + switch (hdr & _TAG_HEADER_MASK) { + case ARITYVAL_SUBTAG: + ptr = tuple_val(obj); + arity = header_arity(hdr); + sum += arity + 1; + if (arity == 0) { /* Empty tuple -- unusual. */ + goto size_common; + } + while (arity-- > 1) { + obj = *++ptr; + if (!IS_CONST(obj)) { + ESTACK_PUSH(s, obj); + } + } + obj = *++ptr; + break; + case FUN_SUBTAG: + { + Eterm* bptr = fun_val(obj); + ErlFunThing* funp = (ErlFunThing *) bptr; + unsigned eterms = 1 /* creator */ + funp->num_free; + unsigned sz = thing_arityval(hdr); + + sum += 1 /* header */ + sz + eterms; + bptr += 1 /* header */ + sz; + while (eterms-- > 1) { + obj = *bptr++; + if (!IS_CONST(obj)) { + ESTACK_PUSH(s, obj); + } + } + obj = *bptr; + break; + } + case SUB_BINARY_SUBTAG: + { + Eterm real_bin; + Uint offset; /* Not used. */ + Uint bitsize; + Uint bitoffs; + Uint extra_bytes; + Eterm hdr; + ERTS_GET_REAL_BIN(obj, real_bin, offset, bitoffs, bitsize); + if ((bitsize + bitoffs) > 8) { + sum += ERL_SUB_BIN_SIZE; + extra_bytes = 2; + } else if ((bitsize + bitoffs) > 0) { + sum += ERL_SUB_BIN_SIZE; + extra_bytes = 1; + } else { + extra_bytes = 0; + } + hdr = *binary_val(real_bin); + if (thing_subtag(hdr) == REFC_BINARY_SUBTAG) { + sum += PROC_BIN_SIZE; + } else { + sum += heap_bin_size(binary_size(obj)+extra_bytes); + } + goto size_common; + } + break; + case BIN_MATCHSTATE_SUBTAG: + erl_exit(ERTS_ABORT_EXIT, + "size_object: matchstate term not allowed"); + default: + sum += thing_arityval(hdr) + 1; + /* Fall through */ + size_common: + if (ESTACK_ISEMPTY(s)) { + DESTROY_ESTACK(s); + return sum; + } + obj = ESTACK_POP(s); + break; + } + } + break; + case TAG_PRIMARY_IMMED1: + if (ESTACK_ISEMPTY(s)) { + DESTROY_ESTACK(s); + return sum; + } + obj = ESTACK_POP(s); + break; + default: + erl_exit(ERTS_ABORT_EXIT, "size_object: bad tag for %#x\n", obj); + } + } +} + +/* + * Copy a structure to a heap. + */ +Eterm +copy_struct(Eterm obj, Uint sz, Eterm** hpp, ErlOffHeap* off_heap) +{ + char* hstart; + Uint hsize; + Eterm* htop; + Eterm* hbot; + Eterm* hp; + Eterm* objp; + Eterm* tp; + Eterm res; + Eterm elem; + Eterm* tailp; + Eterm* argp; + Eterm* const_tuple; + Eterm hdr; + int i; +#ifdef DEBUG + Eterm org_obj = obj; + Uint org_sz = sz; +#endif + + if (IS_CONST(obj)) + return obj; + + hp = htop = *hpp; + hbot = htop + sz; + hstart = (char *)htop; + hsize = (char*) hbot - hstart; + const_tuple = 0; + + /* Copy the object onto the heap */ + switch (primary_tag(obj)) { + case TAG_PRIMARY_LIST: argp = &res; goto L_copy_list; + case TAG_PRIMARY_BOXED: argp = &res; goto L_copy_boxed; + default: + erl_exit(ERTS_ABORT_EXIT, + "%s, line %d: Internal error in copy_struct: 0x%08x\n", + __FILE__, __LINE__,obj); + } + + L_copy: + while (hp != htop) { + obj = *hp; + + switch (primary_tag(obj)) { + case TAG_PRIMARY_IMMED1: + hp++; + break; + case TAG_PRIMARY_LIST: + objp = list_val(obj); + if (in_area(objp,hstart,hsize)) { + hp++; + break; + } + argp = hp++; + /* Fall through */ + + L_copy_list: + tailp = argp; + while (is_list(obj)) { + objp = list_val(obj); + tp = tailp; + elem = *objp; + if (IS_CONST(elem)) { + *(hbot-2) = elem; + tailp = hbot-1; + hbot -= 2; + } + else { + *htop = elem; + tailp = htop+1; + htop += 2; + } + *tp = make_list(tailp - 1); + obj = *(objp+1); + } + switch (primary_tag(obj)) { + case TAG_PRIMARY_IMMED1: *tailp = obj; goto L_copy; + case TAG_PRIMARY_BOXED: argp = tailp; goto L_copy_boxed; + default: + erl_exit(ERTS_ABORT_EXIT, + "%s, line %d: Internal error in copy_struct: 0x%08x\n", + __FILE__, __LINE__,obj); + } + + case TAG_PRIMARY_BOXED: + if (in_area(boxed_val(obj),hstart,hsize)) { + hp++; + break; + } + argp = hp++; + + L_copy_boxed: + objp = boxed_val(obj); + hdr = *objp; + switch (hdr & _TAG_HEADER_MASK) { + case ARITYVAL_SUBTAG: + { + int const_flag = 1; /* assume constant tuple */ + i = arityval(hdr); + *argp = make_tuple(htop); + tp = htop; /* tp is pointer to new arity value */ + *htop++ = *objp++; /* copy arity value */ + while (i--) { + elem = *objp++; + if (!IS_CONST(elem)) { + const_flag = 0; + } + *htop++ = elem; + } + if (const_flag) { + const_tuple = tp; /* this is the latest const_tuple */ + } + } + break; + case REFC_BINARY_SUBTAG: + { + ProcBin* pb; + + pb = (ProcBin *) objp; + if (pb->flags) { + erts_emasculate_writable_binary(pb); + } + i = thing_arityval(*objp) + 1; + hbot -= i; + tp = hbot; + while (i--) { + *tp++ = *objp++; + } + *argp = make_binary(hbot); + pb = (ProcBin*) hbot; + erts_refc_inc(&pb->val->refc, 2); + pb->next = off_heap->mso; + pb->flags = 0; + off_heap->mso = pb; + off_heap->overhead += pb->size / sizeof(Eterm); + } + break; + case SUB_BINARY_SUBTAG: + { + ErlSubBin* sb = (ErlSubBin *) objp; + Eterm real_bin = sb->orig; + Uint bit_offset = sb->bitoffs; + Uint bit_size = sb -> bitsize; + Uint offset = sb->offs; + size_t size = sb->size; + Uint extra_bytes; + Uint real_size; + if ((bit_size + bit_offset) > 8) { + extra_bytes = 2; + } else if ((bit_size + bit_offset) > 0) { + extra_bytes = 1; + } else { + extra_bytes = 0; + } + real_size = size+extra_bytes; + objp = binary_val(real_bin); + if (thing_subtag(*objp) == HEAP_BINARY_SUBTAG) { + ErlHeapBin* from = (ErlHeapBin *) objp; + ErlHeapBin* to; + i = heap_bin_size(real_size); + hbot -= i; + to = (ErlHeapBin *) hbot; + to->thing_word = header_heap_bin(real_size); + to->size = real_size; + sys_memcpy(to->data, ((byte *)from->data)+offset, real_size); + } else { + ProcBin* from = (ProcBin *) objp; + ProcBin* to; + + ASSERT(thing_subtag(*objp) == REFC_BINARY_SUBTAG); + if (from->flags) { + erts_emasculate_writable_binary(from); + } + hbot -= PROC_BIN_SIZE; + to = (ProcBin *) hbot; + to->thing_word = HEADER_PROC_BIN; + to->size = real_size; + to->val = from->val; + erts_refc_inc(&to->val->refc, 2); + to->bytes = from->bytes + offset; + to->next = off_heap->mso; + to->flags = 0; + off_heap->mso = to; + off_heap->overhead += to->size / sizeof(Eterm); + } + *argp = make_binary(hbot); + if (extra_bytes != 0) { + ErlSubBin* res; + hbot -= ERL_SUB_BIN_SIZE; + res = (ErlSubBin *) hbot; + res->thing_word = HEADER_SUB_BIN; + res->size = size; + res->bitsize = bit_size; + res->bitoffs = bit_offset; + res->offs = 0; + res->is_writable = 0; + res->orig = *argp; + *argp = make_binary(hbot); + } + break; + } + break; + case FUN_SUBTAG: + { + ErlFunThing* funp = (ErlFunThing *) objp; + + i = thing_arityval(hdr) + 2 + funp->num_free; + tp = htop; + while (i--) { + *htop++ = *objp++; + } +#ifndef HYBRID /* FIND ME! */ + funp = (ErlFunThing *) tp; + funp->next = off_heap->funs; + off_heap->funs = funp; + erts_refc_inc(&funp->fe->refc, 2); +#endif + *argp = make_fun(tp); + } + break; + case EXTERNAL_PID_SUBTAG: + case EXTERNAL_PORT_SUBTAG: + case EXTERNAL_REF_SUBTAG: + { + ExternalThing *etp = (ExternalThing *) htop; + + i = thing_arityval(hdr) + 1; + tp = htop; + + while (i--) { + *htop++ = *objp++; + } + + etp->next = off_heap->externals; + off_heap->externals = etp; + erts_refc_inc(&etp->node->refc, 2); + + *argp = make_external(tp); + } + break; + case BIN_MATCHSTATE_SUBTAG: + erl_exit(ERTS_ABORT_EXIT, + "copy_struct: matchstate term not allowed"); + default: + i = thing_arityval(hdr)+1; + hbot -= i; + tp = hbot; + *argp = make_boxed(hbot); + while (i--) { + *tp++ = *objp++; + } + } + break; + case TAG_PRIMARY_HEADER: + if (header_is_thing(obj) || hp == const_tuple) { + hp += header_arity(obj) + 1; + } else { + hp++; + } + break; + } + } + +#ifdef DEBUG + if (htop != hbot) + erl_exit(ERTS_ABORT_EXIT, + "Internal error in copy_struct() when copying %T:" + " htop=%p != hbot=%p (sz=%bpu)\n", + org_obj, htop, hbot, org_sz); +#else + if (htop > hbot) { + erl_exit(ERTS_ABORT_EXIT, + "Internal error in copy_struct(): htop, hbot overrun\n"); + } +#endif + *hpp = (Eterm *) (hstart+hsize); + return res; +} + +#ifdef HYBRID + +#ifdef BM_MESSAGE_SIZES +# define BM_ADD(var,val) (var) += (val); +#else +# define BM_ADD(var,val) +#endif + +#ifdef DEBUG +# define CLEARMEM(PTR,SIZE) memset(PTR,0,SIZE*sizeof(Eterm)) +#else +# define CLEARMEM(PTR,SIZE) +#endif + +#ifdef INCREMENTAL +#define GlobalAlloc(p, need, hp) \ +do { \ + Uint n = (need); \ + BM_ADD(words_copied,n); \ + BM_SWAP_TIMER(copy,system); \ + /* If a new collection cycle is started during copy, the message * \ + * will end up in the old generation and all allocations * \ + * thereafter must go directly into the old generation. */ \ + if (alloc_old) { \ + erts_incremental_gc((p),n,&dest,1); \ + (hp) = erts_inc_alloc(n); \ + } else { \ + (hp) = IncAlloc((p),n,&dest,1); \ + if (ma_gc_flags & GC_CYCLE_START) { \ + alloc_old = 1; \ + global_htop = global_heap; \ + (hp) = erts_inc_alloc(n); \ + } \ + } \ + CLEARMEM((hp),(n)); \ + BM_SWAP_TIMER(system,copy); \ +} while(0) + +#else /* no INCREMELNTAL */ + +#define GlobalAlloc(p, need, hp) \ +do { \ + Uint n = (need); \ + total_need += n; \ + if (total_need >= global_heap_sz) \ + erl_exit(ERTS_ABORT_EXIT, "Copying a message (%d words) larger than the nursery simply won't work...\n", total_need); \ + if (global_hend - n < global_htop) { \ + BM_SWAP_TIMER(copy,system); \ + erts_global_garbage_collect((p),total_need,NULL,0); \ + BM_SWAP_TIMER(system,copy); \ + total_need = 0; \ + ma_src_top = 0; \ + ma_dst_top = 0; \ + ma_offset_top = 0; \ + goto copy_start; \ + } \ + (hp) = global_htop; \ + global_htop += n; \ + BM_ADD(words_copied,n); \ +} while(0) +#endif /* INCREMENTAL */ + +/* Copy a message to the message area. */ +Eterm copy_struct_lazy(Process *from, Eterm orig, Uint offs) +{ + Eterm obj; + Eterm dest; +#ifdef INCREMENTAL + int alloc_old = 0; +#else + int total_need = 0; +#endif + + VERBOSE(DEBUG_MESSAGES, + ("COPY START; %T is sending a message @ 0x%016x\n%T\n", + from->id, orig, orig)); + +#ifndef INCREMENTAL + copy_start: +#endif + MA_STACK_PUSH(src,orig); + MA_STACK_PUSH(dst,&dest); + MA_STACK_PUSH(offset,offs); + + while (ma_src_top > 0) { + obj = MA_STACK_POP(src); + + /* copy_struct_lazy should never be called with something that + * do not need to be copied. Within the loop, nothing that do + * not need copying should be placed in the src-stack. + */ + ASSERT(!NO_COPY(obj)); + + switch (primary_tag(obj)) { + case TAG_PRIMARY_LIST: { + Eterm *hp; + Eterm *objp; + + GlobalAlloc(from,2,hp); + objp = list_val(obj); + + MA_STACK_UPDATE(dst,MA_STACK_POP(offset),make_list(hp)); + MA_STACK_POP(dst); + + /* TODO: Byt ordningen nedan sÃ¥ att CDR pushas först. */ + + if (NO_COPY(*objp)) { + hp[0] = *objp; +#ifdef INCREMENTAL + if (ptr_within(ptr_val(*objp),inc_fromspc,inc_fromend)) + INC_STORE(gray,hp,2); +#endif + } else { + MA_STACK_PUSH(src,*objp); + MA_STACK_PUSH(dst,hp); + MA_STACK_PUSH(offset,0); + } + + objp++; + + if (NO_COPY(*objp)) { + hp[1] = *objp; +#ifdef INCREMENTAL + if (ptr_within(ptr_val(*objp),inc_fromspc,inc_fromend)) + INC_STORE(gray,hp,2); +#endif + } + else { + MA_STACK_PUSH(src,*objp); + MA_STACK_PUSH(dst,hp); + MA_STACK_PUSH(offset,1); + } + continue; + } + + case TAG_PRIMARY_BOXED: { + Eterm *objp = boxed_val(obj); + + switch (*objp & _TAG_HEADER_MASK) { + case ARITYVAL_SUBTAG: { + Uint ari = arityval(*objp); + Uint i; + Eterm *hp; + GlobalAlloc(from,ari + 1,hp); + /* A GC above might invalidate the value of objp */ + objp = boxed_val(obj); + MA_STACK_UPDATE(dst,MA_STACK_POP(offset),make_tuple(hp)); + MA_STACK_POP(dst); + *hp = *objp++; + for (i = 1; i <= ari; i++) { + switch (primary_tag(*objp)) { + case TAG_PRIMARY_LIST: + case TAG_PRIMARY_BOXED: + if (NO_COPY(*objp)) { + hp[i] = *objp; +#ifdef INCREMENTAL + if (ptr_within(ptr_val(*objp), + inc_fromspc,inc_fromend)) + INC_STORE(gray,hp,BOXED_NEED(hp,*hp)); +#endif + objp++; + } else { + MA_STACK_PUSH(src,*objp++); + MA_STACK_PUSH(dst,hp); + MA_STACK_PUSH(offset,i); + } + break; + default: + hp[i] = *objp++; + } + } + continue; + } + + case REFC_BINARY_SUBTAG: { + ProcBin *pb; + Uint i = thing_arityval(*objp) + 1; + Eterm *hp; + GlobalAlloc(from,i,hp); + /* A GC above might invalidate the value of objp */ + objp = boxed_val(obj); + MA_STACK_UPDATE(dst,MA_STACK_POP(offset),make_binary(hp)); + MA_STACK_POP(dst); + pb = (ProcBin*) hp; + while (i--) { + *hp++ = *objp++; + } + erts_refc_inc(&pb->val->refc, 2); + pb->next = erts_global_offheap.mso; + erts_global_offheap.mso = pb; + erts_global_offheap.overhead += pb->size / sizeof(Eterm); + continue; + } + + case FUN_SUBTAG: { + ErlFunThing *funp = (ErlFunThing*) objp; + Uint i = thing_arityval(*objp) + 1; + Uint j = i + 1 + funp->num_free; + Uint k = i; + Eterm *hp, *hp_start; + GlobalAlloc(from,j,hp); + /* A GC above might invalidate the value of objp */ + objp = boxed_val(obj); + hp_start = hp; + MA_STACK_UPDATE(dst,MA_STACK_POP(offset),make_fun(hp)); + MA_STACK_POP(dst); + funp = (ErlFunThing*) hp; + while (i--) { + *hp++ = *objp++; + } +#ifndef HYBRID // FIND ME! + funp->next = erts_global_offheap.funs; + erts_global_offheap.funs = funp; + erts_refc_inc(&funp->fe->refc, 2); +#endif + for (i = k; i < j; i++) { + switch (primary_tag(*objp)) { + case TAG_PRIMARY_LIST: + case TAG_PRIMARY_BOXED: + if (NO_COPY(*objp)) { +#ifdef INCREMENTAL + if (ptr_within(ptr_val(*objp), + inc_fromspc,inc_fromend)) + INC_STORE(gray,hp,BOXED_NEED(hp,*hp)); +#endif + *hp++ = *objp++; + } else { + MA_STACK_PUSH(src,*objp++); + MA_STACK_PUSH(dst,hp_start); + MA_STACK_PUSH(offset,i); + hp++; + } + break; + default: + *hp++ = *objp++; + } + } + continue; + } + + case EXTERNAL_PID_SUBTAG: + case EXTERNAL_PORT_SUBTAG: + case EXTERNAL_REF_SUBTAG: { + ExternalThing *etp; + Uint i = thing_arityval(*objp) + 1; + Eterm *hp; + GlobalAlloc(from,i,hp); + /* A GC above might invalidate the value of objp */ + objp = boxed_val(obj); + MA_STACK_UPDATE(dst,MA_STACK_POP(offset),make_external(hp)); + MA_STACK_POP(dst); + etp = (ExternalThing*) hp; + while (i--) { + *hp++ = *objp++; + } + + etp->next = erts_global_offheap.externals; + erts_global_offheap.externals = etp; + erts_refc_inc(&etp->node->refc, 2); + continue; + } + + case SUB_BINARY_SUBTAG: { + ErlSubBin *sb = (ErlSubBin *) objp; + Eterm *hp; + Eterm res_binary; + Eterm real_bin = sb->orig; + Uint bit_offset = sb->bitoffs; + Uint bit_size = sb -> bitsize; + Uint sub_offset = sb->offs; + size_t size = sb->size; + Uint extra_bytes; + Uint real_size; + Uint sub_binary_heapneed; + if ((bit_size + bit_offset) > 8) { + extra_bytes = 2; + sub_binary_heapneed = ERL_SUB_BIN_SIZE; + } else if ((bit_size + bit_offset) > 0) { + extra_bytes = 1; + sub_binary_heapneed = ERL_SUB_BIN_SIZE; + } else { + extra_bytes = 0; + sub_binary_heapneed = 0; + } + + real_size = size+extra_bytes; + objp = binary_val(real_bin); + if (thing_subtag(*objp) == HEAP_BINARY_SUBTAG) { + ErlHeapBin *from_bin; + ErlHeapBin *to_bin; + Uint i = heap_bin_size(real_size); + GlobalAlloc(from,i+sub_binary_heapneed,hp); + from_bin = (ErlHeapBin *) objp; + to_bin = (ErlHeapBin *) hp; + to_bin->thing_word = header_heap_bin(real_size); + to_bin->size = real_size; + sys_memcpy(to_bin->data, ((byte *)from_bin->data) + + sub_offset, real_size); + res_binary = make_binary(to_bin); + hp += i; + } else { + ProcBin *from_bin; + ProcBin *to_bin; + + ASSERT(thing_subtag(*objp) == REFC_BINARY_SUBTAG); + from_bin = (ProcBin *) objp; + erts_refc_inc(&from_bin->val->refc, 2); + GlobalAlloc(from,PROC_BIN_SIZE+sub_binary_heapneed,hp); + to_bin = (ProcBin *) hp; + to_bin->thing_word = HEADER_PROC_BIN; + to_bin->size = real_size; + to_bin->val = from_bin->val; + to_bin->bytes = from_bin->bytes + sub_offset; + to_bin->next = erts_global_offheap.mso; + erts_global_offheap.mso = to_bin; + erts_global_offheap.overhead += to_bin->size / sizeof(Eterm); + res_binary=make_binary(to_bin); + hp += PROC_BIN_SIZE; + } + if (extra_bytes != 0) { + ErlSubBin* res; + res = (ErlSubBin *) hp; + res->thing_word = HEADER_SUB_BIN; + res->size = size; + res->bitsize = bit_size; + res->bitoffs = bit_offset; + res->offs = 0; + res->is_writable = 0; + res->orig = res_binary; + res_binary = make_binary(hp); + } + MA_STACK_UPDATE(dst,MA_STACK_POP(offset),res_binary); + MA_STACK_POP(dst); + continue; + } + + case BIN_MATCHSTATE_SUBTAG: + erl_exit(ERTS_ABORT_EXIT, + "copy_struct_lazy: matchstate term not allowed"); + + default: { + Uint size = thing_arityval(*objp) + 1; + Eterm *hp; + GlobalAlloc(from,size,hp); + /* A GC above might invalidate the value of objp */ + objp = boxed_val(obj); + MA_STACK_UPDATE(dst,MA_STACK_POP(offset),make_boxed(hp)); + MA_STACK_POP(dst); + while (size--) { + *hp++ = *objp++; + } + continue; + } + } + continue; + } + + case TAG_PRIMARY_HEADER: + ASSERT((obj & _TAG_HEADER_MASK) == ARITYVAL_SUBTAG); + { + Eterm *objp = &obj; + Uint ari = arityval(obj); + Uint i; + Eterm *hp; + GlobalAlloc(from,ari + 1,hp); + MA_STACK_UPDATE(dst,MA_STACK_POP(offset),make_tuple(hp)); + MA_STACK_POP(dst); + *hp = *objp++; + for (i = 1; i <= ari; i++) { + switch (primary_tag(*objp)) { + case TAG_PRIMARY_LIST: + case TAG_PRIMARY_BOXED: + if (NO_COPY(*objp)) { +#ifdef INCREMENTAL + if (ptr_within(ptr_val(*objp),inc_fromspc,inc_fromend)) + INC_STORE(gray,hp,ari + 1); +#endif + hp[i] = *objp++; + } else { + MA_STACK_PUSH(src,*objp++); + MA_STACK_PUSH(dst,hp); + MA_STACK_PUSH(offset,i); + } + break; + default: + hp[i] = *objp++; + } + } + continue; + } + + default: + erl_exit(ERTS_ABORT_EXIT, + "%s, line %d: Internal error in copy_struct_lazy: 0x%08x\n", + __FILE__, __LINE__,obj); + } + } + + VERBOSE(DEBUG_MESSAGES, + ("Copy allocated @ 0x%08lx:\n%T\n", + (unsigned long)ptr_val(dest),dest)); + + ma_gc_flags &= ~GC_CYCLE_START; + + ASSERT(eq(orig, dest)); + ASSERT(ma_src_top == 0); + ASSERT(ma_dst_top == 0); + ASSERT(ma_offset_top == 0); + return dest; +} + +#undef NO_COPY +#endif /* HYBRID */ + +/* + * Copy a term that is guaranteed to be contained in a single + * heap block. The heap block is copied word by word, and any + * pointers are offsetted to point correctly in the new location. + * + * Typically used to copy a term from an ets table. + * + * NOTE: Assumes that term is a tuple (ptr is an untagged tuple ptr). + */ +Eterm +copy_shallow(Eterm* ptr, Uint sz, Eterm** hpp, ErlOffHeap* off_heap) +{ + Eterm* tp = ptr; + Eterm* hp = *hpp; + Sint offs = hp - tp; + + while (sz--) { + Eterm val = *tp++; + + switch (primary_tag(val)) { + case TAG_PRIMARY_IMMED1: + *hp++ = val; + break; + case TAG_PRIMARY_LIST: + case TAG_PRIMARY_BOXED: + *hp++ = offset_ptr(val, offs); + break; + case TAG_PRIMARY_HEADER: + *hp++ = val; + switch (val & _HEADER_SUBTAG_MASK) { + case ARITYVAL_SUBTAG: + break; + case REFC_BINARY_SUBTAG: + { + ProcBin* pb = (ProcBin *) (hp-1); + int tari = thing_arityval(val); + + sz -= tari; + while (tari--) { + *hp++ = *tp++; + } + erts_refc_inc(&pb->val->refc, 2); + pb->next = off_heap->mso; + off_heap->mso = pb; + off_heap->overhead += pb->size / sizeof(Eterm); + } + break; + case FUN_SUBTAG: + { +#ifndef HYBRID /* FIND ME! */ + ErlFunThing* funp = (ErlFunThing *) (hp-1); +#endif + int tari = thing_arityval(val); + + sz -= tari; + while (tari--) { + *hp++ = *tp++; + } +#ifndef HYBRID /* FIND ME! */ + funp->next = off_heap->funs; + off_heap->funs = funp; + erts_refc_inc(&funp->fe->refc, 2); +#endif + } + break; + case EXTERNAL_PID_SUBTAG: + case EXTERNAL_PORT_SUBTAG: + case EXTERNAL_REF_SUBTAG: + { + ExternalThing* etp = (ExternalThing *) (hp-1); + int tari = thing_arityval(val); + + sz -= tari; + while (tari--) { + *hp++ = *tp++; + } + etp->next = off_heap->externals; + off_heap->externals = etp; + erts_refc_inc(&etp->node->refc, 2); + } + break; + default: + { + int tari = header_arity(val); + + sz -= tari; + while (tari--) { + *hp++ = *tp++; + } + } + break; + } + break; + } + } + *hpp = hp; + return make_tuple(ptr + offs); +} diff --git a/erts/emulator/beam/decl.h b/erts/emulator/beam/decl.h new file mode 100644 index 0000000000..da1be29d53 --- /dev/null +++ b/erts/emulator/beam/decl.h @@ -0,0 +1,55 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifndef __DECL_H__ +#define __DECL_H__ + +#if defined(__STDC__) || defined(_MSC_VER) +#define EXTERN_FUNCTION(t, f, x) extern t f x +#define FUNCTION(t, f, x) t f x +#define _DOTS_ ... +#define _VOID_ void +#elif defined(__cplusplus) +#define EXTERN_FUNCTION(f, x) extern "C" { f x } +#define FUNCTION(t, f, x) t f x +#define _DOTS_ ... +#define _VOID_ void +#else +#define EXTERN_FUNCTION(t, f, x) extern t f (/*x*/) +#define FUNCTION(t, f, x) t f (/*x*/) +#define _DOTS_ +#define _VOID_ +#endif + +/* +** Example of declarations +** +** EXTERN_FUNCTION(void, foo, (int, int, char)); +** FUNCTION(void, bar, (int, char)); +** +** struct funcs { +** FUNCTION(int*, (*f1), (int, int)); +** FUNCTION(void, (*f2), (int, char)); +** FUNCTION(void, (*f3), (_VOID_)); +** FUNCTION(int, (*f4), (char*, _DOTS_)); +** }; +** +*/ + +#endif diff --git a/erts/emulator/beam/dist.c b/erts/emulator/beam/dist.c new file mode 100644 index 0000000000..e3094404e2 --- /dev/null +++ b/erts/emulator/beam/dist.c @@ -0,0 +1,3256 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* + * distribution of erlang messages to other nodes. + */ + + +/* define this to get a lot of debug output */ +/* #define ERTS_DIST_MSG_DBG */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#define ERTS_WANT_EXTERNAL_TAGS + +#include +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "erl_process.h" +#include "error.h" +#include "dist.h" +#include "bif.h" +#include "external.h" +#include "erl_binary.h" + +/* Turn this on to get printouts of all distribution messages + * which go on the line + */ +#if 0 +#define ERTS_DIST_MSG_DBG +#endif +#if 0 +#define ERTS_RAW_DIST_MSG_DBG +#endif + +#if defined(ERTS_DIST_MSG_DBG) || defined(ERTS_RAW_DIST_MSG_DBG) +static void bw(byte *buf, int sz) +{ + bin_write(ERTS_PRINT_STDERR,NULL,buf,sz); +} +#endif + +#ifdef ERTS_DIST_MSG_DBG +static void +dist_msg_dbg(ErtsDistExternal *edep, char *what, byte *buf, int sz) +{ + byte *extp = edep->extp; + Eterm msg; + Sint size = erts_decode_dist_ext_size(edep, 0); + if (size < 0) { + erts_fprintf(stderr, + "DIST MSG DEBUG: erts_decode_dist_ext_size(%s) failed:\n", + what); + bw(buf, sz); + } + else { + Eterm *hp; + ErlHeapFragment *mbuf = new_message_buffer(size); + hp = mbuf->mem; + msg = erts_decode_dist_ext(&hp, &mbuf->off_heap, edep); + if (is_value(msg)) + erts_fprintf(stderr, " %s: %T\n", what, msg); + else { + erts_fprintf(stderr, + "DIST MSG DEBUG: erts_decode_dist_ext(%s) failed:\n", + what); + bw(buf, sz); + } + free_message_buffer(mbuf); + edep->extp = extp; + } +} + +#endif + + + +#define PASS_THROUGH 'p' /* This code should go */ + +int erts_is_alive; /* System must be blocked on change */ + +/* distribution trap functions */ +Export* dsend2_trap = NULL; +Export* dsend3_trap = NULL; +/*Export* dsend_nosuspend_trap = NULL;*/ +Export* dlink_trap = NULL; +Export* dunlink_trap = NULL; +Export* dmonitor_node_trap = NULL; +Export* dgroup_leader_trap = NULL; +Export* dexit_trap = NULL; +Export* dmonitor_p_trap = NULL; + +/* local variables */ + + +/* forward declarations */ + +static void clear_dist_entry(DistEntry*); +static int dsig_send(ErtsDSigData *, Eterm, Eterm, int); +static void send_nodes_mon_msgs(Process *, Eterm, Eterm, Eterm, Eterm); +static void init_nodes_monitors(void); + +static erts_smp_atomic_t no_caches; + +static void +delete_cache(ErtsAtomCache *cache) +{ + if (cache) { + erts_free(ERTS_ALC_T_DCACHE, (void *) cache); + ASSERT(erts_smp_atomic_read(&no_caches) > 0); + erts_smp_atomic_dec(&no_caches); + } +} + + +static void +create_cache(DistEntry *dep) +{ + int i; + ErtsAtomCache *cp; + + ERTS_SMP_LC_ASSERT( + is_internal_port(dep->cid) + && erts_lc_is_port_locked(&erts_port[internal_port_index(dep->cid)])); + ASSERT(!dep->cache); + + dep->cache = cp = (ErtsAtomCache*) erts_alloc(ERTS_ALC_T_DCACHE, + sizeof(ErtsAtomCache)); + erts_smp_atomic_inc(&no_caches); + for (i = 0; i < sizeof(cp->in_arr)/sizeof(cp->in_arr[0]); i++) { + cp->in_arr[i] = THE_NON_VALUE; + cp->out_arr[i] = THE_NON_VALUE; + } +} + +Uint erts_dist_cache_size(void) +{ + return (Uint) erts_smp_atomic_read(&no_caches)*sizeof(ErtsAtomCache); +} + +static ErtsProcList * +get_suspended_on_de(DistEntry *dep, Uint32 unset_qflgs) +{ + ERTS_SMP_LC_ASSERT(erts_smp_lc_spinlock_is_locked(&dep->qlock)); + dep->qflgs &= ~unset_qflgs; + if (dep->qflgs & ERTS_DE_QFLG_EXIT) { + /* No resume when exit has been scheduled */ + return NULL; + } + else { + ErtsProcList *plp; + plp = dep->suspended.first; + dep->suspended.first = NULL; + dep->suspended.last = NULL; + return plp; + } +} + +/* +** A full node name constists of a "n@h" +** +** n must be a valid node name: string of ([a-z][A-Z][0-9]_-)+ +** +** h is not checked at all, we assume that we have a properly +** configured machine where the networking is ok for the OS +** +** We do check that there is not a second @ in the string, since +** many distributed operations are guaranteed not to work then. +*/ + + +static int is_node_name(char *ptr, int len) +{ + int c = '\0'; /* suppress use-before-set warning */ + int pos = 0; + + while (pos < len) { + c = ptr[pos++]; + if (! ((c == '-') || (c == '_') || + ((c >= 'a') && (c <= 'z')) || + ((c >= 'A') && (c <= 'Z')) || + ((c >= '0') && (c <= '9')))) + break; + } + + /* Scanned past the host name: now we want to see a '@', and there + should be text both before and after it. */ + if (c != '@' || pos < 2 || pos == len) + return 0; + + while (pos < len) { + c = ptr[pos++]; + if (c == '@') + return 0; + } + + return 1; +} + +int is_node_name_atom(Eterm a) +{ + int i; + if(is_not_atom(a)) + return 0; + i = atom_val(a); + ASSERT((i > 0) && (i < atom_table_size()) && (atom_tab(i) != NULL)); + return is_node_name((char*)atom_tab(i)->name, atom_tab(i)->len); +} + +typedef struct { + DistEntry *dep; +} NetExitsContext; + +/* +** This function is called when a distribution +** port or process terminates +*/ +static void doit_monitor_net_exits(ErtsMonitor *mon, void *vnecp) +{ + Process *rp; + ErtsMonitor *rmon; + DistEntry *dep = ((NetExitsContext *) vnecp)->dep; + ErtsProcLocks rp_locks = ERTS_PROC_LOCK_LINK; + + rp = erts_pid2proc(NULL, 0, mon->pid, rp_locks); + if (!rp) + goto done; + + if (mon->type == MON_ORIGIN) { + /* local pid is beeing monitored */ + rmon = erts_remove_monitor(&(rp->monitors),mon->ref); + /* ASSERT(rmon != NULL); nope, can happen during process exit */ + if (rmon != NULL) { + erts_destroy_monitor(rmon); + } + } else { + Eterm lhp[3]; + Eterm watched; + ASSERT(mon->type == MON_TARGET); + rmon = erts_remove_monitor(&(rp->monitors),mon->ref); + /* ASSERT(rmon != NULL); can happen during process exit */ + if (rmon != NULL) { + ASSERT(is_atom(rmon->name) || is_nil(rmon->name)); + watched = (is_atom(rmon->name) + ? TUPLE2(lhp, rmon->name, dep->sysname) + : rmon->pid); +#ifdef ERTS_SMP + rp_locks |= ERTS_PROC_LOCKS_MSG_SEND; + erts_smp_proc_lock(rp, ERTS_PROC_LOCKS_MSG_SEND); +#endif + erts_queue_monitor_message(rp, &rp_locks, mon->ref, am_process, + watched, am_noconnection); + erts_destroy_monitor(rmon); + } + } + erts_smp_proc_unlock(rp, rp_locks); + done: + erts_destroy_monitor(mon); +} + +typedef struct { + NetExitsContext *necp; + ErtsLink *lnk; +} LinkNetExitsContext; + +/* +** This is the function actually doing the job of sending exit messages +** for links in a dist entry upon net_exit (the node goes down), NB, +** only process links, not node monitors are handled here, +** they reside in a separate tree.... +*/ +static void doit_link_net_exits_sub(ErtsLink *sublnk, void *vlnecp) +{ + ErtsLink *lnk = ((LinkNetExitsContext *) vlnecp)->lnk; /* the local pid */ + ErtsLink *rlnk; + Process *rp; + + ASSERT(lnk->type == LINK_PID); + if (is_internal_pid(lnk->pid)) { + int xres; + ErtsProcLocks rp_locks = ERTS_PROC_LOCK_LINK|ERTS_PROC_LOCKS_XSIG_SEND; + + rp = erts_pid2proc(NULL, 0, lnk->pid, rp_locks); + if (!rp) { + goto done; + } + + rlnk = erts_remove_link(&(rp->nlinks), sublnk->pid); + xres = erts_send_exit_signal(NULL, + sublnk->pid, + rp, + &rp_locks, + am_noconnection, + NIL, + NULL, + 0); + + if (rlnk) { + erts_destroy_link(rlnk); + if (xres >= 0 && IS_TRACED_FL(rp, F_TRACE_PROCS)) { + /* We didn't exit the process and it is traced */ + trace_proc(NULL, rp, am_getting_unlinked, sublnk->pid); + } + } + erts_smp_proc_unlock(rp, rp_locks); + } + done: + erts_destroy_link(sublnk); + +} + + + + + +/* +** This function is called when a distribution +** port or process terminates, once for each link on the high level, +** it in turn traverses the link subtree for the specific link node... +*/ +static void doit_link_net_exits(ErtsLink *lnk, void *vnecp) +{ + LinkNetExitsContext lnec = {(NetExitsContext *) vnecp, lnk}; + ASSERT(lnk->type == LINK_PID) + erts_sweep_links(ERTS_LINK_ROOT(lnk), &doit_link_net_exits_sub, (void *) &lnec); +#ifdef DEBUG + ERTS_LINK_ROOT(lnk) = NULL; +#endif + erts_destroy_link(lnk); +} + + +static void doit_node_link_net_exits(ErtsLink *lnk, void *vnecp) +{ + DistEntry *dep = ((NetExitsContext *) vnecp)->dep; + Eterm name = dep->sysname; + Process *rp; + ErtsLink *rlnk; + Uint i,n; + ASSERT(lnk->type == LINK_NODE) + if (is_internal_pid(lnk->pid)) { + ErtsProcLocks rp_locks = ERTS_PROC_LOCK_LINK; + rp = erts_pid2proc(NULL, 0, lnk->pid, rp_locks); + if (!rp) { + goto done; + } + rlnk = erts_remove_link(&(rp->nlinks), name); + if (rlnk != NULL) { + ASSERT(is_atom(rlnk->pid) && (rlnk->type == LINK_NODE)); + erts_destroy_link(rlnk); + } + n = ERTS_LINK_REFC(lnk); + for (i = 0; i < n; ++i) { + ErlHeapFragment* bp; + ErlOffHeap *ohp; + Eterm tup; + Eterm *hp = erts_alloc_message_heap(3,&bp,&ohp,rp,&rp_locks); + tup = TUPLE2(hp, am_nodedown, name); + erts_queue_message(rp, &rp_locks, bp, tup, NIL); + } + erts_smp_proc_unlock(rp, rp_locks); + } + done: + erts_destroy_link(lnk); +} + + +/* + * proc is currently running or exiting process. + */ +int erts_do_net_exits(DistEntry *dep, Eterm reason) +{ + Eterm nodename; + + if (dep == erts_this_dist_entry) { /* Net kernel has died (clean up!!) */ + Eterm nd_reason = (reason == am_no_network + ? am_no_network + : am_net_kernel_terminated); + erts_smp_rwmtx_rwlock(&erts_dist_table_rwmtx); + + /* KILL all port controllers */ + while(erts_visible_dist_entries || erts_hidden_dist_entries) { + DistEntry *tdep; + Eterm prt_id; + Port *prt; + if(erts_hidden_dist_entries) + tdep = erts_hidden_dist_entries; + else + tdep = erts_visible_dist_entries; + prt_id = tdep->cid; + ASSERT(is_internal_port(prt_id)); + erts_smp_rwmtx_rwunlock(&erts_dist_table_rwmtx); + + prt = erts_id2port(prt_id, NULL, 0); + if (prt) { + ASSERT(prt->status & ERTS_PORT_SFLG_DISTRIBUTION); + ASSERT(prt->dist_entry); + /* will call do_net_exists !!! */ + erts_do_exit_port(prt, prt_id, nd_reason); + erts_port_release(prt); + } + + erts_smp_rwmtx_rwlock(&erts_dist_table_rwmtx); + } + + erts_smp_rwmtx_rwunlock(&erts_dist_table_rwmtx); + + nodename = erts_this_dist_entry->sysname; + erts_smp_block_system(ERTS_BS_FLG_ALLOW_GC); + erts_set_this_node(am_Noname, 0); + erts_is_alive = 0; + send_nodes_mon_msgs(NULL, am_nodedown, nodename, am_visible, nd_reason); + erts_smp_release_system(); + + } + else { /* recursive call via erts_do_exit_port() will end up here */ + NetExitsContext nec = {dep}; + ErtsLink *nlinks; + ErtsLink *node_links; + ErtsMonitor *monitors; + Uint32 flags; + + erts_smp_atomic_set(&dep->dist_cmd_scheduled, 1); + erts_smp_de_rwlock(dep); + + ERTS_SMP_LC_ASSERT(is_internal_port(dep->cid) + && erts_lc_is_port_locked(&erts_port[internal_port_index(dep->cid)])); + + if (erts_port_task_is_scheduled(&dep->dist_cmd)) + erts_port_task_abort(dep->cid, &dep->dist_cmd); + + if (dep->status & ERTS_DE_SFLG_EXITING) { +#ifdef DEBUG + erts_smp_spin_lock(&dep->qlock); + ASSERT(dep->qflgs & ERTS_DE_QFLG_EXIT); + erts_smp_spin_unlock(&dep->qlock); +#endif + } + else { + dep->status |= ERTS_DE_SFLG_EXITING; + erts_smp_spin_lock(&dep->qlock); + ASSERT(!(dep->qflgs & ERTS_DE_QFLG_EXIT)); + dep->qflgs |= ERTS_DE_QFLG_EXIT; + erts_smp_spin_unlock(&dep->qlock); + } + + erts_smp_de_links_lock(dep); + monitors = dep->monitors; + nlinks = dep->nlinks; + node_links = dep->node_links; + dep->monitors = NULL; + dep->nlinks = NULL; + dep->node_links = NULL; + erts_smp_de_links_unlock(dep); + + nodename = dep->sysname; + flags = dep->flags; + + erts_set_dist_entry_not_connected(dep); + + erts_smp_de_rwunlock(dep); + + erts_sweep_monitors(monitors, &doit_monitor_net_exits, (void *) &nec); + erts_sweep_links(nlinks, &doit_link_net_exits, (void *) &nec); + erts_sweep_links(node_links, &doit_node_link_net_exits, (void *) &nec); + + send_nodes_mon_msgs(NULL, + am_nodedown, + nodename, + flags & DFLAG_PUBLISHED ? am_visible : am_hidden, + reason == am_normal ? am_connection_closed : reason); + + clear_dist_entry(dep); + + } + return 1; +} + +static Export* +trap_function(Eterm func, int arity) +{ + return erts_export_put(am_erlang, func, arity); +} + +void init_dist(void) +{ + init_nodes_monitors(); + + erts_smp_atomic_init(&no_caches, 0); + + /* Lookup/Install all references to trap functions */ + dsend2_trap = trap_function(am_dsend,2); + dsend3_trap = trap_function(am_dsend,3); + /* dsend_nosuspend_trap = trap_function(am_dsend_nosuspend,2);*/ + dlink_trap = trap_function(am_dlink,1); + dunlink_trap = trap_function(am_dunlink,1); + dmonitor_node_trap = trap_function(am_dmonitor_node,3); + dgroup_leader_trap = trap_function(am_dgroup_leader,2); + dexit_trap = trap_function(am_dexit, 2); + dmonitor_p_trap = trap_function(am_dmonitor_p, 2); +} + +#define ErtsDistOutputBuf2Binary(OB) \ + ((Binary *) (((char *) (OB)) - offsetof(Binary, orig_bytes))) + +static ERTS_INLINE ErtsDistOutputBuf * +alloc_dist_obuf(Uint size) +{ + ErtsDistOutputBuf *obuf; + Uint obuf_size = sizeof(ErtsDistOutputBuf)+sizeof(byte)*(size-1); + Binary *bin = erts_bin_drv_alloc(obuf_size); + bin->flags = BIN_FLAG_DRV; + erts_refc_init(&bin->refc, 1); + bin->orig_size = (long) obuf_size; + obuf = (ErtsDistOutputBuf *) &bin->orig_bytes[0]; +#ifdef DEBUG + obuf->dbg_pattern = ERTS_DIST_OUTPUT_BUF_DBG_PATTERN; + ASSERT(bin == ErtsDistOutputBuf2Binary(obuf)); +#endif + return obuf; +} + +static ERTS_INLINE void +free_dist_obuf(ErtsDistOutputBuf *obuf) +{ + Binary *bin = ErtsDistOutputBuf2Binary(obuf); + ASSERT(obuf->dbg_pattern == ERTS_DIST_OUTPUT_BUF_DBG_PATTERN); + if (erts_refc_dectest(&bin->refc, 0) == 0) + erts_bin_free(bin); +} + +static ERTS_INLINE Sint +size_obuf(ErtsDistOutputBuf *obuf) +{ + Binary *bin = ErtsDistOutputBuf2Binary(obuf); + return bin->orig_size; +} + +static void clear_dist_entry(DistEntry *dep) +{ + Sint obufsize = 0; + ErtsAtomCache *cache; + ErtsProcList *suspendees; + ErtsDistOutputBuf *obuf; + + erts_smp_de_rwlock(dep); + cache = dep->cache; + dep->cache = NULL; + +#ifdef DEBUG + erts_smp_de_links_lock(dep); + ASSERT(!dep->nlinks); + ASSERT(!dep->node_links); + ASSERT(!dep->monitors); + erts_smp_de_links_unlock(dep); +#endif + + erts_smp_spin_lock(&dep->qlock); + + if (!dep->out_queue.last) + obuf = dep->finalized_out_queue.first; + else { + dep->out_queue.last->next = dep->finalized_out_queue.first; + obuf = dep->out_queue.first; + } + + dep->out_queue.first = NULL; + dep->out_queue.last = NULL; + dep->finalized_out_queue.first = NULL; + dep->finalized_out_queue.last = NULL; + dep->status = 0; + suspendees = get_suspended_on_de(dep, ERTS_DE_QFLGS_ALL); + + erts_smp_spin_unlock(&dep->qlock); + erts_smp_atomic_set(&dep->dist_cmd_scheduled, 0); + dep->send = NULL; + erts_smp_de_rwunlock(dep); + + erts_resume_processes(suspendees); + + delete_cache(cache); + + while (obuf) { + ErtsDistOutputBuf *fobuf; + fobuf = obuf; + obuf = obuf->next; + obufsize += size_obuf(fobuf); + free_dist_obuf(fobuf); + } + + if (obufsize) { + erts_smp_spin_lock(&dep->qlock); + ASSERT(dep->qsize >= obufsize); + dep->qsize -= obufsize; + erts_smp_spin_unlock(&dep->qlock); + } +} + +/* + * The erts_dsig_send_*() functions implemented below, sends asynchronous + * distributed signals to other Erlang nodes. Before sending a distributed + * signal, you need to prepare the operation by calling erts_dsig_prepare() + * (see dist.h). + * + * Note that the distributed signal send operation is truly asynchronous, + * and the signal is not guaranteed to reach the receiver if the connection + * goes down before the signal has reached the receiver. + */ + +/* +** Send a DOP_LINK link message +*/ +int +erts_dsig_send_link(ErtsDSigData *dsdp, Eterm local, Eterm remote) +{ + Eterm ctl_heap[4]; + Eterm ctl = TUPLE3(&ctl_heap[0], make_small(DOP_LINK), local, remote); + + return dsig_send(dsdp, ctl, THE_NON_VALUE, 0); +} + +int +erts_dsig_send_unlink(ErtsDSigData *dsdp, Eterm local, Eterm remote) +{ + Eterm ctl_heap[4]; + Eterm ctl = TUPLE3(&ctl_heap[0], make_small(DOP_UNLINK), local, remote); + + return dsig_send(dsdp, ctl, THE_NON_VALUE, 0); +} + + +/* A local process that's beeing monitored by a remote one exits. We send: + {DOP_MONITOR_P_EXIT, Local pid or name, Remote pid, ref, reason}, + which is rather sad as only the ref is needed, no pid's... */ +int +erts_dsig_send_m_exit(ErtsDSigData *dsdp, Eterm watcher, Eterm watched, + Eterm ref, Eterm reason) +{ + Eterm ctl; + Eterm ctl_heap[6]; + + ctl = TUPLE5(&ctl_heap[0], make_small(DOP_MONITOR_P_EXIT), + watched, watcher, ref, reason); + +#ifdef DEBUG + erts_smp_de_links_lock(dsdp->dep); + ASSERT(!erts_lookup_monitor(dsdp->dep->monitors, ref)); + erts_smp_de_links_unlock(dsdp->dep); +#endif + + return dsig_send(dsdp, ctl, THE_NON_VALUE, 1); +} + +/* We want to monitor a process (named or unnamed) on another node, we send: + {DOP_MONITOR_P, Local pid, Remote pid or name, Ref}, which is exactly what's + needed on the other side... */ +int +erts_dsig_send_monitor(ErtsDSigData *dsdp, Eterm watcher, Eterm watched, + Eterm ref) +{ + Eterm ctl; + Eterm ctl_heap[5]; + + ctl = TUPLE4(&ctl_heap[0], + make_small(DOP_MONITOR_P), + watcher, watched, ref); + + return dsig_send(dsdp, ctl, THE_NON_VALUE, 0); +} + +/* A local process monitoring a remote one wants to stop monitoring, either + because of a demonitor bif call or because the local process died. We send + {DOP_DEMONITOR_P, Local pid, Remote pid or name, ref}, which is once again + rather redundant as only the ref will be needed on the other side... */ +int +erts_dsig_send_demonitor(ErtsDSigData *dsdp, Eterm watcher, + Eterm watched, Eterm ref, int force) +{ + Eterm ctl; + Eterm ctl_heap[5]; + + ctl = TUPLE4(&ctl_heap[0], + make_small(DOP_DEMONITOR_P), + watcher, watched, ref); + + return dsig_send(dsdp, ctl, THE_NON_VALUE, force); +} + +int +erts_dsig_send_msg(ErtsDSigData *dsdp, Eterm remote, Eterm message) +{ + Eterm ctl; + Eterm ctl_heap[5]; + Eterm token = NIL; + Process *sender = dsdp->proc; + + if (SEQ_TRACE_TOKEN(sender) != NIL) { + seq_trace_update_send(sender); + token = SEQ_TRACE_TOKEN(sender); + seq_trace_output(token, message, SEQ_TRACE_SEND, remote, sender); + } + + if (token != NIL) + ctl = TUPLE4(&ctl_heap[0], + make_small(DOP_SEND_TT), am_Cookie, remote, token); + else + ctl = TUPLE3(&ctl_heap[0], make_small(DOP_SEND), am_Cookie, remote); + return dsig_send(dsdp, ctl, message, 0); +} + +int +erts_dsig_send_reg_msg(ErtsDSigData *dsdp, Eterm remote_name, Eterm message) +{ + Eterm ctl; + Eterm ctl_heap[6]; + Eterm token = NIL; + Process *sender = dsdp->proc; + + if (SEQ_TRACE_TOKEN(sender) != NIL) { + seq_trace_update_send(sender); + token = SEQ_TRACE_TOKEN(sender); + seq_trace_output(token, message, SEQ_TRACE_SEND, remote_name, sender); + } + + if (token != NIL) + ctl = TUPLE5(&ctl_heap[0], make_small(DOP_REG_SEND_TT), + sender->id, am_Cookie, remote_name, token); + else + ctl = TUPLE4(&ctl_heap[0], make_small(DOP_REG_SEND), + sender->id, am_Cookie, remote_name); + return dsig_send(dsdp, ctl, message, 0); +} + +/* local has died, deliver the exit signal to remote */ +int +erts_dsig_send_exit_tt(ErtsDSigData *dsdp, Eterm local, Eterm remote, + Eterm reason, Eterm token) +{ + Eterm ctl; + Eterm ctl_heap[6]; + + if (token != NIL) { + seq_trace_update_send(dsdp->proc); + seq_trace_output_exit(token, reason, SEQ_TRACE_SEND, remote, local); + ctl = TUPLE5(&ctl_heap[0], + make_small(DOP_EXIT_TT), local, remote, token, reason); + } else { + ctl = TUPLE4(&ctl_heap[0], make_small(DOP_EXIT), local, remote, reason); + } + /* forced, i.e ignore busy */ + return dsig_send(dsdp, ctl, THE_NON_VALUE, 1); +} + +int +erts_dsig_send_exit(ErtsDSigData *dsdp, Eterm local, Eterm remote, Eterm reason) +{ + Eterm ctl_heap[5]; + Eterm ctl = TUPLE4(&ctl_heap[0], + make_small(DOP_EXIT), local, remote, reason); + /* forced, i.e ignore busy */ + return dsig_send(dsdp, ctl, THE_NON_VALUE, 1); +} + +int +erts_dsig_send_exit2(ErtsDSigData *dsdp, Eterm local, Eterm remote, Eterm reason) +{ + Eterm ctl_heap[5]; + Eterm ctl = TUPLE4(&ctl_heap[0], + make_small(DOP_EXIT2), local, remote, reason); + + return dsig_send(dsdp, ctl, THE_NON_VALUE, 0); +} + + +int +erts_dsig_send_group_leader(ErtsDSigData *dsdp, Eterm leader, Eterm remote) +{ + Eterm ctl_heap[4]; + Eterm ctl = TUPLE3(&ctl_heap[0], + make_small(DOP_GROUP_LEADER), leader, remote); + + return dsig_send(dsdp, ctl, THE_NON_VALUE, 0); +} + +#if defined(PURIFY) +# define PURIFY_MSG(msg) \ + purify_printf("%s, line %d: %s", __FILE__, __LINE__, msg) +#elif defined(VALGRIND) +#include +#include + +# define PURIFY_MSG(msg) \ + do { \ + char buf__[1]; size_t bufsz__ = sizeof(buf__); \ + if (erts_sys_getenv("VALGRIND_LOG_XML", buf__, &bufsz__) >= 0) { \ + VALGRIND_PRINTF("" \ + "%s, line %d: %s\n", \ + __FILE__, __LINE__, msg); \ + } else { \ + VALGRIND_PRINTF("%s, line %d: %s", __FILE__, __LINE__, msg); \ + } \ + } while (0) +#else +# define PURIFY_MSG(msg) +#endif + +/* +** Input from distribution port. +** Input follows the distribution protocol v4.5 +** +** The protocol is a 4 byte header protocol +** the DOP_DATA is stripped by driver_output +** +** assert hlen == 0 !!! +*/ +int erts_net_message(Port *prt, + DistEntry *dep, + byte *hbuf, + int hlen, + byte *buf, + int len) +{ + ErtsDistExternal ede; + byte *t; + Sint ctl_len; + int orig_ctl_len; + Eterm arg; + Eterm from, to; + Eterm watcher, watched; + Eterm ref; + Eterm *tuple; + Eterm reason; + Process* rp; + Eterm ctl_default[64]; + Eterm* ctl = ctl_default; + ErlOffHeap off_heap; + Eterm* hp; + Sint type; + Eterm token; + Eterm token_size; + ErtsMonitor *mon; + ErtsLink *lnk; + int res; +#ifdef ERTS_DIST_MSG_DBG + int orig_len = len; +#endif + + /* Thanks to Luke Gorrie */ + off_heap.mso = NULL; +#ifndef HYBRID /* FIND ME! */ + off_heap.funs = NULL; +#endif + off_heap.overhead = 0; + off_heap.externals = NULL; + + ERTS_SMP_CHK_NO_PROC_LOCKS; + + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(prt)); + + if (!erts_is_alive) + return 0; + if (hlen > 0) + goto data_error; + if (len == 0) /* HANDLE TICK !!! */ + return 0; + +#ifdef ERTS_RAW_DIST_MSG_DBG + erts_fprintf(stderr, "<< "); + bw(buf, len); +#endif + + if (dep->flags & DFLAG_DIST_HDR_ATOM_CACHE) + t = buf; + else { + /* Skip PASS_THROUGH */ + t = buf+1; + len--; + } + + if (len == 0) { + PURIFY_MSG("data error"); + goto data_error; + } + + res = erts_prepare_dist_ext(&ede, t, len, dep, dep->cache); + + if (res >= 0) + res = ctl_len = erts_decode_dist_ext_size(&ede, 0); + else { +#ifdef ERTS_DIST_MSG_DBG + erts_fprintf(stderr, "DIST MSG DEBUG: erts_prepare_dist_ext() failed:\n"); + bw(buf, orig_len); +#endif + ctl_len = 0; + } + + if (res < 0) { +#ifdef ERTS_DIST_MSG_DBG + erts_fprintf(stderr, "DIST MSG DEBUG: erts_decode_dist_ext_size(CTL) failed:\n"); + bw(buf, orig_len); +#endif + PURIFY_MSG("data error"); + goto data_error; + } + orig_ctl_len = ctl_len; + if (ctl_len > sizeof(ctl_default)/sizeof(ctl_default[0])) { + ctl = erts_alloc(ERTS_ALC_T_DCTRL_BUF, ctl_len * sizeof(Eterm)); + } + hp = ctl; + + arg = erts_decode_dist_ext(&hp, &off_heap, &ede); + if (is_non_value(arg)) { +#ifdef ERTS_DIST_MSG_DBG + erts_fprintf(stderr, "DIST MSG DEBUG: erts_dist_ext_size(CTL) failed:\n"); + bw(buf, orig_len); +#endif + PURIFY_MSG("data error"); + goto data_error; + } + ctl_len = t - buf; + +#ifdef ERTS_DIST_MSG_DBG + erts_fprintf(stderr, "<<%s CTL: %T\n", len != orig_len ? "P" : " ", arg); +#endif + + if (is_not_tuple(arg) || + (tuple = tuple_val(arg), arityval(*tuple) < 1) || + is_not_small(tuple[1])) { + erts_dsprintf_buf_t *dsbufp = erts_create_logger_dsbuf(); + erts_dsprintf(dsbufp, "Invalid distribution message: %.200T", arg); + erts_send_error_to_logger_nogl(dsbufp); + goto data_error; + } + + token_size = 0; + + switch (type = unsigned_val(tuple[1])) { + case DOP_LINK: + from = tuple[2]; + to = tuple[3]; /* local proc to link to */ + + if (is_not_pid(from) || is_not_pid(to)) { + erts_dsprintf_buf_t *dsbufp = erts_create_logger_dsbuf(); + PURIFY_MSG("data error"); + erts_dsprintf(dsbufp, + "Invalid DOP_LINK distribution message: %.200T", + arg); + erts_send_error_to_logger_nogl(dsbufp); + goto data_error; + } + + rp = erts_pid2proc_opt(NULL, 0, + to, ERTS_PROC_LOCK_LINK, + ERTS_P2P_FLG_ALLOW_OTHER_X); + if (!rp) { + /* This is tricky (we MUST force a distributed send) */ + ErtsDSigData dsd; + int code; + code = erts_dsig_prepare(&dsd, dep, NULL, ERTS_DSP_NO_LOCK, 0); + if (code == ERTS_DSIG_PREP_CONNECTED) { + code = erts_dsig_send_exit(&dsd, to, from, am_noproc); + ASSERT(code == ERTS_DSIG_SEND_OK); + } + break; + } + + erts_smp_de_links_lock(dep); + res = erts_add_link(&(rp->nlinks), LINK_PID, from); + + if (res < 0) { + /* It was already there! Lets skip the rest... */ + erts_smp_de_links_unlock(dep); + erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_LINK); + break; + } + lnk = erts_add_or_lookup_link(&(dep->nlinks), LINK_PID, rp->id); + erts_add_link(&(ERTS_LINK_ROOT(lnk)), LINK_PID, from); + erts_smp_de_links_unlock(dep); + + if (IS_TRACED_FL(rp, F_TRACE_PROCS)) + trace_proc(NULL, rp, am_getting_linked, from); + + erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_LINK); + break; + + case DOP_UNLINK: { + ErtsDistLinkData dld; + from = tuple[2]; + to = tuple[3]; + + rp = erts_pid2proc_opt(NULL, 0, + to, ERTS_PROC_LOCK_LINK, + ERTS_P2P_FLG_ALLOW_OTHER_X); + if (!rp) + break; + + lnk = erts_remove_link(&(rp->nlinks), from); + + if (IS_TRACED_FL(rp, F_TRACE_PROCS) && lnk != NULL) { + trace_proc(NULL, rp, am_getting_unlinked, from); + } + + erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_LINK); + + erts_remove_dist_link(&dld, to, from, dep); + erts_destroy_dist_link(&dld); + if (lnk) + erts_destroy_link(lnk); + break; + } + + case DOP_MONITOR_P: { + /* A remote process wants to monitor us, we get: + {DOP_MONITOR_P, Remote pid, local pid or name, ref} */ + Eterm name; + + watcher = tuple[2]; + watched = tuple[3]; /* local proc to monitor */ + ref = tuple[4]; + + if (is_atom(watched)) { + name = watched; + rp = erts_whereis_process(NULL, 0, + watched, ERTS_PROC_LOCK_LINK, + ERTS_P2P_FLG_ALLOW_OTHER_X); + } + else { + name = NIL; + rp = erts_pid2proc_opt(NULL, 0, + watched, ERTS_PROC_LOCK_LINK, + ERTS_P2P_FLG_ALLOW_OTHER_X); + } + + if (!rp) { + ErtsDSigData dsd; + int code; + code = erts_dsig_prepare(&dsd, dep, NULL, ERTS_DSP_NO_LOCK, 0); + if (code == ERTS_DSIG_PREP_CONNECTED) { + code = erts_dsig_send_m_exit(&dsd, watcher, watched, ref, + am_noproc); + ASSERT(code == ERTS_DSIG_SEND_OK); + } + } + else { + if (is_atom(watched)) + watched = rp->id; + erts_smp_de_links_lock(dep); + erts_add_monitor(&(dep->monitors), MON_ORIGIN, ref, watched, name); + erts_add_monitor(&(rp->monitors), MON_TARGET, ref, watcher, name); + erts_smp_de_links_unlock(dep); + erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_LINK); + } + + break; + } + + case DOP_DEMONITOR_P: + /* A remote node informs us that a local pid in no longer monitored + We get {DOP_DEMONITOR_P, Remote pid, Local pid or name, ref}, + We need only the ref of course */ + + /* watcher = tuple[2]; */ + /* watched = tuple[3]; May be an atom in case of monitor name */ + ref = tuple[4]; + + erts_smp_de_links_lock(dep); + mon = erts_remove_monitor(&(dep->monitors),ref); + erts_smp_de_links_unlock(dep); + /* ASSERT(mon != NULL); can happen in case of broken dist message */ + if (mon == NULL) { + break; + } + watched = mon->pid; + erts_destroy_monitor(mon); + rp = erts_pid2proc_opt(NULL, 0, + watched, ERTS_PROC_LOCK_LINK, + ERTS_P2P_FLG_ALLOW_OTHER_X); + if (!rp) { + break; + } + mon = erts_remove_monitor(&(rp->monitors),ref); + erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_LINK); + ASSERT(mon != NULL); + if (mon == NULL) { + break; + } + erts_destroy_monitor(mon); + break; + + case DOP_NODE_LINK: /* XXX never sent ?? */ + break; + + case DOP_REG_SEND_TT: + token_size = size_object(tuple[5]); + /* Fall through ... */ + case DOP_REG_SEND: + /* {DOP_REG_SEND, From, Cookie, ToName} -- Message */ + /* {DOP_REG_SEND_TT, From, Cookie, ToName, TraceToken} -- Message */ + + /* + * There is intentionally no testing of the cookie (it is always '') + * from R9B and onwards. + */ +#ifdef ERTS_DIST_MSG_DBG + dist_msg_dbg(&ede, "MSG", buf, orig_len); +#endif + + from = tuple[2]; + to = tuple[4]; + rp = erts_whereis_process(NULL, 0, to, 0, ERTS_P2P_FLG_SMP_INC_REFC); + if (rp) { + Uint xsize = (type == DOP_REG_SEND + ? 0 + : ERTS_HEAP_FRAG_SIZE(token_size)); + ErtsProcLocks locks = 0; + ErtsDistExternal *ede_copy; + + ede_copy = erts_make_dist_ext_copy(&ede, xsize); + if (type == DOP_REG_SEND) { + token = NIL; + } else { + ErlHeapFragment *heap_frag; + ErlOffHeap *ohp; + ASSERT(xsize); + heap_frag = erts_dist_ext_trailer(ede_copy); + ERTS_INIT_HEAP_FRAG(heap_frag, token_size); + hp = heap_frag->mem; + ohp = &heap_frag->off_heap; + token = tuple[5]; + token = copy_struct(token, token_size, &hp, ohp); + } + + erts_queue_dist_message(rp, &locks, ede_copy, token); + if (locks) + erts_smp_proc_unlock(rp, locks); + erts_smp_proc_dec_refc(rp); + } + break; + + case DOP_SEND_TT: + token_size = size_object(tuple[4]); + /* Fall through ... */ + case DOP_SEND: + /* + * There is intentionally no testing of the cookie (it is always '') + * from R9B and onwards. + */ +#ifdef ERTS_DIST_MSG_DBG + dist_msg_dbg(&ede, "MSG", buf, orig_len); +#endif + + to = tuple[3]; + rp = erts_pid2proc_opt(NULL, 0, to, 0, ERTS_P2P_FLG_SMP_INC_REFC); + if (rp) { + Uint xsize = type == DOP_SEND ? 0 : ERTS_HEAP_FRAG_SIZE(token_size); + ErtsProcLocks locks = 0; + ErtsDistExternal *ede_copy; + + ede_copy = erts_make_dist_ext_copy(&ede, xsize); + if (type == DOP_SEND) { + token = NIL; + } else { + ErlHeapFragment *heap_frag; + ErlOffHeap *ohp; + ASSERT(xsize); + heap_frag = erts_dist_ext_trailer(ede_copy); + ERTS_INIT_HEAP_FRAG(heap_frag, token_size); + hp = heap_frag->mem; + ohp = &heap_frag->off_heap; + token = tuple[4]; + token = copy_struct(token, token_size, &hp, ohp); + } + + erts_queue_dist_message(rp, &locks, ede_copy, token); + if (locks) + erts_smp_proc_unlock(rp, locks); + erts_smp_proc_dec_refc(rp); + } + break; + + case DOP_MONITOR_P_EXIT: { + /* We are monitoring a process on the remote node which dies, we get + {DOP_MONITOR_P_EXIT, Remote pid or name, Local pid, ref, reason} */ + + + Eterm lhp[3]; + Eterm sysname; + ErtsProcLocks rp_locks = ERTS_PROC_LOCKS_MSG_SEND|ERTS_PROC_LOCK_LINK; + + /* watched = tuple[2]; */ /* remote proc which died */ + /* watcher = tuple[3]; */ + ref = tuple[4]; + reason = tuple[5]; + + erts_smp_de_links_lock(dep); + sysname = dep->sysname; + mon = erts_remove_monitor(&(dep->monitors), ref); + /* + * If demonitor was performed at the same time as the + * monitored process exits, monitoring side will have + * removed info about monitor. In this case, do nothing + * and everything will be as it should. + */ + erts_smp_de_links_unlock(dep); + if (mon == NULL) { + break; + } + rp = erts_pid2proc(NULL, 0, mon->pid, rp_locks); + if (rp == NULL) { + break; + } + + erts_destroy_monitor(mon); + + mon = erts_remove_monitor(&(rp->monitors),ref); + + if (mon == NULL) { + erts_smp_proc_unlock(rp, rp_locks); + break; + } + + watched = (is_not_nil(mon->name) + ? TUPLE2(&lhp[0], mon->name, sysname) + : mon->pid); + + erts_queue_monitor_message(rp, &rp_locks, + ref, am_process, watched, reason); + erts_smp_proc_unlock(rp, rp_locks); + erts_destroy_monitor(mon); + break; + } + + case DOP_EXIT_TT: + case DOP_EXIT: { + ErtsDistLinkData dld; + ErtsProcLocks rp_locks = ERTS_PROC_LOCK_LINK|ERTS_PROC_LOCKS_XSIG_SEND; + /* 'from', which 'to' is linked to, died */ + if (type == DOP_EXIT) { + from = tuple[2]; + to = tuple[3]; + reason = tuple[4]; + token = NIL; + } else { + from = tuple[2]; + to = tuple[3]; + token = tuple[4]; + reason = tuple[5]; + } + if (is_not_internal_pid(to)) { + erts_dsprintf_buf_t *dsbufp = erts_create_logger_dsbuf(); + PURIFY_MSG("data error"); + erts_dsprintf(dsbufp, + "Invalid DOP_EXIT distribution message: %.200T", + arg); + erts_send_error_to_logger_nogl(dsbufp); + goto data_error; + } + + rp = erts_pid2proc(NULL, 0, to, rp_locks); + if (!rp) + lnk = NULL; + else { + lnk = erts_remove_link(&(rp->nlinks), from); + + /* If lnk == NULL, we have unlinked on this side, i.e. + * ignore exit. + */ + if (lnk) { + int xres; +#if 0 + /* Arndt: Maybe it should never be 'kill', but it can be, + namely when a linked process does exit(kill). Until we know + whether that is incorrect and what should happen instead, + we leave the assertion out. */ + ASSERT(reason != am_kill); /* should never be kill (killed) */ +#endif + xres = erts_send_exit_signal(NULL, + from, + rp, + &rp_locks, + reason, + token, + NULL, + ERTS_XSIG_FLG_IGN_KILL); + if (xres >= 0 && IS_TRACED_FL(rp, F_TRACE_PROCS)) { + /* We didn't exit the process and it is traced */ + trace_proc(NULL, rp, am_getting_unlinked, from); + } + } + erts_smp_proc_unlock(rp, rp_locks); + } + erts_remove_dist_link(&dld, to, from, dep); + if (lnk) + erts_destroy_link(lnk); + erts_destroy_dist_link(&dld); + break; + } + case DOP_EXIT2_TT: + case DOP_EXIT2: { + ErtsProcLocks rp_locks = ERTS_PROC_LOCKS_XSIG_SEND; + /* 'from' is send an exit signal to 'to' */ + if (type == DOP_EXIT2) { + from = tuple[2]; + to = tuple[3]; + reason = tuple[4]; + token = NIL; + } else { + from = tuple[2]; + to = tuple[3]; + token = tuple[4]; + reason = tuple[5]; + } + rp = erts_pid2proc_opt(NULL, 0, to, rp_locks, + ERTS_P2P_FLG_SMP_INC_REFC); + if (rp) { + (void) erts_send_exit_signal(NULL, + from, + rp, + &rp_locks, + reason, + token, + NULL, + 0); + erts_smp_proc_unlock(rp, rp_locks); + erts_smp_proc_dec_refc(rp); + } + break; + } + case DOP_GROUP_LEADER: + from = tuple[2]; /* Group leader */ + to = tuple[3]; /* new member */ + if (is_not_pid(from)) + break; + + rp = erts_pid2proc(NULL, 0, to, ERTS_PROC_LOCK_MAIN); + if (!rp) + break; + rp->group_leader = STORE_NC_IN_PROC(rp, from); + erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_MAIN); + break; + + default: { + erts_dsprintf_buf_t *dsbufp = erts_create_logger_dsbuf(); + erts_dsprintf(dsbufp, + "Illegal value in distribution dispatch switch: " + "%.200T", + arg); + erts_send_error_to_logger_nogl(dsbufp); + PURIFY_MSG("data error"); + goto data_error; + } + } + + if (off_heap.mso) { + erts_cleanup_mso(off_heap.mso); + } + if (off_heap.externals) { + erts_cleanup_externals(off_heap.externals); + } +#ifndef HYBRID /* FIND ME! */ + if (off_heap.funs) { + erts_cleanup_funs(off_heap.funs); + } + if (ctl != ctl_default) { + erts_free(ERTS_ALC_T_DCTRL_BUF, (void *) ctl); + } +#endif + ERTS_SMP_CHK_NO_PROC_LOCKS; + return 0; + + data_error: + if (off_heap.mso) { + erts_cleanup_mso(off_heap.mso); + } + if (off_heap.externals) { + erts_cleanup_externals(off_heap.externals); + } +#ifndef HYBRID /* FIND ME! */ + if (off_heap.funs) { + erts_cleanup_funs(off_heap.funs); + } + if (ctl != ctl_default) { + erts_free(ERTS_ALC_T_DCTRL_BUF, (void *) ctl); + } +#endif + erts_do_exit_port(prt, dep->cid, am_killed); + ERTS_SMP_CHK_NO_PROC_LOCKS; + return -1; +} + +#define ERTS_DE_BUSY_LIMIT (128*1024) + +static int +dsig_send(ErtsDSigData *dsdp, Eterm ctl, Eterm msg, int force_busy) +{ + Eterm cid; + int suspended = 0; + int resume = 0; + Uint32 pass_through_size; + Uint data_size, dhdr_ext_size; + ErtsAtomCacheMap *acmp; + ErtsDistOutputBuf *obuf; + DistEntry *dep = dsdp->dep; + Uint32 flags = dep->flags; + Process *c_p = dsdp->proc; + + if (!c_p || dsdp->no_suspend) + force_busy = 1; + + ERTS_SMP_LC_ASSERT(!c_p + || (ERTS_PROC_LOCK_MAIN + == erts_proc_lc_my_proc_locks(c_p))); + + if (!erts_is_alive) + return ERTS_DSIG_SEND_OK; + + if (flags & DFLAG_DIST_HDR_ATOM_CACHE) { + acmp = erts_get_atom_cache_map(c_p); + pass_through_size = 0; + } + else { + acmp = NULL; + pass_through_size = 1; + } + +#ifdef ERTS_DIST_MSG_DBG + erts_fprintf(stderr, ">>%s CTL: %T\n", pass_through_size ? "P" : " ", ctl); + if (is_value(msg)) + erts_fprintf(stderr, " MSG: %T\n", msg); +#endif + + data_size = pass_through_size; + erts_reset_atom_cache_map(acmp); + data_size += erts_encode_dist_ext_size(ctl, flags, acmp); + if (is_value(msg)) + data_size += erts_encode_dist_ext_size(msg, flags, acmp); + erts_finalize_atom_cache_map(acmp); + + dhdr_ext_size = erts_encode_ext_dist_header_size(acmp); + data_size += dhdr_ext_size; + + obuf = alloc_dist_obuf(data_size); + obuf->ext_endp = &obuf->data[0] + pass_through_size + dhdr_ext_size; + + /* Encode internal version of dist header */ + obuf->extp = erts_encode_ext_dist_header_setup(obuf->ext_endp, acmp); + /* Encode control message */ + erts_encode_dist_ext(ctl, &obuf->ext_endp, flags, acmp); + if (is_value(msg)) { + /* Encode message */ + erts_encode_dist_ext(msg, &obuf->ext_endp, flags, acmp); + } + + ASSERT(obuf->extp < obuf->ext_endp); + ASSERT(&obuf->data[0] <= obuf->extp - pass_through_size); + ASSERT(obuf->ext_endp <= &obuf->data[0] + data_size); + + data_size = obuf->ext_endp - obuf->extp; + + /* + * Signal encoded; now verify that the connection still exists, + * and if so enqueue the signal and schedule it for send. + */ + obuf->next = NULL; + erts_smp_de_rlock(dep); + cid = dep->cid; + if (cid != dsdp->cid + || dep->connection_id != dsdp->connection_id + || dep->status & ERTS_DE_SFLG_EXITING) { + /* Not the same connection as when we started; drop message... */ + erts_smp_de_runlock(dep); + free_dist_obuf(obuf); + } + else { + ErtsProcList *plp = NULL; + erts_smp_spin_lock(&dep->qlock); + dep->qsize += size_obuf(obuf); + if (dep->qsize >= ERTS_DE_BUSY_LIMIT) + dep->qflgs |= ERTS_DE_QFLG_BUSY; + if (!force_busy && (dep->qflgs & ERTS_DE_QFLG_BUSY)) { + erts_smp_spin_unlock(&dep->qlock); + + plp = erts_proclist_create(c_p); + plp->next = NULL; + erts_suspend(c_p, ERTS_PROC_LOCK_MAIN, NULL); + suspended = 1; + erts_smp_spin_lock(&dep->qlock); + } + + /* Enqueue obuf on dist entry */ + if (dep->out_queue.last) + dep->out_queue.last->next = obuf; + else + dep->out_queue.first = obuf; + dep->out_queue.last = obuf; + + if (!force_busy) { + if (!(dep->qflgs & ERTS_DE_QFLG_BUSY)) { + if (suspended) + resume = 1; /* was busy when we started, but isn't now */ + } + else { + /* Enqueue suspended process on dist entry */ + ASSERT(plp); + if (dep->suspended.last) + dep->suspended.last->next = plp; + else + dep->suspended.first = plp; + dep->suspended.last = plp; + } + } + + erts_smp_spin_unlock(&dep->qlock); + erts_schedule_dist_command(NULL, dep); + erts_smp_de_runlock(dep); + + if (resume) { + erts_resume(c_p, ERTS_PROC_LOCK_MAIN); + erts_proclist_destroy(plp); + /* + * Note that the calling process still have to yield as if it + * suspended. If not, the calling process could later be + * erroneously scheduled when it shouldn't be. + */ + } + } + + if (c_p) { + int reds; + /* + * Bump reductions on calling process. + * + * This is the reduction cost: Always a base cost of 8 reductions + * plus 16 reductions per kilobyte generated external data. + */ + + data_size >>= (10-4); +#if defined(ARCH_64) + data_size &= 0x003fffffffffffff; +#elif defined(ARCH_32) + data_size &= 0x003fffff; +#else +# error "Ohh come on ... !?!" +#endif + reds = 8 + ((int) data_size > 1000000 ? 1000000 : (int) data_size); + BUMP_REDS(c_p, reds); + } + + if (suspended) { + if (!resume && erts_system_monitor_flags.busy_dist_port) + monitor_generic(c_p, am_busy_dist_port, cid); + return ERTS_DSIG_SEND_YIELD; + } + return ERTS_DSIG_SEND_OK; +} + + +static Uint +dist_port_command(Port *prt, ErtsDistOutputBuf *obuf) +{ + int fpe_was_unmasked; + Uint size = obuf->ext_endp - obuf->extp; + + ERTS_SMP_CHK_NO_PROC_LOCKS; + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(prt)); + + if (size > (Uint) INT_MAX) + erl_exit(ERTS_ABORT_EXIT, + "Absurdly large distribution output data buffer " + "(%bpu bytes) passed.\n", + size); + + prt->caller = NIL; + fpe_was_unmasked = erts_block_fpe(); + (*prt->drv_ptr->output)((ErlDrvData) prt->drv_data, + (char*) obuf->extp, + (int) size); + erts_unblock_fpe(fpe_was_unmasked); + return size; +} + +static Uint +dist_port_commandv(Port *prt, ErtsDistOutputBuf *obuf) +{ + int fpe_was_unmasked; + Uint size = obuf->ext_endp - obuf->extp; + SysIOVec iov[2]; + ErlDrvBinary* bv[2]; + ErlIOVec eiov; + + ERTS_SMP_CHK_NO_PROC_LOCKS; + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(prt)); + + if (size > (Uint) INT_MAX) + erl_exit(ERTS_ABORT_EXIT, + "Absurdly large distribution output data buffer " + "(%bpu bytes) passed.\n", + size); + + iov[0].iov_base = NULL; + iov[0].iov_len = 0; + bv[0] = NULL; + + iov[1].iov_base = obuf->extp; + iov[1].iov_len = size; + bv[1] = Binary2ErlDrvBinary(ErtsDistOutputBuf2Binary(obuf)); + + eiov.vsize = 2; + eiov.size = size; + eiov.iov = iov; + eiov.binv = bv; + + ASSERT(prt->drv_ptr->outputv); + + prt->caller = NIL; + fpe_was_unmasked = erts_block_fpe(); + (*prt->drv_ptr->outputv)((ErlDrvData) prt->drv_data, &eiov); + erts_unblock_fpe(fpe_was_unmasked); + + return size; +} + + +#if defined(ARCH_64) +#define ERTS_PORT_REDS_MASK__ 0x003fffffffffffffL +#elif defined(ARCH_32) +#define ERTS_PORT_REDS_MASK__ 0x003fffff +#else +# error "Ohh come on ... !?!" +#endif + +#define ERTS_PORT_REDS_DIST_CMD_START 5 +#define ERTS_PORT_REDS_DIST_CMD_FINALIZE 3 +#define ERTS_PORT_REDS_DIST_CMD_EXIT 200 +#define ERTS_PORT_REDS_DIST_CMD_RESUMED 5 +#define ERTS_PORT_REDS_DIST_CMD_DATA(SZ) \ + ((SZ) < (1 << 10) \ + ? ((Sint) 1) \ + : ((((Sint) (SZ)) >> 10) & ((Sint) ERTS_PORT_REDS_MASK__))) + +int +erts_dist_command(Port *prt, int reds_limit) +{ + Sint reds = ERTS_PORT_REDS_DIST_CMD_START; + int prt_busy; + int de_busy; + Uint32 status; + Uint32 flags; + Uint32 qflgs; + Sint obufsize = 0; + ErtsDistOutputQueue oq, foq; + DistEntry *dep = prt->dist_entry; + Uint (*send)(Port *prt, ErtsDistOutputBuf *obuf); + + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(prt)); + + erts_refc_inc(&dep->refc, 1); /* Otherwise dist_entry might be + removed if port command fails */ + + erts_smp_atomic_xchg(&dep->dist_cmd_scheduled, 0); + + erts_smp_de_rlock(dep); + flags = dep->flags; + status = dep->status; + send = dep->send; + erts_smp_de_runlock(dep); + + if (status & ERTS_DE_SFLG_EXITING) { + erts_do_exit_port(prt, prt->id, am_killed); + erts_deref_dist_entry(dep); + return reds + ERTS_PORT_REDS_DIST_CMD_EXIT; + } + + ASSERT(send); + + /* + * We need to remove both out queues from the + * dist entry while passing it to port command; + * otherwise, port command will free the buffers + * in the queues on failure and we'll end up with + * a mess. + */ + + erts_smp_spin_lock(&dep->qlock); + oq.first = dep->out_queue.first; + oq.last = dep->out_queue.last; + dep->out_queue.first = NULL; + dep->out_queue.last = NULL; + qflgs = dep->qflgs; + erts_smp_spin_unlock(&dep->qlock); + + foq.first = dep->finalized_out_queue.first; + foq.last = dep->finalized_out_queue.last; + dep->finalized_out_queue.first = NULL; + dep->finalized_out_queue.last = NULL; + + if (reds > reds_limit) + goto preempted; + + prt_busy = (int) (prt->status & ERTS_PORT_SFLG_PORT_BUSY); + de_busy = (int) (qflgs & ERTS_DE_QFLG_BUSY); + + if (prt_busy) { + if (!de_busy) { + erts_smp_spin_lock(&dep->qlock); + dep->qflgs |= ERTS_DE_QFLG_BUSY; + erts_smp_spin_unlock(&dep->qlock); + de_busy = 1; + } + } + else if (foq.first) { + int preempt = 0; + do { + Uint size; + ErtsDistOutputBuf *fob; + + size = (*send)(prt, foq.first); +#ifdef ERTS_RAW_DIST_MSG_DBG + erts_fprintf(stderr, ">> "); + bw(foq.first->extp, size); +#endif + reds += ERTS_PORT_REDS_DIST_CMD_DATA(size); + fob = foq.first; + obufsize += size_obuf(fob); + foq.first = foq.first->next; + free_dist_obuf(fob); + preempt = reds > reds_limit || (prt->status & ERTS_PORT_SFLGS_DEAD); + if (prt->status & ERTS_PORT_SFLG_PORT_BUSY) { + erts_smp_spin_lock(&dep->qlock); + dep->qflgs |= ERTS_DE_QFLG_BUSY; + erts_smp_spin_unlock(&dep->qlock); + de_busy = prt_busy = 1; + break; + } + } while (foq.first && !preempt); + if (!foq.first) + foq.last = NULL; + if (preempt) + goto preempted; + } + + if (prt_busy) { + if (oq.first) { + ErtsDistOutputBuf *ob; + int preempt; + finalize_only: + preempt = 0; + ob = oq.first; + ASSERT(ob); + do { + ob->extp = erts_encode_ext_dist_header_finalize(ob->extp, + dep->cache); + if (!(flags & DFLAG_DIST_HDR_ATOM_CACHE)) + *--ob->extp = PASS_THROUGH; /* Old node; 'pass through' + needed */ + ASSERT(&ob->data[0] <= ob->extp && ob->extp < ob->ext_endp); + reds += ERTS_PORT_REDS_DIST_CMD_FINALIZE; + preempt = reds > reds_limit; + if (preempt) + break; + ob = ob->next; + } while (ob); + /* + * At least one buffer was finalized; if we got preempted, + * ob points to the last buffer that we finalized. + */ + if (foq.last) + foq.last->next = oq.first; + else + foq.first = oq.first; + if (!preempt) { + /* All buffers finalized */ + foq.last = oq.last; + oq.first = oq.last = NULL; + } + else { + /* Not all buffers finalized; split oq. */ + foq.last = ob; + oq.first = ob->next; + if (oq.first) + ob->next = NULL; + else + oq.last = NULL; + } + if (preempt) + goto preempted; + } + } + else { + int preempt = 0; + while (oq.first && !preempt) { + ErtsDistOutputBuf *fob; + Uint size; + oq.first->extp + = erts_encode_ext_dist_header_finalize(oq.first->extp, + dep->cache); + reds += ERTS_PORT_REDS_DIST_CMD_FINALIZE; + if (!(flags & DFLAG_DIST_HDR_ATOM_CACHE)) + *--oq.first->extp = PASS_THROUGH; /* Old node; 'pass through' + needed */ + ASSERT(&oq.first->data[0] <= oq.first->extp + && oq.first->extp < oq.first->ext_endp); + size = (*send)(prt, oq.first); +#ifdef ERTS_RAW_DIST_MSG_DBG + erts_fprintf(stderr, ">> "); + bw(oq.first->extp, size); +#endif + reds += ERTS_PORT_REDS_DIST_CMD_DATA(size); + fob = oq.first; + obufsize += size_obuf(fob); + oq.first = oq.first->next; + free_dist_obuf(fob); + preempt = reds > reds_limit || (prt->status & ERTS_PORT_SFLGS_DEAD); + if (prt->status & ERTS_PORT_SFLG_PORT_BUSY) { + erts_smp_spin_lock(&dep->qlock); + dep->qflgs |= ERTS_DE_QFLG_BUSY; + erts_smp_spin_unlock(&dep->qlock); + de_busy = prt_busy = 1; + if (oq.first && !preempt) + goto finalize_only; + } + } + + ASSERT(!oq.first || preempt); + + /* + * Preempt if not all buffers have been handled. + */ + if (preempt && oq.first) + goto preempted; + +#ifdef DEBUG + oq.last = NULL; +#endif + ASSERT(!oq.first); + ASSERT(!foq.first && !foq.last); + + /* + * Everything that was buffered when we started have now been + * written to the port. If port isn't busy but dist entry is + * and we havn't got too muched queued on dist entry, set + * dist entry in a non-busy state and resume suspended + * processes. + */ + erts_smp_spin_lock(&dep->qlock); + ASSERT(dep->qsize >= obufsize); + dep->qsize -= obufsize; + obufsize = 0; + if (de_busy && !prt_busy && dep->qsize < ERTS_DE_BUSY_LIMIT) { + ErtsProcList *suspendees; + int resumed; + suspendees = get_suspended_on_de(dep, ERTS_DE_QFLG_BUSY); + erts_smp_spin_unlock(&dep->qlock); + + resumed = erts_resume_processes(suspendees); + reds += resumed*ERTS_PORT_REDS_DIST_CMD_RESUMED; + de_busy = 0; + } + else + erts_smp_spin_unlock(&dep->qlock); + } + + ASSERT(!oq.first && !oq.last); + + done: + + if (obufsize != 0) { + ASSERT(obufsize > 0); + erts_smp_spin_lock(&dep->qlock); + ASSERT(dep->qsize >= obufsize); + dep->qsize -= obufsize; + erts_smp_spin_unlock(&dep->qlock); + } + + ASSERT(foq.first || !foq.last); + ASSERT(!foq.first || foq.last); + ASSERT(!dep->finalized_out_queue.first); + ASSERT(!dep->finalized_out_queue.last); + + if (foq.first) { + dep->finalized_out_queue.first = foq.first; + dep->finalized_out_queue.last = foq.last; + } + + /* Avoid wrapping reduction counter... */ + if (reds > INT_MAX/2) + reds = INT_MAX/2; + + erts_deref_dist_entry(dep); + + return reds; + + preempted: + + ASSERT(oq.first || !oq.last); + ASSERT(!oq.first || oq.last); + + if (prt->status & ERTS_PORT_SFLGS_DEAD) { + /* + * Port died during port command; clean up 'oq' + * and 'foq'. Things buffered in dist entry after + * we begun processing the queues have already been + * cleaned up when port terminated. + */ + + if (oq.first) + oq.last->next = foq.first; + else + oq.first = foq.first; + + while (oq.first) { + ErtsDistOutputBuf *fob = oq.first; + oq.first = oq.first->next; + obufsize += size_obuf(fob); + free_dist_obuf(fob); + } + + foq.first = NULL; + foq.last = NULL; + +#ifdef DEBUG + erts_smp_spin_lock(&dep->qlock); + ASSERT(dep->qsize == obufsize); + erts_smp_spin_unlock(&dep->qlock); +#endif + } + else { + if (oq.first) { + /* + * Unhandle buffers need to be put back first + * in out_queue. + */ + erts_smp_spin_lock(&dep->qlock); + dep->qsize -= obufsize; + obufsize = 0; + oq.last->next = dep->out_queue.first; + dep->out_queue.first = oq.first; + if (!dep->out_queue.last) + dep->out_queue.last = oq.last; + erts_smp_spin_unlock(&dep->qlock); + } + + erts_schedule_dist_command(prt, NULL); + } + goto done; +} + +void +erts_dist_port_not_busy(Port *prt) +{ + erts_schedule_dist_command(prt, NULL); +} + +void +erts_kill_dist_connection(DistEntry *dep, Uint32 connection_id) +{ + erts_smp_de_rwlock(dep); + if (is_internal_port(dep->cid) + && connection_id == dep->connection_id + && !(dep->status & ERTS_DE_SFLG_EXITING)) { + + dep->status |= ERTS_DE_SFLG_EXITING; + + erts_smp_spin_lock(&dep->qlock); + ASSERT(!(dep->qflgs & ERTS_DE_QFLG_EXIT)); + dep->qflgs |= ERTS_DE_QFLG_EXIT; + erts_smp_spin_unlock(&dep->qlock); + + erts_schedule_dist_command(NULL, dep); + } + erts_smp_de_rwunlock(dep); +} + +struct print_to_data { + int to; + void *arg; +}; + +static void doit_print_monitor_info(ErtsMonitor *mon, void *vptdp) +{ + int to = ((struct print_to_data *) vptdp)->to; + void *arg = ((struct print_to_data *) vptdp)->arg; + Process *rp; + ErtsMonitor *rmon; + rp = erts_pid2proc_unlocked(mon->pid); + if (!rp || (rmon = erts_lookup_monitor(rp->monitors, mon->ref)) == NULL) { + erts_print(to, arg, "Warning, stray monitor for: %T\n", mon->pid); + } else if (mon->type == MON_ORIGIN) { + /* Local pid is being monitored */ + erts_print(to, arg, "Remotely monitored by: %T %T\n", + mon->pid, rmon->pid); + } else { + erts_print(to, arg, "Remote monitoring: %T ", mon->pid); + if (is_not_atom(rmon->pid)) + erts_print(to, arg, "%T\n", rmon->pid); + else + erts_print(to, arg, "{%T, %T}\n", + rmon->name, + rmon->pid); /* which in this case is the + remote system name... */ + } +} + +static void print_monitor_info(int to, void *arg, ErtsMonitor *mon) +{ + struct print_to_data ptd = {to, arg}; + erts_doforall_monitors(mon,&doit_print_monitor_info,&ptd); +} + +typedef struct { + struct print_to_data *ptdp; + Eterm from; +} PrintLinkContext; + +static void doit_print_link_info2(ErtsLink *lnk, void *vpplc) +{ + PrintLinkContext *pplc = (PrintLinkContext *) vpplc; + erts_print(pplc->ptdp->to, pplc->ptdp->arg, "Remote link: %T %T\n", + pplc->from, lnk->pid); +} + +static void doit_print_link_info(ErtsLink *lnk, void *vptdp) +{ + if (is_internal_pid(lnk->pid) && erts_pid2proc_unlocked(lnk->pid)) { + PrintLinkContext plc = {(struct print_to_data *) vptdp, lnk->pid}; + erts_doforall_links(ERTS_LINK_ROOT(lnk), &doit_print_link_info2, &plc); + } +} + +static void print_link_info(int to, void *arg, ErtsLink *lnk) +{ + struct print_to_data ptd = {to, arg}; + erts_doforall_links(lnk, &doit_print_link_info, (void *) &ptd); +} + +typedef struct { + struct print_to_data ptd; + Eterm sysname; +} PrintNodeLinkContext; + + +static void doit_print_nodelink_info(ErtsLink *lnk, void *vpcontext) +{ + PrintNodeLinkContext *pcontext = vpcontext; + + if (is_internal_pid(lnk->pid) && erts_pid2proc_unlocked(lnk->pid)) + erts_print(pcontext->ptd.to, pcontext->ptd.arg, + "Remote monitoring: %T %T\n", lnk->pid, pcontext->sysname); +} + +static void print_nodelink_info(int to, void *arg, ErtsLink *lnk, Eterm sysname) +{ + PrintNodeLinkContext context = {{to, arg}, sysname}; + erts_doforall_links(lnk, &doit_print_nodelink_info, &context); +} + + +static int +info_dist_entry(int to, void *arg, DistEntry *dep, int visible, int connected) +{ + + if (visible && connected) { + erts_print(to, arg, "=visible_node:"); + } else if (connected) { + erts_print(to, arg, "=hidden_node:"); + } else { + erts_print(to, arg, "=not_connected:"); + } + erts_print(to, arg, "%d\n", dist_entry_channel_no(dep)); + + if(connected && is_nil(dep->cid)) { + erts_print(to, arg, + "Error: Not connected node still registered as connected:%T\n", + dep->sysname); + return 0; + } + + if(!connected && is_not_nil(dep->cid)) { + erts_print(to, arg, + "Error: Connected node not registered as connected:%T\n", + dep->sysname); + return 0; + } + + erts_print(to, arg, "Name: %T", dep->sysname); +#ifdef DEBUG + erts_print(to, arg, " (refc=%d)", erts_refc_read(&dep->refc, 1)); +#endif + erts_print(to, arg, "\n"); + if (!connected && is_nil(dep->cid)) { + if (dep->nlinks) { + erts_print(to, arg, "Error: Got links to not connected node:%T\n", + dep->sysname); + } + return 0; + } + + erts_print(to, arg, "Controller: %T\n", dep->cid, to); + + erts_print_node_info(to, arg, dep->sysname, NULL, NULL); + print_monitor_info(to, arg, dep->monitors); + print_link_info(to, arg, dep->nlinks); + print_nodelink_info(to, arg, dep->node_links, dep->sysname); + + return 0; + +} +int distribution_info(int to, void *arg) /* Called by break handler */ +{ + DistEntry *dep; + + erts_print(to, arg, "=node:%T\n", erts_this_dist_entry->sysname); + + if (erts_this_node->sysname == am_Noname) { + erts_print(to, arg, "=no_distribution\n"); + return(0); + } + +#if 0 + if (!erts_visible_dist_entries && !erts_hidden_dist_entries) + erts_print(to, arg, "Alive but not holding any connections \n"); +#endif + + for(dep = erts_visible_dist_entries; dep; dep = dep->next) { + info_dist_entry(to, arg, dep, 1, 1); + } + + for(dep = erts_hidden_dist_entries; dep; dep = dep->next) { + info_dist_entry(to, arg, dep, 0, 1); + } + + for (dep = erts_not_connected_dist_entries; dep; dep = dep->next) { + info_dist_entry(to, arg, dep, 0, 0); + } + + return(0); +} + +/**************************************************************************** + DISTRIBUTION BIFS: + + setnode/2 -- start distribution + setnode/3 -- set node controller + + node/1 -- return objects node name + node/0 -- return this node name + nodes/0 -- return a list of all (non hidden) nodes + is_alive -- return true if distribution is running else false + monitor_node -- turn on/off node monitoring + + node controller only: + dist_exit/3 -- send exit signals from remote to local process + dist_link/2 -- link a remote process to a local + dist_unlink/2 -- unlink a remote from a local +****************************************************************************/ + + + +/********************************************************************** + ** Set the node name of current node fail if node already is set. + ** setnode(name@host, Creation) + ** loads functions pointer to trap_functions from module erlang. + ** erlang:dsend/2 + ** erlang:dlink/1 + ** erlang:dunlink/1 + ** erlang:dmonitor_node/3 + ** erlang:dgroup_leader/2 + ** erlang:dexit/2 + ** -- are these needed ? + ** dexit/1 + ***********************************************************************/ + +BIF_RETTYPE setnode_2(BIF_ALIST_2) +{ + Process *net_kernel; + Uint creation; + + /* valid creation ? */ + if(!term_to_Uint(BIF_ARG_2, &creation)) + goto error; + if(creation > 3) + goto error; + + /* valid node name ? */ + if (!is_node_name_atom(BIF_ARG_1)) + goto error; + + if (BIF_ARG_1 == am_Noname) /* cant use this name !! */ + goto error; + if (erts_is_alive) /* must not be alive! */ + goto error; + + /* Check that all trap functions are defined !! */ + if (dsend2_trap->address == NULL || + dsend3_trap->address == NULL || + /* dsend_nosuspend_trap->address == NULL ||*/ + dlink_trap->address == NULL || + dunlink_trap->address == NULL || + dmonitor_node_trap->address == NULL || + dgroup_leader_trap->address == NULL || + dmonitor_p_trap->address == NULL || + dexit_trap->address == NULL) { + goto error; + } + + net_kernel = erts_whereis_process(BIF_P, ERTS_PROC_LOCK_MAIN, + am_net_kernel, ERTS_PROC_LOCK_MAIN, 0); + if (!net_kernel) + goto error; + + /* By setting dist_entry==erts_this_dist_entry and DISTRIBUTION on + net_kernel do_net_exist will be called when net_kernel + is terminated !! */ + (void *) ERTS_PROC_SET_DIST_ENTRY(net_kernel, + ERTS_PROC_LOCK_MAIN, + erts_this_dist_entry); + erts_refc_inc(&erts_this_dist_entry->refc, 2); + net_kernel->flags |= F_DISTRIBUTION; + + if (net_kernel != BIF_P) + erts_smp_proc_unlock(net_kernel, ERTS_PROC_LOCK_MAIN); + +#ifdef DEBUG + erts_smp_rwmtx_rwlock(&erts_dist_table_rwmtx); + ASSERT(!erts_visible_dist_entries && !erts_hidden_dist_entries); + erts_smp_rwmtx_rwunlock(&erts_dist_table_rwmtx); +#endif + + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN); + erts_smp_block_system(ERTS_BS_FLG_ALLOW_GC); + erts_set_this_node(BIF_ARG_1, (Uint32) creation); + erts_is_alive = 1; + send_nodes_mon_msgs(NULL, am_nodeup, BIF_ARG_1, am_visible, NIL); + erts_smp_release_system(); + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_MAIN); + + BIF_RET(am_true); + + error: + BIF_ERROR(BIF_P, BADARG); +} + +/********************************************************************** + ** Allocate a dist entry, set node name install the connection handler + ** setnode_3({name@host, Creation}, Cid, {Type, Version, Initial, IC, OC}) + ** Type = flag field, where the flags are specified in dist.h + ** Version = distribution version, >= 1 + ** IC = in_cookie (ignored) + ** OC = out_cookie (ignored) + ** + ** Note that in distribution protocols above 1, the Initial parameter + ** is always NIL and the cookies are always the atom '', cookies are not + ** sent in the distribution messages but are only used in + ** the handshake. + ** + ***********************************************************************/ + +BIF_RETTYPE setnode_3(BIF_ALIST_3) +{ + BIF_RETTYPE ret; + Uint flags; + unsigned long version; + Eterm ic, oc; + Eterm *tp; + DistEntry *dep = NULL; + Port *pp = NULL; + + /* Prepare for success */ + ERTS_BIF_PREP_RET(ret, am_true); + + /* + * Check and pick out arguments + */ + + if (!is_node_name_atom(BIF_ARG_1) || + is_not_internal_port(BIF_ARG_2) || + (erts_this_node->sysname == am_Noname)) { + goto badarg; + } + + if (!is_tuple(BIF_ARG_3)) + goto badarg; + tp = tuple_val(BIF_ARG_3); + if (*tp++ != make_arityval(4)) + goto badarg; + if (!is_small(*tp)) + goto badarg; + flags = unsigned_val(*tp++); + if (!is_small(*tp) || (version = unsigned_val(*tp)) == 0) + goto badarg; + ic = *(++tp); + oc = *(++tp); + if (!is_atom(ic) || !is_atom(oc)) + goto badarg; + + /* DFLAG_EXTENDED_REFERENCES is compulsory from R9 and forward */ + if (!(DFLAG_EXTENDED_REFERENCES & flags)) { + erts_dsprintf_buf_t *dsbufp = erts_create_logger_dsbuf(); + erts_dsprintf(dsbufp, "%T", BIF_P->id); + if (BIF_P->reg) + erts_dsprintf(dsbufp, " (%T)", BIF_P->reg->name); + erts_dsprintf(dsbufp, + " attempted to enable connection to node %T " + "which is not able to handle extended references.\n", + BIF_ARG_1); + erts_send_error_to_logger(BIF_P->group_leader, dsbufp); + goto badarg; + } + + /* + * Arguments seem to be in order. + */ + + /* get dist_entry */ + dep = erts_find_or_insert_dist_entry(BIF_ARG_1); + if (dep == erts_this_dist_entry) + goto badarg; + else if (!dep) + goto system_limit; /* Should never happen!!! */ + + pp = erts_id2port(BIF_ARG_2, BIF_P, ERTS_PROC_LOCK_MAIN); + erts_smp_de_rwlock(dep); + + if (!pp || (pp->status & ERTS_PORT_SFLG_EXITING)) + goto badarg; + + if ((pp->drv_ptr->flags & ERL_DRV_FLAG_SOFT_BUSY) == 0) + goto badarg; + + if (dep->cid == BIF_ARG_2 && pp->dist_entry == dep) + goto done; /* Already set */ + + if (dep->status & ERTS_DE_SFLG_EXITING) { + /* Suspend on dist entry waiting for the exit to finish */ + ErtsProcList *plp = erts_proclist_create(BIF_P); + plp->next = NULL; + erts_suspend(BIF_P, ERTS_PROC_LOCK_MAIN, NULL); + erts_smp_spin_lock(&dep->qlock); + if (dep->suspended.last) + dep->suspended.last->next = plp; + else + dep->suspended.first = plp; + dep->suspended.last = plp; + erts_smp_spin_unlock(&dep->qlock); + goto yield; + } + + ASSERT(!(dep->status & ERTS_DE_SFLG_EXITING)); + + if (pp->dist_entry || is_not_nil(dep->cid)) + goto badarg; + + erts_port_status_bor_set(pp, ERTS_PORT_SFLG_DISTRIBUTION); + + pp->dist_entry = dep; + + dep->version = version; + dep->creation = 0; + + ASSERT(pp->drv_ptr->outputv || pp->drv_ptr->output); + +#if 1 + dep->send = (pp->drv_ptr->outputv + ? dist_port_commandv + : dist_port_command); +#else + dep->send = dist_port_command; +#endif + ASSERT(dep->send); + +#ifdef DEBUG + erts_smp_spin_lock(&dep->qlock); + ASSERT(dep->qsize == 0); + erts_smp_spin_unlock(&dep->qlock); +#endif + + erts_set_dist_entry_connected(dep, BIF_ARG_2, flags); + + if (flags & DFLAG_DIST_HDR_ATOM_CACHE) + create_cache(dep); + + erts_smp_de_rwunlock(dep); + dep = NULL; /* inc of refc transferred to port (dist_entry field) */ + + send_nodes_mon_msgs(BIF_P, + am_nodeup, + BIF_ARG_1, + flags & DFLAG_PUBLISHED ? am_visible : am_hidden, + NIL); + done: + + if (dep && dep != erts_this_dist_entry) { + erts_smp_de_rwunlock(dep); + erts_deref_dist_entry(dep); + } + + if (pp) + erts_smp_port_unlock(pp); + + return ret; + + yield: + ERTS_BIF_PREP_YIELD3(ret, bif_export[BIF_setnode_3], BIF_P, + BIF_ARG_1, BIF_ARG_2, BIF_ARG_3); + goto done; + + badarg: + ERTS_BIF_PREP_ERROR(ret, BIF_P, BADARG); + goto done; + + system_limit: + ERTS_BIF_PREP_ERROR(ret, BIF_P, SYSTEM_LIMIT); + goto done; +} + + +/**********************************************************************/ +/* dist_exit(Local, Term, Remote) -> Bool */ + +BIF_RETTYPE dist_exit_3(BIF_ALIST_3) +{ + Eterm local; + Eterm remote; + DistEntry *rdep; + + local = BIF_ARG_1; + remote = BIF_ARG_3; + + /* Check that remote is a remote process */ + if (is_not_external_pid(remote)) + goto error; + + rdep = external_dist_entry(remote); + + if(rdep == erts_this_dist_entry) + goto error; + + /* Check that local is local */ + if (is_internal_pid(local)) { + Process *lp; + ErtsProcLocks lp_locks; + if (BIF_P->id == local) { + lp_locks = ERTS_PROC_LOCKS_ALL; + lp = BIF_P; + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCKS_ALL_MINOR); + } + else { + lp_locks = ERTS_PROC_LOCKS_XSIG_SEND; + lp = erts_pid2proc_opt(BIF_P, ERTS_PROC_LOCK_MAIN, + local, lp_locks, + ERTS_P2P_FLG_SMP_INC_REFC); + if (!lp) { + BIF_RET(am_true); /* ignore */ + } + } + + (void) erts_send_exit_signal(BIF_P, + remote, + lp, + &lp_locks, + BIF_ARG_2, + NIL, + NULL, + 0); +#ifdef ERTS_SMP + if (lp == BIF_P) + lp_locks &= ~ERTS_PROC_LOCK_MAIN; +#endif + erts_smp_proc_unlock(lp, lp_locks); + if (lp != BIF_P) + erts_smp_proc_dec_refc(lp); + else { + /* + * We may have exited current process and may have to take action. + */ + ERTS_BIF_CHK_EXITED(BIF_P); + ERTS_SMP_BIF_CHK_PENDING_EXIT(BIF_P, ERTS_PROC_LOCK_MAIN); + } + } + else if (is_external_pid(local) + && external_dist_entry(local) == erts_this_dist_entry) { + BIF_RET(am_true); /* ignore */ + } + else + goto error; + BIF_RET(am_true); + + error: + BIF_ERROR(BIF_P, BADARG); +} + +/**********************************************************************/ +/* node(Object) -> Node */ + +BIF_RETTYPE node_1(BIF_ALIST_1) +{ + if (is_not_node_container(BIF_ARG_1)) + BIF_ERROR(BIF_P, BADARG); + BIF_RET(node_container_node_name(BIF_ARG_1)); +} + +/**********************************************************************/ +/* node() -> Node */ + +BIF_RETTYPE node_0(BIF_ALIST_0) +{ + BIF_RET(erts_this_dist_entry->sysname); +} + + +/**********************************************************************/ +/* nodes() -> [ Node ] */ + +#if 0 /* Done in erlang.erl instead. */ +BIF_RETTYPE nodes_0(BIF_ALIST_0) +{ + return nodes_1(BIF_P, am_visible); +} +#endif + + +BIF_RETTYPE nodes_1(BIF_ALIST_1) +{ + Eterm result; + int length; + Eterm* hp; + int not_connected = 0; + int visible = 0; + int hidden = 0; + int this = 0; + Uint buf[2]; /* For one cons-cell */ + DistEntry *dep; + Eterm arg_list = BIF_ARG_1; +#ifdef DEBUG + Eterm* endp; +#endif + if (is_atom(BIF_ARG_1)) + arg_list = CONS(buf, BIF_ARG_1, NIL); + + while (is_list(arg_list)) { + switch(CAR(list_val(arg_list))) { + case am_visible: visible = 1; break; + case am_hidden: hidden = 1; break; + case am_known: visible = hidden = not_connected = this = 1; break; + case am_this: this = 1; break; + case am_connected: visible = hidden = 1; break; + default: BIF_ERROR(BIF_P, BADARG); break; + } + arg_list = CDR(list_val(arg_list)); + } + + if (is_not_nil(arg_list)) + BIF_ERROR(BIF_P, BADARG); + + length = 0; + + erts_smp_rwmtx_rwlock(&erts_dist_table_rwmtx); + + ASSERT(erts_no_of_not_connected_dist_entries >= 0); + ASSERT(erts_no_of_hidden_dist_entries >= 0); + ASSERT(erts_no_of_visible_dist_entries >= 0); + if(not_connected) + length += erts_no_of_not_connected_dist_entries; + if(hidden) + length += erts_no_of_hidden_dist_entries; + if(visible) + length += erts_no_of_visible_dist_entries; + if(this) + length++; + + result = NIL; + + if (length == 0) { + erts_smp_rwmtx_rwunlock(&erts_dist_table_rwmtx); + BIF_RET(result); + } + + hp = HAlloc(BIF_P, 2*length); + +#ifdef DEBUG + endp = hp + length*2; +#endif + if(not_connected) + for(dep = erts_not_connected_dist_entries; dep; dep = dep->next) { + result = CONS(hp, dep->sysname, result); + hp += 2; + } + if(hidden) + for(dep = erts_hidden_dist_entries; dep; dep = dep->next) { + result = CONS(hp, dep->sysname, result); + hp += 2; + } + if(visible) + for(dep = erts_visible_dist_entries; dep; dep = dep->next) { + result = CONS(hp, dep->sysname, result); + hp += 2; + } + if(this) { + result = CONS(hp, erts_this_dist_entry->sysname, result); + hp += 2; + } + ASSERT(endp == hp); + erts_smp_rwmtx_rwunlock(&erts_dist_table_rwmtx); + BIF_RET(result); +} + +/**********************************************************************/ +/* is_alive() -> Bool */ + +BIF_RETTYPE is_alive_0(BIF_ALIST_0) +{ + Eterm res = erts_is_alive ? am_true : am_false; + BIF_RET(res); +} + +/**********************************************************************/ +/* erlang:monitor_node(Node, Bool, Options) -> Bool */ + +BIF_RETTYPE monitor_node_3(BIF_ALIST_3) +{ + DistEntry *dep; + ErtsLink *lnk; + Eterm l; + + for (l = BIF_ARG_3; l != NIL && is_list(l); l = CDR(list_val(l))) { + Eterm t = CAR(list_val(l)); + /* allow_passive_connect the only available option right now */ + if (t != am_allow_passive_connect) { + BIF_ERROR(BIF_P, BADARG); + } + } + if (l != NIL) { + BIF_ERROR(BIF_P, BADARG); + } + + if (is_not_atom(BIF_ARG_1) || + ((BIF_ARG_2 != am_true) && (BIF_ARG_2 != am_false)) || + ((erts_this_node->sysname == am_Noname) + && (BIF_ARG_1 != erts_this_node->sysname))) { + BIF_ERROR(BIF_P, BADARG); + } + dep = erts_sysname_to_connected_dist_entry(BIF_ARG_1); + if (!dep) { + do_trap: + BIF_TRAP3(dmonitor_node_trap, BIF_P, BIF_ARG_1, BIF_ARG_2, BIF_ARG_3); + } + if (dep == erts_this_dist_entry) + goto done; + + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_LINK); + erts_smp_de_rlock(dep); + if (ERTS_DE_IS_NOT_CONNECTED(dep)) { + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_LINK); + erts_smp_de_runlock(dep); + goto do_trap; + } + erts_smp_de_links_lock(dep); + erts_smp_de_runlock(dep); + + if (BIF_ARG_2 == am_true) { + ASSERT(dep->cid != NIL); + lnk = erts_add_or_lookup_link(&(dep->node_links), LINK_NODE, + BIF_P->id); + ++ERTS_LINK_REFC(lnk); + lnk = erts_add_or_lookup_link(&(BIF_P->nlinks), LINK_NODE, BIF_ARG_1); + ++ERTS_LINK_REFC(lnk); + } + else { + lnk = erts_lookup_link(dep->node_links, BIF_P->id); + if (lnk != NULL) { + if ((--ERTS_LINK_REFC(lnk)) == 0) { + erts_destroy_link(erts_remove_link(&(dep->node_links), + BIF_P->id)); + } + } + lnk = erts_lookup_link(BIF_P->nlinks, BIF_ARG_1); + if (lnk != NULL) { + if ((--ERTS_LINK_REFC(lnk)) == 0) { + erts_destroy_link(erts_remove_link(&(BIF_P->nlinks), + BIF_ARG_1)); + } + } + } + + erts_smp_de_links_unlock(dep); + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_LINK); + + done: + erts_deref_dist_entry(dep); + BIF_RET(am_true); +} + +/* monitor_node(Node, Bool) -> Bool */ + +BIF_RETTYPE monitor_node_2(BIF_ALIST_2) +{ + BIF_RET(monitor_node_3(BIF_P,BIF_ARG_1,BIF_ARG_2,NIL)); +} + +BIF_RETTYPE net_kernel_dflag_unicode_io_1(BIF_ALIST_1) +{ + DistEntry *de; + Uint32 f; + if (is_not_pid(BIF_ARG_1)) { + BIF_ERROR(BIF_P,BADARG); + } + de = pid_dist_entry(BIF_ARG_1); + ASSERT(de != NULL); + if (de == erts_this_dist_entry) { + BIF_RET(am_true); + } + erts_smp_de_rlock(de); + f = de->flags; + erts_smp_de_runlock(de); + BIF_RET(((f & DFLAG_UNICODE_IO) ? am_true : am_false)); +} + +/* + * The major part of the implementation of net_kernel:monitor_nodes/[1,2] + * follows. + * + * Currently net_kernel:monitor_nodes/[1,2] calls process_flag/2 which in + * turn calls erts_monitor_nodes(). If the process_flag() call fails (with + * badarg), the code in net_kernel determines what type of error to return. + * This in order to simplify the task of being backward compatible. + */ + +#define ERTS_NODES_MON_OPT_TYPE_VISIBLE (((Uint16) 1) << 0) +#define ERTS_NODES_MON_OPT_TYPE_HIDDEN (((Uint16) 1) << 1) +#define ERTS_NODES_MON_OPT_DOWN_REASON (((Uint16) 1) << 2) + +#define ERTS_NODES_MON_OPT_TYPES \ + (ERTS_NODES_MON_OPT_TYPE_VISIBLE|ERTS_NODES_MON_OPT_TYPE_HIDDEN) + +typedef struct ErtsNodesMonitor_ ErtsNodesMonitor; +struct ErtsNodesMonitor_ { + ErtsNodesMonitor *prev; + ErtsNodesMonitor *next; + Process *proc; + Uint16 opts; + Uint16 no; +}; + +static erts_smp_mtx_t nodes_monitors_mtx; +static ErtsNodesMonitor *nodes_monitors; +static ErtsNodesMonitor *nodes_monitors_end; + +/* + * Nodes monitors are stored in a double linked list. 'nodes_monitors' + * points to the beginning of the list and 'nodes_monitors_end' points + * to the end of the list. + * + * There might be more than one entry per process in the list. If so, + * they are located in sequence. The 'nodes_monitors' field of the + * process struct refers to the first element in the sequence + * corresponding to the process in question. + */ + +static void +init_nodes_monitors(void) +{ + erts_smp_mtx_init(&nodes_monitors_mtx, "nodes_monitors"); + nodes_monitors = NULL; + nodes_monitors_end = NULL; +} + +static ERTS_INLINE Uint +nodes_mon_msg_sz(ErtsNodesMonitor *nmp, Eterm what, Eterm reason) +{ + Uint sz; + if (!nmp->opts) { + sz = 3; + } + else { + sz = 0; + + if (nmp->opts & ERTS_NODES_MON_OPT_TYPES) + sz += 2 + 3; + + if (what == am_nodedown + && (nmp->opts & ERTS_NODES_MON_OPT_DOWN_REASON)) { + if (is_not_immed(reason)) + sz += size_object(reason); + sz += 2 + 3; + } + + sz += 4; + } + return sz; +} + +static ERTS_INLINE void +send_nodes_mon_msg(Process *rp, + ErtsProcLocks *rp_locksp, + ErtsNodesMonitor *nmp, + Eterm node, + Eterm what, + Eterm type, + Eterm reason, + Uint sz) +{ + Eterm msg; + ErlHeapFragment* bp; + ErlOffHeap *ohp; + Eterm *hp = erts_alloc_message_heap(sz, &bp, &ohp, rp, rp_locksp); +#ifdef DEBUG + Eterm *hend = hp + sz; +#endif + + if (!nmp->opts) { + msg = TUPLE2(hp, what, node); +#ifdef DEBUG + hp += 3; +#endif + } + else { + Eterm tup; + Eterm info = NIL; + + if (nmp->opts & (ERTS_NODES_MON_OPT_TYPE_VISIBLE + | ERTS_NODES_MON_OPT_TYPE_HIDDEN)) { + + tup = TUPLE2(hp, am_node_type, type); + hp += 3; + info = CONS(hp, tup, info); + hp += 2; + } + + if (what == am_nodedown + && (nmp->opts & ERTS_NODES_MON_OPT_DOWN_REASON)) { + Eterm rsn_cpy; + + if (is_immed(reason)) + rsn_cpy = reason; + else { + Eterm rsn_sz = size_object(reason); + rsn_cpy = copy_struct(reason, rsn_sz, &hp, ohp); + } + + tup = TUPLE2(hp, am_nodedown_reason, rsn_cpy); + hp += 3; + info = CONS(hp, tup, info); + hp += 2; + } + + msg = TUPLE3(hp, what, node, info); +#ifdef DEBUG + hp += 4; +#endif + } + + ASSERT(hend == hp); + erts_queue_message(rp, rp_locksp, bp, msg, NIL); +} + +static void +send_nodes_mon_msgs(Process *c_p, Eterm what, Eterm node, Eterm type, Eterm reason) +{ + ErtsNodesMonitor *nmp; + ErtsProcLocks rp_locks = 0; /* Init to shut up false warning */ + Process *rp = NULL; + + ASSERT(is_immed(what)); + ASSERT(is_immed(node)); + ASSERT(is_immed(type)); + + ERTS_SMP_LC_ASSERT(!c_p + || (erts_proc_lc_my_proc_locks(c_p) + == ERTS_PROC_LOCK_MAIN)); + erts_smp_mtx_lock(&nodes_monitors_mtx); + + for (nmp = nodes_monitors; nmp; nmp = nmp->next) { + int i; + Uint16 no; + Uint sz; + + ASSERT(nmp->proc != NULL); + + if (!nmp->opts) { + if (type != am_visible) + continue; + } + else { + switch (type) { + case am_hidden: + if (!(nmp->opts & ERTS_NODES_MON_OPT_TYPE_HIDDEN)) + continue; + break; + case am_visible: + if ((nmp->opts & ERTS_NODES_MON_OPT_TYPES) + && !(nmp->opts & ERTS_NODES_MON_OPT_TYPE_VISIBLE)) + continue; + break; + default: + erl_exit(ERTS_ABORT_EXIT, "Bad node type found\n"); + } + } + + if (rp != nmp->proc) { + if (rp) { + if (rp == c_p) + rp_locks &= ~ERTS_PROC_LOCK_MAIN; + erts_smp_proc_unlock(rp, rp_locks); + } + + rp = nmp->proc; + rp_locks = 0; + if (rp == c_p) + rp_locks |= ERTS_PROC_LOCK_MAIN; + } + + ASSERT(rp); + + sz = nodes_mon_msg_sz(nmp, what, reason); + + for (i = 0, no = nmp->no; i < no; i++) + send_nodes_mon_msg(rp, + &rp_locks, + nmp, + node, + what, + type, + reason, + sz); + } + + if (rp) { + if (rp == c_p) + rp_locks &= ~ERTS_PROC_LOCK_MAIN; + erts_smp_proc_unlock(rp, rp_locks); + } + + erts_smp_mtx_unlock(&nodes_monitors_mtx); +} + +static Eterm +insert_nodes_monitor(Process *c_p, Uint32 opts) +{ + Uint16 no = 1; + Eterm res = am_false; + ErtsNodesMonitor *xnmp, *nmp; + + ERTS_SMP_LC_ASSERT(erts_smp_lc_mtx_is_locked(&nodes_monitors_mtx)); + ERTS_SMP_LC_ASSERT(erts_proc_lc_my_proc_locks(c_p) & ERTS_PROC_LOCK_MAIN); + + xnmp = c_p->nodes_monitors; + if (xnmp) { + ASSERT(!xnmp->prev || xnmp->prev->proc != c_p); + + while (1) { + ASSERT(xnmp->proc == c_p); + if (xnmp->opts == opts) + break; + if (!xnmp->next || xnmp->next->proc != c_p) + break; + xnmp = xnmp->next; + } + ASSERT(xnmp); + ASSERT(xnmp->proc == c_p); + ASSERT(xnmp->opts == opts + || !xnmp->next + || xnmp->next->proc != c_p); + + if (xnmp->opts != opts) + goto alloc_new; + else { + res = am_true; + no = xnmp->no++; + if (!xnmp->no) { + /* + * 'no' wrapped; transfer all prevous monitors to new + * element (which will be the next element in the list) + * and set this to one... + */ + xnmp->no = 1; + goto alloc_new; + } + } + } + else { + alloc_new: + nmp = erts_alloc(ERTS_ALC_T_NODES_MON, sizeof(ErtsNodesMonitor)); + nmp->proc = c_p; + nmp->opts = opts; + nmp->no = no; + + if (xnmp) { + ASSERT(nodes_monitors); + ASSERT(c_p->nodes_monitors); + nmp->next = xnmp->next; + nmp->prev = xnmp; + xnmp->next = nmp; + if (nmp->next) { + ASSERT(nodes_monitors_end != xnmp); + ASSERT(nmp->next->prev == xnmp); + nmp->next->prev = nmp; + } + else { + ASSERT(nodes_monitors_end == xnmp); + nodes_monitors_end = nmp; + } + } + else { + ASSERT(!c_p->nodes_monitors); + c_p->nodes_monitors = nmp; + nmp->next = NULL; + nmp->prev = nodes_monitors_end; + if (nodes_monitors_end) { + ASSERT(nodes_monitors); + nodes_monitors_end->next = nmp; + } + else { + ASSERT(!nodes_monitors); + nodes_monitors = nmp; + } + nodes_monitors_end = nmp; + } + } + return res; +} + +static Eterm +remove_nodes_monitors(Process *c_p, Uint32 opts, int all) +{ + Eterm res = am_false; + ErtsNodesMonitor *nmp; + + ERTS_SMP_LC_ASSERT(erts_smp_lc_mtx_is_locked(&nodes_monitors_mtx)); + ERTS_SMP_LC_ASSERT(erts_proc_lc_my_proc_locks(c_p) & ERTS_PROC_LOCK_MAIN); + + nmp = c_p->nodes_monitors; + ASSERT(!nmp || !nmp->prev || nmp->prev->proc != c_p); + + while (nmp && nmp->proc == c_p) { + if (!all && nmp->opts != opts) + nmp = nmp->next; + else { /* if (all || nmp->opts == opts) */ + ErtsNodesMonitor *free_nmp; + res = am_true; + if (nmp->prev) { + ASSERT(nodes_monitors != nmp); + nmp->prev->next = nmp->next; + } + else { + ASSERT(nodes_monitors == nmp); + nodes_monitors = nmp->next; + } + if (nmp->next) { + ASSERT(nodes_monitors_end != nmp); + nmp->next->prev = nmp->prev; + } + else { + ASSERT(nodes_monitors_end == nmp); + nodes_monitors_end = nmp->prev; + } + free_nmp = nmp; + nmp = nmp->next; + if (c_p->nodes_monitors == free_nmp) + c_p->nodes_monitors = nmp && nmp->proc == c_p ? nmp : NULL; + erts_free(ERTS_ALC_T_NODES_MON, free_nmp); + } + } + + ASSERT(!all || !c_p->nodes_monitors); + return res; +} + +void +erts_delete_nodes_monitors(Process *c_p, ErtsProcLocks locks) +{ +#if defined(ERTS_ENABLE_LOCK_CHECK) && defined(ERTS_SMP) + if (c_p) { + ErtsProcLocks might_unlock = locks & ~ERTS_PROC_LOCK_MAIN; + if (might_unlock) + erts_proc_lc_might_unlock(c_p, might_unlock); + } +#endif + if (erts_smp_mtx_trylock(&nodes_monitors_mtx) == EBUSY) { + ErtsProcLocks unlock_locks = locks & ~ERTS_PROC_LOCK_MAIN; + if (c_p && unlock_locks) + erts_smp_proc_unlock(c_p, unlock_locks); + erts_smp_mtx_lock(&nodes_monitors_mtx); + if (c_p && unlock_locks) + erts_smp_proc_lock(c_p, unlock_locks); + } + remove_nodes_monitors(c_p, 0, 1); + erts_smp_mtx_unlock(&nodes_monitors_mtx); +} + +Eterm +erts_monitor_nodes(Process *c_p, Eterm on, Eterm olist) +{ + Eterm res; + Eterm opts_list = olist; + Uint16 opts = (Uint16) 0; + + ASSERT(c_p); + ERTS_SMP_LC_ASSERT(erts_proc_lc_my_proc_locks(c_p) == ERTS_PROC_LOCK_MAIN); + + if (on != am_true && on != am_false) + return THE_NON_VALUE; + + if (is_not_nil(opts_list)) { + int all = 0, visible = 0, hidden = 0; + + while (is_list(opts_list)) { + Eterm *cp = list_val(opts_list); + Eterm opt = CAR(cp); + opts_list = CDR(cp); + if (opt == am_nodedown_reason) + opts |= ERTS_NODES_MON_OPT_DOWN_REASON; + else if (is_tuple(opt)) { + Eterm* tp = tuple_val(opt); + if (arityval(tp[0]) != 2) + return THE_NON_VALUE; + switch (tp[1]) { + case am_node_type: + switch (tp[2]) { + case am_visible: + if (hidden || all) + return THE_NON_VALUE; + opts |= ERTS_NODES_MON_OPT_TYPE_VISIBLE; + visible = 1; + break; + case am_hidden: + if (visible || all) + return THE_NON_VALUE; + opts |= ERTS_NODES_MON_OPT_TYPE_HIDDEN; + hidden = 1; + break; + case am_all: + if (visible || hidden) + return THE_NON_VALUE; + opts |= ERTS_NODES_MON_OPT_TYPES; + all = 1; + break; + default: + return THE_NON_VALUE; + } + break; + default: + return THE_NON_VALUE; + } + } + else { + return THE_NON_VALUE; + } + } + + if (is_not_nil(opts_list)) + return THE_NON_VALUE; + } + + erts_smp_mtx_lock(&nodes_monitors_mtx); + + if (on == am_true) + res = insert_nodes_monitor(c_p, opts); + else + res = remove_nodes_monitors(c_p, opts, 0); + + erts_smp_mtx_unlock(&nodes_monitors_mtx); + + return res; +} + +/* + * Note, this function is only used for debuging. + */ + +Eterm +erts_processes_monitoring_nodes(Process *c_p) +{ + ErtsNodesMonitor *nmp; + Eterm res; + Eterm *hp; + Eterm **hpp; + Uint sz; + Uint *szp; +#ifdef DEBUG + Eterm *hend; +#endif + + ASSERT(c_p); + ERTS_SMP_LC_ASSERT(erts_proc_lc_my_proc_locks(c_p) == ERTS_PROC_LOCK_MAIN); + erts_smp_mtx_lock(&nodes_monitors_mtx); + + sz = 0; + szp = &sz; + hpp = NULL; + + bld_result: + res = NIL; + + for (nmp = nodes_monitors_end; nmp; nmp = nmp->prev) { + Uint16 i; + for (i = 0; i < nmp->no; i++) { + Eterm olist = NIL; + if (nmp->opts & ERTS_NODES_MON_OPT_TYPES) { + Eterm type; + switch (nmp->opts & ERTS_NODES_MON_OPT_TYPES) { + case ERTS_NODES_MON_OPT_TYPES: type = am_all; break; + case ERTS_NODES_MON_OPT_TYPE_VISIBLE: type = am_visible; break; + case ERTS_NODES_MON_OPT_TYPE_HIDDEN: type = am_hidden; break; + default: erl_exit(ERTS_ABORT_EXIT, "Bad node type found\n"); + } + olist = erts_bld_cons(hpp, szp, + erts_bld_tuple(hpp, szp, 2, + am_node_type, + type), + olist); + } + if (nmp->opts & ERTS_NODES_MON_OPT_DOWN_REASON) + olist = erts_bld_cons(hpp, szp, am_nodedown_reason, olist); + res = erts_bld_cons(hpp, szp, + erts_bld_tuple(hpp, szp, 2, + nmp->proc->id, + olist), + res); + } + } + + if (!hpp) { + hp = HAlloc(c_p, sz); +#ifdef DEBUG + hend = hp + sz; +#endif + hpp = &hp; + szp = NULL; + goto bld_result; + } + + ASSERT(hp == hend); + + erts_smp_mtx_unlock(&nodes_monitors_mtx); + + return res; +} diff --git a/erts/emulator/beam/dist.h b/erts/emulator/beam/dist.h new file mode 100644 index 0000000000..ea1abcaeed --- /dev/null +++ b/erts/emulator/beam/dist.h @@ -0,0 +1,290 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifndef __DIST_H__ +#define __DIST_H__ + +#include "erl_process.h" +#include "erl_node_tables.h" + +#define DFLAG_PUBLISHED 0x01 +#define DFLAG_ATOM_CACHE 0x02 +#define DFLAG_EXTENDED_REFERENCES 0x04 +#define DFLAG_DIST_MONITOR 0x08 +#define DFLAG_FUN_TAGS 0x10 +#define DFLAG_DIST_MONITOR_NAME 0x20 +#define DFLAG_HIDDEN_ATOM_CACHE 0x40 +#define DFLAG_NEW_FUN_TAGS 0x80 +#define DFLAG_EXTENDED_PIDS_PORTS 0x100 +#define DFLAG_EXPORT_PTR_TAG 0x200 +#define DFLAG_BIT_BINARIES 0x400 +#define DFLAG_NEW_FLOATS 0x800 +#define DFLAG_UNICODE_IO 0x1000 +#define DFLAG_DIST_HDR_ATOM_CACHE 0x2000 +#define DFLAG_SMALL_ATOM_TAGS 0x4000 + +/* All flags that should be enabled when term_to_binary/1 is used. */ +#define TERM_TO_BINARY_DFLAGS (DFLAG_EXTENDED_REFERENCES \ + | DFLAG_NEW_FUN_TAGS \ + | DFLAG_EXTENDED_PIDS_PORTS \ + | DFLAG_EXPORT_PTR_TAG \ + | DFLAG_BIT_BINARIES) + +/* opcodes used in distribution messages */ +#define DOP_LINK 1 +#define DOP_SEND 2 +#define DOP_EXIT 3 +#define DOP_UNLINK 4 +#define DOP_NODE_LINK 5 +#define DOP_REG_SEND 6 +#define DOP_GROUP_LEADER 7 +#define DOP_EXIT2 8 + +#define DOP_SEND_TT 12 +#define DOP_EXIT_TT 13 +#define DOP_REG_SEND_TT 16 +#define DOP_EXIT2_TT 18 + +#define DOP_MONITOR_P 19 +#define DOP_DEMONITOR_P 20 +#define DOP_MONITOR_P_EXIT 21 + +/* distribution trap functions */ +extern Export* dsend2_trap; +extern Export* dsend3_trap; +/*extern Export* dsend_nosuspend_trap;*/ +extern Export* dlink_trap; +extern Export* dunlink_trap; +extern Export* dmonitor_node_trap; +extern Export* dgroup_leader_trap; +extern Export* dexit_trap; +extern Export* dmonitor_p_trap; + +typedef enum { + ERTS_DSP_NO_LOCK, + ERTS_DSP_RLOCK, + ERTS_DSP_RWLOCK +} ErtsDSigPrepLock; + + +typedef struct { + Process *proc; + DistEntry *dep; + Eterm cid; + Eterm connection_id; + int no_suspend; +} ErtsDSigData; + +#define ERTS_DE_IS_NOT_CONNECTED(DEP) \ + (ERTS_SMP_LC_ASSERT(erts_lc_rwmtx_is_rlocked(&(DEP)->rwmtx) \ + || erts_lc_rwmtx_is_rwlocked(&(DEP)->rwmtx)), \ + (is_nil((DEP)->cid) || ((DEP)->status & ERTS_DE_SFLG_EXITING))) + +#define ERTS_DE_IS_CONNECTED(DEP) \ + (!ERTS_DE_IS_NOT_CONNECTED((DEP))) + + +extern int erts_is_alive; + +/* + * erts_dsig_prepare() prepares a send of a distributed signal. + * One of the values defined below are returned. If the returned + * value is another than ERTS_DSIG_PREP_CONNECTED, the + * distributed signal cannot be sent before apropriate actions + * have been taken. Apropriate actions would typically be setting + * up the connection. + */ + +/* Connected; signal can be sent. */ +#define ERTS_DSIG_PREP_CONNECTED 0 +/* Not connected; connection needs to be set up. */ +#define ERTS_DSIG_PREP_NOT_CONNECTED 1 +/* Caller would be suspended on send operation. */ +#define ERTS_DSIG_PREP_WOULD_SUSPEND 2 +/* System not alive (distributed) */ +#define ERTS_DSIG_PREP_NOT_ALIVE 3 + +ERTS_GLB_INLINE int erts_dsig_prepare(ErtsDSigData *, + DistEntry *, + Process *, + ErtsDSigPrepLock, + int); + +ERTS_GLB_INLINE +void erts_schedule_dist_command(Port *, DistEntry *); + +#if ERTS_GLB_INLINE_INCL_FUNC_DEF + +ERTS_GLB_INLINE int +erts_dsig_prepare(ErtsDSigData *dsdp, + DistEntry *dep, + Process *proc, + ErtsDSigPrepLock dspl, + int no_suspend) +{ + int failure; + if (!erts_is_alive) + return ERTS_DSIG_PREP_NOT_ALIVE; + if (!dep) + return ERTS_DSIG_PREP_NOT_CONNECTED; + if (dspl == ERTS_DSP_RWLOCK) + erts_smp_de_rwlock(dep); + else + erts_smp_de_rlock(dep); + if (ERTS_DE_IS_NOT_CONNECTED(dep)) { + failure = ERTS_DSIG_PREP_NOT_CONNECTED; + goto fail; + } + if (no_suspend) { + failure = ERTS_DSIG_PREP_CONNECTED; + erts_smp_spin_lock(&dep->qlock); + if (dep->qflgs & ERTS_DE_QFLG_BUSY) + failure = ERTS_DSIG_PREP_WOULD_SUSPEND; + erts_smp_spin_unlock(&dep->qlock); + if (failure == ERTS_DSIG_PREP_WOULD_SUSPEND) + goto fail; + } + dsdp->proc = proc; + dsdp->dep = dep; + dsdp->cid = dep->cid; + dsdp->connection_id = dep->connection_id; + dsdp->no_suspend = no_suspend; + if (dspl == ERTS_DSP_NO_LOCK) + erts_smp_de_runlock(dep); + return ERTS_DSIG_PREP_CONNECTED; + + fail: + if (dspl == ERTS_DSP_RWLOCK) + erts_smp_de_rwunlock(dep); + else + erts_smp_de_runlock(dep); + return failure; + +} + +ERTS_GLB_INLINE +void erts_schedule_dist_command(Port *prt, DistEntry *dist_entry) +{ + DistEntry *dep; + Eterm id; + + if (prt) { + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(prt)); + ASSERT((erts_port_status_get(prt) & ERTS_PORT_SFLGS_DEAD) == 0); + ASSERT(prt->dist_entry); + + dep = prt->dist_entry; + id = prt->id; + } + else { + ASSERT(dist_entry); + ERTS_SMP_LC_ASSERT(erts_lc_rwmtx_is_rlocked(&dist_entry->rwmtx) + || erts_lc_rwmtx_is_rwlocked(&dist_entry->rwmtx)); + ASSERT(is_internal_port(dist_entry->cid)); + + dep = dist_entry; + id = dep->cid; + } + + if (!erts_smp_atomic_xchg(&dep->dist_cmd_scheduled, 1)) { + (void) erts_port_task_schedule(id, + &dep->dist_cmd, + ERTS_PORT_TASK_DIST_CMD, + (ErlDrvEvent) -1, + NULL); + } +} + +#endif + +typedef struct { + ErtsLink *d_lnk; + ErtsLink *d_sub_lnk; +} ErtsDistLinkData; + +ERTS_GLB_INLINE void erts_remove_dist_link(ErtsDistLinkData *, + Eterm, + Eterm, + DistEntry *); +ERTS_GLB_INLINE int erts_was_dist_link_removed(ErtsDistLinkData *); +ERTS_GLB_INLINE void erts_destroy_dist_link(ErtsDistLinkData *); + +#if ERTS_GLB_INLINE_INCL_FUNC_DEF + +ERTS_GLB_INLINE void +erts_remove_dist_link(ErtsDistLinkData *dldp, + Eterm lid, + Eterm rid, + DistEntry *dep) +{ + erts_smp_de_links_lock(dep); + dldp->d_lnk = erts_lookup_link(dep->nlinks, lid); + if (!dldp->d_lnk) + dldp->d_sub_lnk = NULL; + else { + dldp->d_sub_lnk = erts_remove_link(&ERTS_LINK_ROOT(dldp->d_lnk), rid); + dldp->d_lnk = (ERTS_LINK_ROOT(dldp->d_lnk) + ? NULL + : erts_remove_link(&dep->nlinks, lid)); + } + erts_smp_de_links_unlock(dep); +} + +ERTS_GLB_INLINE int +erts_was_dist_link_removed(ErtsDistLinkData *dldp) +{ + return dldp->d_sub_lnk != NULL; +} + +ERTS_GLB_INLINE void +erts_destroy_dist_link(ErtsDistLinkData *dldp) +{ + if (dldp->d_lnk) + erts_destroy_link(dldp->d_lnk); + if (dldp->d_sub_lnk) + erts_destroy_link(dldp->d_sub_lnk); +} + +#endif + +/* + * erts_dsig_send_* return values. + */ +#define ERTS_DSIG_SEND_OK 0 +#define ERTS_DSIG_SEND_YIELD 1 + +extern int erts_dsig_send_link(ErtsDSigData *, Eterm, Eterm); +extern int erts_dsig_send_msg(ErtsDSigData *, Eterm, Eterm); +extern int erts_dsig_send_exit_tt(ErtsDSigData *, Eterm, Eterm, Eterm, Eterm); +extern int erts_dsig_send_unlink(ErtsDSigData *, Eterm, Eterm); +extern int erts_dsig_send_reg_msg(ErtsDSigData *, Eterm, Eterm); +extern int erts_dsig_send_group_leader(ErtsDSigData *, Eterm, Eterm); +extern int erts_dsig_send_exit(ErtsDSigData *, Eterm, Eterm, Eterm); +extern int erts_dsig_send_exit2(ErtsDSigData *, Eterm, Eterm, Eterm); +extern int erts_dsig_send_demonitor(ErtsDSigData *, Eterm, Eterm, Eterm, int); +extern int erts_dsig_send_monitor(ErtsDSigData *, Eterm, Eterm, Eterm); +extern int erts_dsig_send_m_exit(ErtsDSigData *, Eterm, Eterm, Eterm, Eterm); + +extern int erts_dist_command(Port *prt, int reds); +extern void erts_dist_port_not_busy(Port *prt); +extern void erts_kill_dist_connection(DistEntry *dep, Uint32); + +extern Uint erts_dist_cache_size(void); + +#endif diff --git a/erts/emulator/beam/elib_malloc.c b/erts/emulator/beam/elib_malloc.c new file mode 100644 index 0000000000..b18c48d8d6 --- /dev/null +++ b/erts/emulator/beam/elib_malloc.c @@ -0,0 +1,2334 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1997-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* +** Description: Faster malloc(). +*/ +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" + +#ifdef ENABLE_ELIB_MALLOC + +#undef THREAD_SAFE_ELIB_MALLOC +#ifdef USE_THREADS +#define THREAD_SAFE_ELIB_MALLOC 1 +#else +#define THREAD_SAFE_ELIB_MALLOC 0 +#endif + +#include "erl_driver.h" +#include "erl_threads.h" +#include "elib_stat.h" +#include +#include + +/* To avoid clobbering of names becaure of reclaim on VxWorks, + we undefine all possible malloc, calloc etc. */ +#undef malloc +#undef calloc +#undef free +#undef realloc + +#define ELIB_INLINE /* inline all possible functions */ + +#ifndef ELIB_ALIGN +#define ELIB_ALIGN sizeof(double) +#endif + +#ifndef ELIB_HEAP_SIZE +#define ELIB_HEAP_SIZE (64*1024) /* Default 64K */ +#endif + +#ifndef ELIB_HEAP_INCREAMENT +#define ELIB_HEAP_INCREAMENT (32*1024) /* Default 32K */ +#endif + +#ifndef ELIB_FAILURE +#define ELIB_FAILURE abort() +#endif + +#undef ASSERT +#ifdef DEBUG +#define ASSERT(B) \ + ((void) ((B) ? 1 : (fprintf(stderr, "%s:%d: Assertion failed: %s\n", \ + __FILE__, __LINE__, #B), abort(), 0))) +#else +#define ASSERT(B) ((void) 1) +#endif + +#ifndef USE_RECURSIVE_MALLOC_MUTEX +#define USE_RECURSIVE_MALLOC_MUTEX 0 +#endif + +#if USE_RECURSIVE_MALLOC_MUTEX +static erts_mtx_t malloc_mutex = ERTS_REC_MTX_INITER; +#else /* #if USE_RECURSIVE_MALLOC_MUTEX */ +static erts_mtx_t malloc_mutex = ERTS_MTX_INITER; +#if THREAD_SAFE_ELIB_MALLOC +static erts_cnd_t malloc_cond = ERTS_CND_INITER; +#endif +#endif /* #if USE_RECURSIVE_MALLOC_MUTEX */ + +typedef unsigned long EWord; /* Assume 32-bit in this implementation */ +typedef unsigned short EHalfWord; /* Assume 16-bit in this implementation */ +typedef unsigned char EByte; /* Assume 8-bit byte */ + + +#define elib_printf fprintf +#define elib_putc fputc + + +#if defined(__STDC__) || defined(__WIN32__) +#define CONCAT(x,y) x##y +#else +#define CONCAT(x,y) x/**/y +#endif + + +#ifdef ELIB_DEBUG +#define ELIB_PREFIX(fun, args) CONCAT(elib__,fun) args +#else +#define ELIB_PREFIX(fun, args) CONCAT(elib_,fun) args +#endif + +#if defined(__STDC__) +void *ELIB_PREFIX(malloc, (size_t)); +void *ELIB_PREFIX(calloc, (size_t, size_t)); +void ELIB_PREFIX(cfree, (EWord *)); +void ELIB_PREFIX(free, (EWord *)); +void *ELIB_PREFIX(realloc, (EWord *, size_t)); +void* ELIB_PREFIX(memresize, (EWord *, int)); +void* ELIB_PREFIX(memalign, (int, int)); +void* ELIB_PREFIX(valloc, (int)); +void* ELIB_PREFIX(pvalloc, (int)); +int ELIB_PREFIX(memsize, (EWord *)); +/* Extern interfaces used by VxWorks */ +size_t elib_sizeof(void *); +void elib_init(EWord *, EWord); +void elib_force_init(EWord *, EWord); +#endif + +#if defined(__STDC__) +/* define prototypes for missing */ +void* memalign(size_t a, size_t s); +void* pvalloc(size_t nb); +void* memresize(void *p, int nb); +int memsize(void *p); +#endif + +/* bytes to pages */ +#define PAGES(x) (((x)+page_size-1) / page_size) +#define PAGE_ALIGN(p) ((char*)((((EWord)(p))+page_size-1)&~(page_size-1))) + +/* bytes to words */ +#define WORDS(x) (((x)+sizeof(EWord)-1) / sizeof(EWord)) + +/* Align an address */ +#define ALIGN(p) ((EWord*)((((EWord)(p)+ELIB_ALIGN-1)&~(ELIB_ALIGN-1)))) + +/* Calculate the size needed to keep alignment */ + +#define ALIGN_BSZ(nb) ((nb+sizeof(EWord)+ELIB_ALIGN-1) & ~(ELIB_ALIGN-1)) + +#define ALIGN_WSZ(nb) WORDS(ALIGN_BSZ(nb)) + +#define ALIGN_SIZE(nb) (ALIGN_WSZ(nb) - 1) + + +/* PARAMETERS */ + +#if defined(ELIB_HEAP_SBRK) + +#undef PAGE_SIZE + +/* Get the system page size (NEED MORE DEFINES HERE) */ +#ifdef _SC_PAGESIZE +#define PAGE_SIZE sysconf(_SC_PAGESIZE) +#elif defined(_MSC_VER) +# ifdef _M_ALPHA +# define PAGE_SIZE 0x2000 +# else +# define PAGE_SIZE 0x1000 +# endif +#else +#define PAGE_SIZE getpagesize() +#endif + +#define ELIB_EXPAND(need) expand_sbrk(need) +static FUNCTION(int, expand_sbrk, (EWord)); + +#elif defined(ELIB_HEAP_FIXED) + +#define PAGE_SIZE 1024 +#define ELIB_EXPAND(need) -1 +static EWord fix_heap[WORDS(ELIB_HEAP_SIZE)]; + +#elif defined(ELIB_HEAP_USER) + +#define PAGE_SIZE 1024 +#define ELIB_EXPAND(need) -1 + +#else + +#error "ELIB HEAP TYPE NOT SET" + +#endif + + +#define STAT_ALLOCED_BLOCK(SZ) \ +do { \ + tot_allocated += (SZ); \ + if (max_allocated < tot_allocated) \ + max_allocated = tot_allocated; \ +} while (0) + +#define STAT_FREED_BLOCK(SZ) \ +do { \ + tot_allocated -= (SZ); \ +} while (0) + +static int max_allocated = 0; +static int tot_allocated = 0; +static EWord* eheap; /* Align heap start */ +static EWord* eheap_top; /* Point to end of heap */ +EWord page_size = 0; /* Set by elib_init */ + +#if defined(ELIB_DEBUG) || defined(DEBUG) +#define ALIGN_CHECK(a, p) \ + do { \ + if ((EWord)(p) & (a-1)) { \ + elib_printf(stderr, \ + "RUNTIME ERROR: bad alignment (0x%lx:%d:%d)\n", \ + (unsigned long) (p), (int) a, __LINE__); \ + ELIB_FAILURE; \ + } \ + } while(0) +#define ELIB_ALIGN_CHECK(p) ALIGN_CHECK(ELIB_ALIGN, p) +#else +#define ALIGN_CHECK(a, p) +#define ELIB_ALIGN_CHECK(p) +#endif + +#define DYNAMIC 32 + +/* +** Free block layout +** 1 1 30 +** +--------------------------+ +** |F|P| Size | +** +--------------------------+ +** +** Where F is the free bit +** P is the free above bit +** Size is messured in words and does not include the hdr word +** +** If block is on the free list the size is also stored last in the block. +** +*/ +typedef struct _free_block FreeBlock; +struct _free_block { + EWord hdr; + Uint flags; + FreeBlock* parent; + FreeBlock* left; + FreeBlock* right; + EWord v[1]; +}; + +typedef struct _allocated_block { + EWord hdr; + EWord v[5]; +} AllocatedBlock; + + +/* + * Interface to tree routines. + */ +typedef Uint Block_t; + +static Block_t* get_free_block(Uint); +static void link_free_block(Block_t *); +static void unlink_free_block(Block_t *del); + +#define FREE_BIT 0x80000000 +#define FREE_ABOVE_BIT 0x40000000 +#define SIZE_MASK 0x3fffffff /* 2^30 words = 2^32 bytes */ + +/* Work on both FreeBlock and AllocatedBlock */ +#define SIZEOF(p) ((p)->hdr & SIZE_MASK) +#define IS_FREE(p) (((p)->hdr & FREE_BIT) != 0) +#define IS_FREE_ABOVE(p) (((p)->hdr & FREE_ABOVE_BIT) != 0) + +/* Given that we have a free block above find its size */ +#define SIZEOF_ABOVE(p) *(((EWord*) (p)) - 1) + +#define MIN_BLOCK_SIZE (sizeof(FreeBlock)/sizeof(EWord)) +#define MIN_WORD_SIZE (MIN_BLOCK_SIZE-1) +#define MIN_BYTE_SIZE (sizeof(FreeBlock)-sizeof(EWord)) + +#define MIN_ALIGN_SIZE ALIGN_SIZE(MIN_BYTE_SIZE) + + +static AllocatedBlock* heap_head = 0; +static AllocatedBlock* heap_tail = 0; +static EWord eheap_size = 0; + +static int heap_locked; + +static int elib_need_init = 1; +#if THREAD_SAFE_ELIB_MALLOC +static int elib_is_initing = 0; +#endif + +typedef FreeBlock RBTree_t; + +static RBTree_t* root = NULL; + + +static FUNCTION(void, deallocate, (AllocatedBlock*, int)); + +/* + * Unlink a free block + */ + +#define mark_allocated(p, szp) do { \ + (p)->hdr = ((p)->hdr & FREE_ABOVE_BIT) | (szp); \ + (p)->v[szp] &= ~FREE_ABOVE_BIT; \ + } while(0) + +#define mark_free(p, szp) do { \ + (p)->hdr = FREE_BIT | (szp); \ + ((FreeBlock *)p)->v[szp-sizeof(FreeBlock)/sizeof(EWord)+1] = (szp); \ + } while(0) + +#if 0 +/* Help macros to log2 */ +#define LOG_1(x) (((x) > 1) ? 1 : 0) +#define LOG_2(x) (((x) > 3) ? 2+LOG_1((x) >> 2) : LOG_1(x)) +#define LOG_4(x) (((x) > 15) ? 4+LOG_2((x) >> 4) : LOG_2(x)) +#define LOG_8(x) (((x) > 255) ? 8+LOG_4((x)>>8) : LOG_4(x)) +#define LOG_16(x) (((x) > 65535) ? 16+LOG_8((x)>>16) : LOG_8(x)) + +#define log2(x) LOG_16(x) +#endif + +/* + * Split a block to be allocated. + * Mark block as ALLOCATED and clear + * FREE_ABOVE_BIT on next block + * + * nw is SIZE aligned and szp is SIZE aligned + 1 + */ +static void +split_block(FreeBlock* p, EWord nw, EWord szp) +{ + EWord szq; + FreeBlock* q; + + szq = szp - nw; + /* Preserve FREE_ABOVE bit in p->hdr !!! */ + + if (szq >= MIN_ALIGN_SIZE+1) { + szq--; + p->hdr = (p->hdr & FREE_ABOVE_BIT) | nw; + + q = (FreeBlock*) (((EWord*) p) + nw + 1); + mark_free(q, szq); + link_free_block((Block_t *) q); + + q = (FreeBlock*) (((EWord*) q) + szq + 1); + q->hdr |= FREE_ABOVE_BIT; + } + else { + mark_allocated((AllocatedBlock*)p, szp); + } +} + +/* + * Find a free block + */ +static FreeBlock* +alloc_block(EWord nw) +{ + for (;;) { + FreeBlock* p = (FreeBlock *) get_free_block(nw); + + if (p != NULL) { + return p; + } else if (ELIB_EXPAND(nw+MIN_WORD_SIZE)) { + return 0; + } + } +} + + +size_t elib_sizeof(void *p) +{ + AllocatedBlock* pp; + + if (p != 0) { + pp = (AllocatedBlock*) (((char *)p)-1); + return SIZEOF(pp); + } + return 0; +} + +static void locked_elib_init(EWord*, EWord); +static void init_elib_malloc(EWord*, EWord); + +/* +** Initialize the elib +** The addr and sz is only used when compiled with EXPAND_ADDR +*/ +/* Not static, this is used by VxWorks */ +void elib_init(EWord* addr, EWord sz) +{ + if (!elib_need_init) + return; + erts_mtx_lock(&malloc_mutex); + locked_elib_init(addr, sz); + erts_mtx_unlock(&malloc_mutex); +} + +static void locked_elib_init(EWord* addr, EWord sz) +{ + if (!elib_need_init) + return; + +#if THREAD_SAFE_ELIB_MALLOC + +#if !USE_RECURSIVE_MALLOC_MUTEX + { + static erts_tid_t initer_tid; + + if(elib_is_initing) { + + if(erts_equal_tids(initer_tid, erts_thr_self())) + return; + + /* Wait until initializing thread is done with initialization */ + + while(elib_need_init) + erts_cnd_wait(&malloc_cond, &malloc_mutex); + + return; + } + else { + initer_tid = erts_thr_self(); + elib_is_initing = 1; + } + } +#else + if(elib_is_initing) + return; + elib_is_initing = 1; +#endif + +#endif /* #if THREAD_SAFE_ELIB_MALLOC */ + + /* Do the actual initialization of the malloc implementation */ + init_elib_malloc(addr, sz); + +#if THREAD_SAFE_ELIB_MALLOC + +#if !USE_RECURSIVE_MALLOC_MUTEX + erts_mtx_unlock(&malloc_mutex); +#endif + + /* Recursive calls to malloc are allowed here... */ + erts_mtx_set_forksafe(&malloc_mutex); + +#if !USE_RECURSIVE_MALLOC_MUTEX + erts_mtx_lock(&malloc_mutex); + elib_is_initing = 0; +#endif + +#endif /* #if THREAD_SAFE_ELIB_MALLOC */ + + elib_need_init = 0; + +#if THREAD_SAFE_ELIB_MALLOC && !USE_RECURSIVE_MALLOC_MUTEX + erts_cnd_broadcast(&malloc_cond); +#endif + +} + +static void init_elib_malloc(EWord* addr, EWord sz) +{ + int i; + FreeBlock* freep; + EWord tmp_sz; +#ifdef ELIB_HEAP_SBRK + char* top; + EWord n; +#endif + + max_allocated = 0; + tot_allocated = 0; + root = NULL; + + /* Get the page size (may involve system call!!!) */ + page_size = PAGE_SIZE; + +#if defined(ELIB_HEAP_SBRK) + sz = PAGES(ELIB_HEAP_SIZE)*page_size; + + if ((top = (char*) sbrk(0)) == (char*)-1) { + elib_printf(stderr, "could not initialize elib, sbrk(0)"); + ELIB_FAILURE; + } + n = PAGE_ALIGN(top) - top; + if ((top = (char*) sbrk(n)) == (char*)-1) { + elib_printf(stderr, "could not initialize elib, sbrk(n)"); + ELIB_FAILURE; + } + if ((eheap = (EWord*) sbrk(sz)) == (EWord*)-1) { + elib_printf(stderr, "could not initialize elib, sbrk(SIZE)"); + ELIB_FAILURE; + } + sz = WORDS(ELIB_HEAP_SIZE); +#elif defined(ELIB_HEAP_FIXED) + eheap = fix_heap; + sz = WORDS(ELIB_HEAP_SIZE); +#elif defined(ELIB_HEAP_USER) + eheap = addr; + sz = WORDS(sz); +#else + return -1; +#endif + eheap_size = 0; + + /* Make sure that the first word of the heap_head is aligned */ + addr = ALIGN(eheap+1); + sz -= ((addr - 1) - eheap); /* Subtract unusable size */ + eheap_top = eheap = addr - 1; /* Set new aligned heap start */ + + eheap_top[sz-1] = 0; /* Heap stop mark */ + + addr = eheap; + heap_head = (AllocatedBlock*) addr; + heap_head->hdr = MIN_ALIGN_SIZE; + for (i = 0; i < MIN_ALIGN_SIZE; i++) + heap_head->v[i] = 0; + + addr += (MIN_ALIGN_SIZE+1); + freep = (FreeBlock*) addr; + tmp_sz = sz - (((MIN_ALIGN_SIZE+1) + MIN_BLOCK_SIZE) + 1 + 1); + mark_free(freep, tmp_sz); + link_free_block((Block_t *) freep); + + /* No need to align heap tail */ + heap_tail = (AllocatedBlock*) &eheap_top[sz-MIN_BLOCK_SIZE-1]; + heap_tail->hdr = FREE_ABOVE_BIT | MIN_WORD_SIZE; + heap_tail->v[0] = 0; + heap_tail->v[1] = 0; + heap_tail->v[2] = 0; + + eheap_top += sz; + eheap_size += sz; + + heap_locked = 0; +} + +#ifdef ELIB_HEAP_USER +void elib_force_init(EWord* addr, EWord sz) +{ + elib_need_init = 1; + elib_init(addr,sz); +} +#endif + +#ifdef ELIB_HEAP_SBRK + +/* +** need in number of words (should include head and tail words) +*/ +static int expand_sbrk(EWord sz) +{ + EWord* p; + EWord bytes = sz * sizeof(EWord); + EWord size; + AllocatedBlock* tail; + + if (bytes < ELIB_HEAP_SIZE) + size = PAGES(ELIB_HEAP_INCREAMENT)*page_size; + else + size = PAGES(bytes)*page_size; + + if ((p = (EWord*) sbrk(size)) == ((EWord*) -1)) + return -1; + + if (p != eheap_top) { + elib_printf(stderr, "panic: sbrk moved\n"); + ELIB_FAILURE; + } + + sz = WORDS(size); + + /* Set new endof heap marker and a new heap tail */ + eheap_top[sz-1] = 0; + + tail = (AllocatedBlock*) &eheap_top[sz-MIN_BLOCK_SIZE-1]; + tail->hdr = FREE_ABOVE_BIT | MIN_WORD_SIZE; + tail->v[0] = 0; + tail->v[1] = 0; + tail->v[2] = 0; + + /* Patch old tail with new appended size */ + heap_tail->hdr = (heap_tail->hdr & FREE_ABOVE_BIT) | + (MIN_WORD_SIZE+1+(sz-MIN_BLOCK_SIZE-1)); + deallocate(heap_tail, 0); + + heap_tail = tail; + + eheap_size += sz; + eheap_top += sz; + + return 0; +} + +#endif /* ELIB_HEAP_SBRK */ + + +/* +** Scan heap and check for corrupted heap +*/ +int elib_check_heap(void) +{ + AllocatedBlock* p = heap_head; + EWord sz; + + if (heap_locked) { + elib_printf(stderr, "heap is locked no info avaiable\n"); + return 0; + } + + while((sz = SIZEOF(p)) != 0) { + if (IS_FREE(p)) { + if (p->v[sz-1] != sz) { + elib_printf(stderr, "panic: heap corrupted\r\n"); + ELIB_FAILURE; + } + p = (AllocatedBlock*) (p->v + sz); + if (!IS_FREE_ABOVE(p)) { + elib_printf(stderr, "panic: heap corrupted\r\n"); + ELIB_FAILURE; + } + } + else + p = (AllocatedBlock*) (p->v + sz); + } + return 1; +} + +/* +** Load the byte vector pointed to by v of length vsz +** with a heap image +** The scale is defined by vsz and the current heap size +** free = 0, full = 255 +** +** +*/ +int elib_heap_map(EByte* v, int vsz) +{ + AllocatedBlock* p = heap_head; + EWord sz; + int gsz = eheap_size / vsz; /* The granuality used */ + int fsz = 0; + int usz = 0; + + if (gsz == 0) + return -1; /* too good reolution */ + + while((sz = SIZEOF(p)) != 0) { + if (IS_FREE(p)) { + fsz += sz; + if ((fsz + usz) > gsz) { + *v++ = (255*usz)/gsz; + fsz -= (gsz - usz); + usz = 0; + while(fsz >= gsz) { + *v++ = 0; + fsz -= gsz; + } + } + } + else { + usz += sz; + if ((fsz + usz) > gsz) { + *v++ = 255 - (255*fsz)/gsz; + usz -= (gsz - fsz); + fsz = 0; + while(usz >= gsz) { + *v++ = 255; + usz -= gsz; + } + } + } + p = (AllocatedBlock*) (p->v + sz); + } + return 0; +} + +/* +** Generate a histogram of free/allocated blocks +** Count granuality of 10 gives +** (0-10],(10-100],(100-1000],(1000-10000] ... +** (0-2], (2-4], (4-8], (8-16], .... +*/ +static int i_logb(EWord size, int base) +{ + int lg = 0; + while(size >= base) { + size /= base; + lg++; + } + return lg; +} + +int elib_histo(EWord* vf, EWord* va, int vsz, int base) +{ + AllocatedBlock* p = heap_head; + EWord sz; + int i; + int linear; + + if ((vsz <= 1) || (vf == 0 && va == 0)) + return -1; + + if (base < 0) { + linear = 1; + base = -base; + } + else + linear = 0; + + if (base <= 1) + return -1; + + if (vf != 0) { + for (i = 0; i < vsz; i++) + vf[i] = 0; + } + if (va != 0) { + for (i = 0; i < vsz; i++) + va[i] = 0; + } + + while((sz = SIZEOF(p)) != 0) { + if (IS_FREE(p)) { + if (vf != 0) { + int val; + if (linear) + val = sz / base; + else + val = i_logb(sz, base); + if (val >= vsz) + vf[vsz-1]++; + else + vf[val]++; + } + } + else { + if (va != 0) { + int val; + if (linear) + val = sz / base; + else + val = i_logb(sz, base); + if (val >= vsz) + va[vsz-1]++; + else + va[val]++; + } + } + p = (AllocatedBlock*) (p->v + sz); + } + return 0; +} + +/* +** Fill the info structure with actual values +** Total +** Allocated +** Free +** maxMaxFree +*/ +void elib_stat(struct elib_stat* info) +{ + EWord blks = 0; + EWord sz_free = 0; + EWord sz_alloc = 0; + EWord sz_max_free = 0; + EWord sz_min_used = 0x7fffffff; + EWord sz; + EWord num_free = 0; + AllocatedBlock* p = heap_head; + + info->mem_total = eheap_size; + + p = (AllocatedBlock*) (p->v + SIZEOF(p)); + + while((sz = SIZEOF(p)) != 0) { + blks++; + if (IS_FREE(p)) { + if (sz > sz_max_free) + sz_max_free = sz; + sz_free += sz; + ++num_free; + } + else { + if (sz < sz_min_used) + sz_min_used = sz; + sz_alloc += sz; + } + p = (AllocatedBlock*) (p->v + sz); + } + info->mem_blocks = blks; + info->free_blocks = num_free; + info->mem_alloc = sz_alloc; + info->mem_free = sz_free; + info->min_used = sz_min_used; + info->max_free = sz_max_free; + info->mem_max_alloc = max_allocated; + ASSERT(sz_alloc == tot_allocated); +} + +/* +** Dump the heap +*/ +void elib_heap_dump(char* label) +{ + AllocatedBlock* p = heap_head; + EWord sz; + + elib_printf(stderr, "HEAP DUMP (%s)\n", label); + if (!elib_check_heap()) + return; + + while((sz = SIZEOF(p)) != 0) { + if (IS_FREE(p)) { + elib_printf(stderr, "%p: FREE, size = %d\n", p, (int) sz); + } + else { + elib_printf(stderr, "%p: USED, size = %d %s\n", p, (int) sz, + IS_FREE_ABOVE(p)?"(FREE ABOVE)":""); + } + p = (AllocatedBlock*) (p->v + sz); + } +} + +/* +** Scan heaps and count: +** free_size, allocated_size, max_free_block +*/ +void elib_statistics(void* to) +{ + struct elib_stat info; + EWord frag; + + if (!elib_check_heap()) + return; + + elib_stat(&info); + + frag = 1000 - ((1000 * info.max_free) / info.mem_free); + + elib_printf(to, "Heap Statistics: total(%d), blocks(%d), frag(%d.%d%%)\n", + info.mem_total, info.mem_blocks, + (int) frag/10, (int) frag % 10); + + elib_printf(to, " allocated(%d), free(%d), " + "free_blocks(%d)\n", + info.mem_alloc, info.mem_free,info.free_blocks); + elib_printf(to, " max_free(%d), min_used(%d)\n", + info.max_free, info.min_used); +} + +/* +** Allocate a least nb bytes with alignment a +** Algorithm: +** 1) Try locate a block which match exacly among the by direct index. +** 2) Try using a fix block of greater size +** 3) Try locate a block by searching in lists where block sizes +** X may vary between 2^i < X <= 2^(i+1) +** +** Reset memory to zero if clear is true +*/ +static AllocatedBlock* allocate(EWord nb, EWord a, int clear) +{ + FreeBlock* p; + EWord nw; + + if (a == ELIB_ALIGN) { + /* + * Common case: Called by malloc(), realloc(), calloc(). + */ + nw = nb < MIN_BYTE_SIZE ? MIN_ALIGN_SIZE : ALIGN_SIZE(nb); + + if ((p = alloc_block(nw)) == 0) + return NULL; + } else { + /* + * Special case: Called by memalign(). + */ + EWord asz, szp, szq, tmpsz; + FreeBlock *q; + + if ((p = alloc_block((1+MIN_ALIGN_SIZE)*sizeof(EWord)+a-1+nb)) == 0) + return NULL; + + asz = a - ((EWord) ((AllocatedBlock *)p)->v) % a; + + if (asz != a) { + /* Enforce the alignment requirement by cutting of a free + block at the beginning of the block. */ + + if (asz < (1+MIN_ALIGN_SIZE)*sizeof(EWord) && !IS_FREE_ABOVE(p)) { + /* Not enough room to cut of a free block; + increase align size */ + asz += (((1+MIN_ALIGN_SIZE)*sizeof(EWord) + a - 1)/a)*a; + } + + szq = ALIGN_SIZE(asz - sizeof(EWord)); + szp = SIZEOF(p) - szq - 1; + + q = p; + p = (FreeBlock*) (((EWord*) q) + szq + 1); + p->hdr = FREE_ABOVE_BIT | FREE_BIT | szp; + + if (IS_FREE_ABOVE(q)) { /* This should not be possible I think, + but just in case... */ + tmpsz = SIZEOF_ABOVE(q) + 1; + szq += tmpsz; + q = (FreeBlock*) (((EWord*) q) - tmpsz); + unlink_free_block((Block_t *) q); + q->hdr = (q->hdr & FREE_ABOVE_BIT) | FREE_BIT | szq; + } + mark_free(q, szq); + link_free_block((Block_t *) q); + + } /* else already had the correct alignment */ + + nw = nb < MIN_BYTE_SIZE ? MIN_ALIGN_SIZE : ALIGN_SIZE(nb); + } + + split_block(p, nw, SIZEOF(p)); + + STAT_ALLOCED_BLOCK(SIZEOF(p)); + + if (clear) { + EWord* pp = ((AllocatedBlock*)p)->v; + + while(nw--) + *pp++ = 0; + } + + return (AllocatedBlock*) p; +} + + +/* +** Deallocate memory pointed to by p +** 1. Merge with block above if this block is free +** 2. Merge with block below if this block is free +** Link the block to the correct free list +** +** p points to the block header! +** +*/ +static void deallocate(AllocatedBlock* p, int stat_count) +{ + FreeBlock* q; + EWord szq; + EWord szp; + + szp = SIZEOF(p); + + if (stat_count) + STAT_FREED_BLOCK(SIZEOF(p)); + + if (IS_FREE_ABOVE(p)) { + szq = SIZEOF_ABOVE(p); + q = (FreeBlock*) ( ((EWord*) p) - szq - 1); + unlink_free_block((Block_t *) q); + + p = (AllocatedBlock*) q; + szp += (szq + 1); + } + q = (FreeBlock*) (p->v + szp); + if (IS_FREE(q)) { + szq = SIZEOF(q); + unlink_free_block((Block_t *) q); + szp += (szq + 1); + } + else + q->hdr |= FREE_ABOVE_BIT; + + /* The block above p can NEVER be free !!! */ + p->hdr = FREE_BIT | szp; + p->v[szp-1] = szp; + + link_free_block((Block_t *) p); +} + +/* +** Reallocate memory +** If preserve is true then data is moved if neccesary +*/ +static AllocatedBlock* reallocate(AllocatedBlock* p, EWord nb, int preserve) +{ + EWord szp; + EWord szq; + EWord sz; + EWord nw; + FreeBlock* q; + + if (nb < MIN_BYTE_SIZE) + nw = MIN_ALIGN_SIZE; + else + nw = ALIGN_SIZE(nb); + + sz = szp = SIZEOF(p); + + STAT_FREED_BLOCK(szp); + + /* Merge with block below */ + q = (FreeBlock*) (p->v + szp); + if (IS_FREE(q)) { + szq = SIZEOF(q); + unlink_free_block((Block_t *) q); + szp += (szq + 1); + } + + if (nw <= szp) { + split_block((FreeBlock *) p, nw, szp); + STAT_ALLOCED_BLOCK(SIZEOF(p)); + return p; + } + else { + EWord* dp = p->v; + AllocatedBlock* npp; + + if (IS_FREE_ABOVE(p)) { + szq = SIZEOF_ABOVE(p); + if (szq + szp + 1 >= nw) { + q = (FreeBlock*) (((EWord*) p) - szq - 1); + unlink_free_block((Block_t * )q); + szp += (szq + 1); + p = (AllocatedBlock*) q; + + if (preserve) { + EWord* pp = p->v; + while(sz--) + *pp++ = *dp++; + } + split_block((FreeBlock *) p, nw, szp); + STAT_ALLOCED_BLOCK(SIZEOF(p)); + return p; + } + } + + /* + * Update p so that allocate() and deallocate() works. + * (Note that allocate() may call expand_sbrk(), which in + * in turn calls deallocate().) + */ + + p->hdr = (p->hdr & FREE_ABOVE_BIT) | szp; + p->v[szp] &= ~FREE_ABOVE_BIT; + + npp = allocate(nb, ELIB_ALIGN, 0); + if(npp == NULL) + return NULL; + if (preserve) { + EWord* pp = npp->v; + while(sz--) + *pp++ = *dp++; + } + deallocate(p, 0); + return npp; + } +} + +/* +** What malloc() and friends should do (and return) when the heap is +** exhausted. [sverkerw] +*/ +static void* heap_exhausted(void) +{ + /* Choose behaviour */ +#if 0 + /* Crash-and-burn --- leave a usable corpse (hopefully) */ + abort(); +#endif + /* The usual ANSI-compliant behaviour */ + return NULL; +} + +/* +** Allocate size bytes of memory +*/ +void* ELIB_PREFIX(malloc, (size_t nb)) +{ + void *res; + AllocatedBlock* p; + + erts_mtx_lock(&malloc_mutex); + if (elib_need_init) + locked_elib_init(NULL,(EWord)0); + + if (nb == 0) + res = NULL; + else if ((p = allocate(nb, ELIB_ALIGN, 0)) != 0) { + ELIB_ALIGN_CHECK(p->v); + res = p->v; + } + else + res = heap_exhausted(); + + erts_mtx_unlock(&malloc_mutex); + + return res; +} + + +void* ELIB_PREFIX(calloc, (size_t nelem, size_t size)) +{ + void *res; + int nb; + AllocatedBlock* p; + + erts_mtx_lock(&malloc_mutex); + if (elib_need_init) + locked_elib_init(NULL,(EWord)0); + + if ((nb = nelem * size) == 0) + res = NULL; + else if ((p = allocate(nb, ELIB_ALIGN, 1)) != 0) { + ELIB_ALIGN_CHECK(p->v); + res = p->v; + } + else + res = heap_exhausted(); + + erts_mtx_unlock(&malloc_mutex); + + return res; +} + +/* +** Free memory allocated by malloc +*/ + +void ELIB_PREFIX(free, (EWord* p)) +{ + erts_mtx_lock(&malloc_mutex); + if (elib_need_init) + locked_elib_init(NULL,(EWord)0); + + if (p != 0) + deallocate((AllocatedBlock*)(p-1), 1); + + erts_mtx_unlock(&malloc_mutex); +} + +void ELIB_PREFIX(cfree, (EWord* p)) +{ + ELIB_PREFIX(free, (p)); +} + + +/* +** Realloc the memory allocated in p to nb number of bytes +** +*/ + +void* ELIB_PREFIX(realloc, (EWord* p, size_t nb)) +{ + void *res = NULL; + AllocatedBlock* pp; + + erts_mtx_lock(&malloc_mutex); + if (elib_need_init) + locked_elib_init(NULL,(EWord)0); + + if (p != 0) { + pp = (AllocatedBlock*) (p-1); + if (nb > 0) { + if ((pp = reallocate(pp, nb, 1)) != 0) { + ELIB_ALIGN_CHECK(pp->v); + res = pp->v; + } + } + else + deallocate(pp, 1); + } + else if (nb > 0) { + if ((pp = allocate(nb, ELIB_ALIGN, 0)) != 0) { + ELIB_ALIGN_CHECK(pp->v); + res = pp->v; + } + else + res = heap_exhausted(); + } + + erts_mtx_unlock(&malloc_mutex); + + return res; +} + +/* +** Resize the memory area pointed to by p with nb number of bytes +*/ +void* ELIB_PREFIX(memresize, (EWord* p, int nb)) +{ + void *res = NULL; + AllocatedBlock* pp; + + erts_mtx_lock(&malloc_mutex); + if (elib_need_init) + locked_elib_init(NULL,(EWord)0); + + if (p != 0) { + pp = (AllocatedBlock*) (p-1); + if (nb > 0) { + if ((pp = reallocate(pp, nb, 0)) != 0) { + ELIB_ALIGN_CHECK(pp->v); + res = pp->v; + } + } + else + deallocate(pp, 1); + } + else if (nb > 0) { + if ((pp = allocate(nb, ELIB_ALIGN, 0)) != 0) { + ELIB_ALIGN_CHECK(pp->v); + res = pp->v; + } + else + res = heap_exhausted(); + } + + erts_mtx_unlock(&malloc_mutex); + + return res; +} + + +/* Create aligned memory a must be a power of 2 !!! */ + +void* ELIB_PREFIX(memalign, (int a, int nb)) +{ + void *res; + AllocatedBlock* p; + + erts_mtx_lock(&malloc_mutex); + if (elib_need_init) + locked_elib_init(NULL,(EWord)0); + + if (nb == 0 || a <= 0) + res = NULL; + else if ((p = allocate(nb, a, 0)) != 0) { + ALIGN_CHECK(a, p->v); + res = p->v; + } + else + res = heap_exhausted(); + + erts_mtx_unlock(&malloc_mutex); + + return res; +} + +void* ELIB_PREFIX(valloc, (int nb)) +{ + return ELIB_PREFIX(memalign, (page_size, nb)); +} + + +void* ELIB_PREFIX(pvalloc, (int nb)) +{ + return ELIB_PREFIX(memalign, (page_size, PAGES(nb)*page_size)); +} +/* Return memory size for pointer p in bytes */ + +int ELIB_PREFIX(memsize, (p)) +EWord* p; +{ + return SIZEOF((AllocatedBlock*)(p-1))*4; +} + + +/* +** -------------------------------------------------------------------------- +** DEBUG LIBRARY +** -------------------------------------------------------------------------- +*/ + +#ifdef ELIB_DEBUG + +#define IN_HEAP(p) (((p) >= (char*) eheap) && (p) < (char*) eheap_top) +/* +** ptr_to_block: return the pointer to heap block pointed into by ptr +** Returns 0 if not pointing into a block +*/ + +static EWord* ptr_to_block(char* ptr) +{ + AllocatedBlock* p = heap_head; + EWord sz; + + while((sz = SIZEOF(p)) != 0) { + if ((ptr >= (char*) p->v) && (ptr < (char*)(p->v+sz))) + return p->v; + p = (AllocatedBlock*) (p->v + sz); + } + return 0; +} + +/* +** Validate a pointer +** returns: +** 0 - if points to start of a block +** 1 - if points outsize heap +** -1 - if points inside block +** +*/ +static int check_pointer(char* ptr) +{ + if (IN_HEAP(ptr)) { + if (ptr_to_block(ptr) == 0) + return 1; + return 0; + } + return -1; +} + +/* +** Validate a memory area +** returns: +** 0 - if area is included in a block +** -1 - if area overlap a heap block +** 1 - if area is outside heap +*/ +static int check_area(char* ptr, int n) +{ + if (IN_HEAP(ptr)) { + if (IN_HEAP(ptr+n-1)) { + EWord* p1 = ptr_to_block(ptr); + EWord* p2 = ptr_to_block(ptr+n-1); + + if (p1 == p2) + return (p1 == 0) ? -1 : 0; + return -1; + } + } + else if (IN_HEAP(ptr+n-1)) + return -1; + return 1; +} + +/* +** Check if a block write will overwrite heap block +*/ +static void check_write(char* ptr, int n, char* file, int line, char* fun) +{ + if (check_area(ptr, n) == -1) { + elib_printf(stderr, "RUNTIME ERROR: %s heap overwrite\n", fun); + elib_printf(stderr, "File: %s Line: %d\n", file, line); + ELIB_FAILURE; + } +} + +/* +** Check if a pointer is an allocated object +*/ +static void check_allocated_block(char* ptr, char* file, int line, char* fun) +{ + EWord* q; + + if (!IN_HEAP(ptr) || ((q=ptr_to_block(ptr)) == 0) || (ptr != (char*) q)) { + elib_printf(stderr, "RUNTIME ERROR: %s non heap pointer\n", fun); + elib_printf(stderr, "File: %s Line: %d\n", file, line); + ELIB_FAILURE; + } + + if (IS_FREE((AllocatedBlock*)(q-1))) { + elib_printf(stderr, "RUNTIME ERROR: %s free pointer\n", fun); + elib_printf(stderr, "File: %s Line: %d\n", file, line); + ELIB_FAILURE; + } + +} + +/* +** -------------------------------------------------------------------------- +** DEBUG VERSIONS (COMPILED WITH THE ELIB.H) +** -------------------------------------------------------------------------- +*/ + +void* elib_dbg_malloc(int n, char* file, int line) +{ + return elib__malloc(n); +} + +void* elib_dbg_calloc(int n, int s, char* file, int line) +{ + return elib__calloc(n, s); +} + +void* elib_dbg_realloc(EWord* p, int n, char* file, int line) +{ + if (p == 0) + return elib__malloc(n); + check_allocated_block(p, file, line, "elib_realloc"); + return elib__realloc(p, n); +} + +void elib_dbg_free(EWord* p, char* file, int line) +{ + if (p == 0) + return; + check_allocated_block(p, file, line, "elib_free"); + elib__free(p); +} + +void elib_dbg_cfree(EWord* p, char* file, int line) +{ + if (p == 0) + return; + check_allocated_block(p, file, line, "elib_free"); + elib__cfree(p); +} + +void* elib_dbg_memalign(int a, int n, char* file, int line) +{ + return elib__memalign(a, n); +} + +void* elib_dbg_valloc(int n, char* file, int line) +{ + return elib__valloc(n); +} + +void* elib_dbg_pvalloc(int n, char* file, int line) +{ + return elib__pvalloc(n); +} + +void* elib_dbg_memresize(EWord* p, int n, char* file, int line) +{ + if (p == 0) + return elib__malloc(n); + check_allocated_block(p, file, line, "elib_memresize"); + return elib__memresize(p, n); +} + +int elib_dbg_memsize(void* p, char* file, int line) +{ + check_allocated_block(p, file, line, "elib_memsize"); + return elib__memsize(p); +} + +/* +** -------------------------------------------------------------------------- +** LINK TIME FUNCTIONS (NOT COMPILED CALLS) +** -------------------------------------------------------------------------- +*/ + +void* elib_malloc(int n) +{ + return elib_dbg_malloc(n, "", -1); +} + +void* elib_calloc(int n, int s) +{ + return elib_dbg_calloc(n, s, "", -1); +} + +void* elib_realloc(EWord* p, int n) +{ + return elib_dbg_realloc(p, n, "", -1); +} + +void elib_free(EWord* p) +{ + elib_dbg_free(p, "", -1); +} + +void elib_cfree(EWord* p) +{ + elib_dbg_cfree(p, "", -1); +} + +void* elib_memalign(int a, int n) +{ + return elib_dbg_memalign(a, n, "", -1); +} + +void* elib_valloc(int n) +{ + return elib_dbg_valloc(n, "", -1); +} + +void* elib_pvalloc(int n) +{ + return elib_dbg_pvalloc(n, "", -1); +} + +void* elib_memresize(EWord* p, int n) +{ + return elib_dbg_memresize(p, n, "", -1); +} + + +int elib_memsize(EWord* p) +{ + return elib_dbg_memsize(p, "", -1); +} + +#endif /* ELIB_DEBUG */ + +/* +** -------------------------------------------------------------------------- +** Map c library functions to elib +** -------------------------------------------------------------------------- +*/ + +#if defined(ELIB_ALLOC_IS_CLIB) +void* malloc(size_t nb) +{ + return elib_malloc(nb); +} + +void* calloc(size_t nelem, size_t size) +{ + return elib_calloc(nelem, size); +} + + +void free(void *p) +{ + elib_free(p); +} + +void cfree(void *p) +{ + elib_cfree(p); +} + +void* realloc(void* p, size_t nb) +{ + return elib_realloc(p, nb); +} + + +void* memalign(size_t a, size_t s) +{ + return elib_memalign(a, s); +} + +void* valloc(size_t nb) +{ + return elib_valloc(nb); +} + +void* pvalloc(size_t nb) +{ + return elib_pvalloc(nb); +} + +#if 0 +void* memresize(void* p, int nb) +{ + return elib_memresize(p, nb); +} + +int memsize(void* p) +{ + return elib_memsize(p); +} +#endif +#endif /* ELIB_ALLOC_IS_CLIB */ + +#endif /* ENABLE_ELIB_MALLOC */ + +void elib_ensure_initialized(void) +{ +#ifdef ENABLE_ELIB_MALLOC +#ifndef ELIB_DONT_INITIALIZE + elib_init(NULL, 0); +#endif +#endif +} + +#ifdef ENABLE_ELIB_MALLOC +/** + ** A Slightly modified version of the "address order best fit" algorithm + ** used in erl_bestfit_alloc.c. Comments refer to that implementation. + **/ + +/* + * Description: A combined "address order best fit"/"best fit" allocator + * based on a Red-Black (binary search) Tree. The search, + * insert, and delete operations are all O(log n) operations + * on a Red-Black Tree. In the "address order best fit" case + * n equals number of free blocks, and in the "best fit" case + * n equals number of distinct sizes of free blocks. Red-Black + * Trees are described in "Introduction to Algorithms", by + * Thomas H. Cormen, Charles E. Leiserson, and + * Ronald L. Riverest. + * + * This module is a callback-module for erl_alloc_util.c + * + * Author: Rickard Green + */ + +#ifdef DEBUG +#if 0 +#define HARD_DEBUG +#endif +#else +#undef HARD_DEBUG +#endif + +#define SZ_MASK SIZE_MASK +#define FLG_MASK (~(SZ_MASK)) + +#define BLK_SZ(B) (*((Block_t *) (B)) & SZ_MASK) + +#define TREE_NODE_FLG (((Uint) 1) << 0) +#define RED_FLG (((Uint) 1) << 1) +#ifdef HARD_DEBUG +# define LEFT_VISITED_FLG (((Uint) 1) << 2) +# define RIGHT_VISITED_FLG (((Uint) 1) << 3) +#endif + +#define IS_TREE_NODE(N) (((RBTree_t *) (N))->flags & TREE_NODE_FLG) +#define IS_LIST_ELEM(N) (!IS_TREE_NODE(((RBTree_t *) (N)))) + +#define SET_TREE_NODE(N) (((RBTree_t *) (N))->flags |= TREE_NODE_FLG) +#define SET_LIST_ELEM(N) (((RBTree_t *) (N))->flags &= ~TREE_NODE_FLG) + +#define IS_RED(N) (((RBTree_t *) (N)) \ + && ((RBTree_t *) (N))->flags & RED_FLG) +#define IS_BLACK(N) (!IS_RED(((RBTree_t *) (N)))) + +#define SET_RED(N) (((RBTree_t *) (N))->flags |= RED_FLG) +#define SET_BLACK(N) (((RBTree_t *) (N))->flags &= ~RED_FLG) + +#undef ASSERT +#define ASSERT ASSERT_EXPR + +#if 1 +#define RBT_ASSERT ASSERT +#else +#define RBT_ASSERT(x) +#endif + + +#ifdef HARD_DEBUG +static RBTree_t * check_tree(Uint); +#endif + +#ifdef ERTS_INLINE +# ifndef ERTS_CAN_INLINE +# define ERTS_CAN_INLINE 1 +# endif +#else +# if defined(__GNUC__) +# define ERTS_CAN_INLINE 1 +# define ERTS_INLINE __inline__ +# elif defined(__WIN32__) +# define ERTS_CAN_INLINE 1 +# define ERTS_INLINE __inline +# else +# define ERTS_CAN_INLINE 0 +# define ERTS_INLINE +# endif +#endif + +/* Types... */ +#if 0 +typedef struct RBTree_t_ RBTree_t; + +struct RBTree_t_ { + Block_t hdr; + Uint flags; + RBTree_t *parent; + RBTree_t *left; + RBTree_t *right; +}; +#endif + +#if 0 +typedef struct { + RBTree_t t; + RBTree_t *next; +} RBTreeList_t; + +#define LIST_NEXT(N) (((RBTreeList_t *) (N))->next) +#define LIST_PREV(N) (((RBTreeList_t *) (N))->t.parent) +#endif + +#ifdef DEBUG + +/* Destroy all tree fields */ +#define DESTROY_TREE_NODE(N) \ + sys_memset((void *) (((Block_t *) (N)) + 1), \ + 0xff, \ + (sizeof(RBTree_t) - sizeof(Block_t))) + +/* Destroy all tree and list fields */ +#define DESTROY_LIST_ELEM(N) \ + sys_memset((void *) (((Block_t *) (N)) + 1), \ + 0xff, \ + (sizeof(RBTreeList_t) - sizeof(Block_t))) + +#else + +#define DESTROY_TREE_NODE(N) +#define DESTROY_LIST_ELEM(N) + +#endif + + +/* + * Red-Black Tree operations needed + */ + +static ERTS_INLINE void +left_rotate(RBTree_t **root, RBTree_t *x) +{ + RBTree_t *y = x->right; + x->right = y->left; + if (y->left) + y->left->parent = x; + y->parent = x->parent; + if (!y->parent) { + RBT_ASSERT(*root == x); + *root = y; + } + else if (x == x->parent->left) + x->parent->left = y; + else { + RBT_ASSERT(x == x->parent->right); + x->parent->right = y; + } + y->left = x; + x->parent = y; +} + +static ERTS_INLINE void +right_rotate(RBTree_t **root, RBTree_t *x) +{ + RBTree_t *y = x->left; + x->left = y->right; + if (y->right) + y->right->parent = x; + y->parent = x->parent; + if (!y->parent) { + RBT_ASSERT(*root == x); + *root = y; + } + else if (x == x->parent->right) + x->parent->right = y; + else { + RBT_ASSERT(x == x->parent->left); + x->parent->left = y; + } + y->right = x; + x->parent = y; +} + + +/* + * Replace node x with node y + * NOTE: block header of y is not changed + */ +static ERTS_INLINE void +replace(RBTree_t **root, RBTree_t *x, RBTree_t *y) +{ + + if (!x->parent) { + RBT_ASSERT(*root == x); + *root = y; + } + else if (x == x->parent->left) + x->parent->left = y; + else { + RBT_ASSERT(x == x->parent->right); + x->parent->right = y; + } + if (x->left) { + RBT_ASSERT(x->left->parent == x); + x->left->parent = y; + } + if (x->right) { + RBT_ASSERT(x->right->parent == x); + x->right->parent = y; + } + + y->flags = x->flags; + y->parent = x->parent; + y->right = x->right; + y->left = x->left; + + DESTROY_TREE_NODE(x); + +} + +static void +tree_insert_fixup(RBTree_t *blk) +{ + RBTree_t *x = blk, *y; + + /* + * Rearrange the tree so that it satisfies the Red-Black Tree properties + */ + + RBT_ASSERT(x != root && IS_RED(x->parent)); + do { + + /* + * x and its parent are both red. Move the red pair up the tree + * until we get to the root or until we can separate them. + */ + + RBT_ASSERT(IS_RED(x)); + RBT_ASSERT(IS_BLACK(x->parent->parent)); + RBT_ASSERT(x->parent->parent); + + if (x->parent == x->parent->parent->left) { + y = x->parent->parent->right; + if (IS_RED(y)) { + SET_BLACK(y); + x = x->parent; + SET_BLACK(x); + x = x->parent; + SET_RED(x); + } + else { + + if (x == x->parent->right) { + x = x->parent; + left_rotate(&root, x); + } + + RBT_ASSERT(x == x->parent->parent->left->left); + RBT_ASSERT(IS_RED(x)); + RBT_ASSERT(IS_RED(x->parent)); + RBT_ASSERT(IS_BLACK(x->parent->parent)); + RBT_ASSERT(IS_BLACK(y)); + + SET_BLACK(x->parent); + SET_RED(x->parent->parent); + right_rotate(&root, x->parent->parent); + + RBT_ASSERT(x == x->parent->left); + RBT_ASSERT(IS_RED(x)); + RBT_ASSERT(IS_RED(x->parent->right)); + RBT_ASSERT(IS_BLACK(x->parent)); + break; + } + } + else { + RBT_ASSERT(x->parent == x->parent->parent->right); + y = x->parent->parent->left; + if (IS_RED(y)) { + SET_BLACK(y); + x = x->parent; + SET_BLACK(x); + x = x->parent; + SET_RED(x); + } + else { + + if (x == x->parent->left) { + x = x->parent; + right_rotate(&root, x); + } + + RBT_ASSERT(x == x->parent->parent->right->right); + RBT_ASSERT(IS_RED(x)); + RBT_ASSERT(IS_RED(x->parent)); + RBT_ASSERT(IS_BLACK(x->parent->parent)); + RBT_ASSERT(IS_BLACK(y)); + + SET_BLACK(x->parent); + SET_RED(x->parent->parent); + left_rotate(&root, x->parent->parent); + + RBT_ASSERT(x == x->parent->right); + RBT_ASSERT(IS_RED(x)); + RBT_ASSERT(IS_RED(x->parent->left)); + RBT_ASSERT(IS_BLACK(x->parent)); + break; + } + } + } while (x != root && IS_RED(x->parent)); + + SET_BLACK(root); +} + +static void +unlink_free_block(Block_t *del) +{ + Uint spliced_is_black; + RBTree_t *x, *y, *z = (RBTree_t *) del; + RBTree_t null_x; /* null_x is used to get the fixup started when we + splice out a node without children. */ + + null_x.parent = NULL; + +#ifdef HARD_DEBUG + check_tree(0); +#endif + + /* Remove node from tree... */ + + /* Find node to splice out */ + if (!z->left || !z->right) + y = z; + else + /* Set y to z:s successor */ + for(y = z->right; y->left; y = y->left); + /* splice out y */ + x = y->left ? y->left : y->right; + spliced_is_black = IS_BLACK(y); + if (x) { + x->parent = y->parent; + } + else if (!x && spliced_is_black) { + x = &null_x; + x->flags = 0; + SET_BLACK(x); + x->right = x->left = NULL; + x->parent = y->parent; + y->left = x; + } + + if (!y->parent) { + RBT_ASSERT(root == y); + root = x; + } + else if (y == y->parent->left) + y->parent->left = x; + else { + RBT_ASSERT(y == y->parent->right); + y->parent->right = x; + } + if (y != z) { + /* We spliced out the successor of z; replace z by the successor */ + replace(&root, z, y); + } + + if (spliced_is_black) { + /* We removed a black node which makes the resulting tree + violate the Red-Black Tree properties. Fixup tree... */ + + while (IS_BLACK(x) && x->parent) { + + /* + * x has an "extra black" which we move up the tree + * until we reach the root or until we can get rid of it. + * + * y is the sibbling of x + */ + + if (x == x->parent->left) { + y = x->parent->right; + RBT_ASSERT(y); + if (IS_RED(y)) { + RBT_ASSERT(y->right); + RBT_ASSERT(y->left); + SET_BLACK(y); + RBT_ASSERT(IS_BLACK(x->parent)); + SET_RED(x->parent); + left_rotate(&root, x->parent); + y = x->parent->right; + } + RBT_ASSERT(y); + RBT_ASSERT(IS_BLACK(y)); + if (IS_BLACK(y->left) && IS_BLACK(y->right)) { + SET_RED(y); + x = x->parent; + } + else { + if (IS_BLACK(y->right)) { + SET_BLACK(y->left); + SET_RED(y); + right_rotate(&root, y); + y = x->parent->right; + } + RBT_ASSERT(y); + if (IS_RED(x->parent)) { + + SET_BLACK(x->parent); + SET_RED(y); + } + RBT_ASSERT(y->right); + SET_BLACK(y->right); + left_rotate(&root, x->parent); + x = root; + break; + } + } + else { + RBT_ASSERT(x == x->parent->right); + y = x->parent->left; + RBT_ASSERT(y); + if (IS_RED(y)) { + RBT_ASSERT(y->right); + RBT_ASSERT(y->left); + SET_BLACK(y); + RBT_ASSERT(IS_BLACK(x->parent)); + SET_RED(x->parent); + right_rotate(&root, x->parent); + y = x->parent->left; + } + RBT_ASSERT(y); + RBT_ASSERT(IS_BLACK(y)); + if (IS_BLACK(y->right) && IS_BLACK(y->left)) { + SET_RED(y); + x = x->parent; + } + else { + if (IS_BLACK(y->left)) { + SET_BLACK(y->right); + SET_RED(y); + left_rotate(&root, y); + y = x->parent->left; + } + RBT_ASSERT(y); + if (IS_RED(x->parent)) { + SET_BLACK(x->parent); + SET_RED(y); + } + RBT_ASSERT(y->left); + SET_BLACK(y->left); + right_rotate(&root, x->parent); + x = root; + break; + } + } + } + SET_BLACK(x); + + if (null_x.parent) { + if (null_x.parent->left == &null_x) + null_x.parent->left = NULL; + else { + RBT_ASSERT(null_x.parent->right == &null_x); + null_x.parent->right = NULL; + } + RBT_ASSERT(!null_x.left); + RBT_ASSERT(!null_x.right); + } + else if (root == &null_x) { + root = NULL; + RBT_ASSERT(!null_x.left); + RBT_ASSERT(!null_x.right); + } + } + + + DESTROY_TREE_NODE(del); + +#ifdef HARD_DEBUG + check_tree(0); +#endif + +} + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *\ + * "Address order best fit" specific callbacks. * +\* */ + +static void +link_free_block(Block_t *block) +{ + RBTree_t *blk = (RBTree_t *) block; + Uint blk_sz = BLK_SZ(blk); + + blk->flags = 0; + blk->left = NULL; + blk->right = NULL; + + if (!root) { + blk->parent = NULL; + SET_BLACK(blk); + root = blk; + } else { + RBTree_t *x = root; + while (1) { + Uint size; + + size = BLK_SZ(x); + + if (blk_sz < size || (blk_sz == size && blk < x)) { + if (!x->left) { + blk->parent = x; + x->left = blk; + break; + } + x = x->left; + } + else { + if (!x->right) { + blk->parent = x; + x->right = blk; + break; + } + x = x->right; + } + + } + + /* Insert block into size tree */ + RBT_ASSERT(blk->parent); + + SET_RED(blk); + if (IS_RED(blk->parent)) { + tree_insert_fixup(blk); + } + } + +#ifdef HARD_DEBUG + check_tree(0); +#endif +} + + +static Block_t * +get_free_block(Uint size) +{ + RBTree_t *x = root; + RBTree_t *blk = NULL; + Uint blk_sz; + + while (x) { + blk_sz = BLK_SZ(x); + if (blk_sz < size) { + x = x->right; + } + else { + blk = x; + x = x->left; + } + } + + if (!blk) + return NULL; + +#ifdef HARD_DEBUG + ASSERT(blk == check_tree(size)); +#endif + + unlink_free_block((Block_t *) blk); + + return (Block_t *) blk; +} + + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *\ + * Debug functions * +\* */ + + +#ifdef HARD_DEBUG + +#define IS_LEFT_VISITED(FB) ((FB)->flags & LEFT_VISITED_FLG) +#define IS_RIGHT_VISITED(FB) ((FB)->flags & RIGHT_VISITED_FLG) + +#define SET_LEFT_VISITED(FB) ((FB)->flags |= LEFT_VISITED_FLG) +#define SET_RIGHT_VISITED(FB) ((FB)->flags |= RIGHT_VISITED_FLG) + +#define UNSET_LEFT_VISITED(FB) ((FB)->flags &= ~LEFT_VISITED_FLG) +#define UNSET_RIGHT_VISITED(FB) ((FB)->flags &= ~RIGHT_VISITED_FLG) + + +#if 0 +# define PRINT_TREE +#else +# undef PRINT_TREE +#endif + +#ifdef PRINT_TREE +static void print_tree(void); +#endif + +/* + * Checks that the order between parent and children are correct, + * and that the Red-Black Tree properies are satisfied. if size > 0, + * check_tree() returns a node that satisfies "best fit" resp. + * "address order best fit". + * + * The Red-Black Tree properies are: + * 1. Every node is either red or black. + * 2. Every leaf (NIL) is black. + * 3. If a node is red, then both its children are black. + * 4. Every simple path from a node to a descendant leaf + * contains the same number of black nodes. + */ + +static RBTree_t * +check_tree(Uint size) +{ + RBTree_t *res = NULL; + Sint blacks; + Sint curr_blacks; + RBTree_t *x; + +#ifdef PRINT_TREE + print_tree(); +#endif + + if (!root) + return res; + + x = root; + ASSERT(IS_BLACK(x)); + ASSERT(!x->parent); + curr_blacks = 1; + blacks = -1; + + while (x) { + if (!IS_LEFT_VISITED(x)) { + SET_LEFT_VISITED(x); + if (x->left) { + x = x->left; + if (IS_BLACK(x)) + curr_blacks++; + continue; + } + else { + if (blacks < 0) + blacks = curr_blacks; + ASSERT(blacks == curr_blacks); + } + } + + if (!IS_RIGHT_VISITED(x)) { + SET_RIGHT_VISITED(x); + if (x->right) { + x = x->right; + if (IS_BLACK(x)) + curr_blacks++; + continue; + } + else { + if (blacks < 0) + blacks = curr_blacks; + ASSERT(blacks == curr_blacks); + } + } + + + if (IS_RED(x)) { + ASSERT(IS_BLACK(x->right)); + ASSERT(IS_BLACK(x->left)); + } + + ASSERT(x->parent || x == root); + + if (x->left) { + ASSERT(x->left->parent == x); + ASSERT(BLK_SZ(x->left) < BLK_SZ(x) + || (BLK_SZ(x->left) == BLK_SZ(x) && x->left < x)); + } + + if (x->right) { + ASSERT(x->right->parent == x); + ASSERT(BLK_SZ(x->right) > BLK_SZ(x) + || (BLK_SZ(x->right) == BLK_SZ(x) && x->right > x)); + } + + if (size && BLK_SZ(x) >= size) { + if (!res + || BLK_SZ(x) < BLK_SZ(res) + || (BLK_SZ(x) == BLK_SZ(res) && x < res)) + res = x; + } + + UNSET_LEFT_VISITED(x); + UNSET_RIGHT_VISITED(x); + if (IS_BLACK(x)) + curr_blacks--; + x = x->parent; + + } + + ASSERT(curr_blacks == 0); + + UNSET_LEFT_VISITED(root); + UNSET_RIGHT_VISITED(root); + + return res; + +} + + +#ifdef PRINT_TREE +#define INDENT_STEP 2 + +#include + +static void +print_tree_aux(RBTree_t *x, int indent) +{ + int i; + + if (!x) { + for (i = 0; i < indent; i++) { + putc(' ', stderr); + } + fprintf(stderr, "BLACK: nil\r\n"); + } + else { + print_tree_aux(x->right, indent + INDENT_STEP); + for (i = 0; i < indent; i++) { + putc(' ', stderr); + } + fprintf(stderr, "%s: sz=%lu addr=0x%lx\r\n", + IS_BLACK(x) ? "BLACK" : "RED", + BLK_SZ(x), + (Uint) x); + print_tree_aux(x->left, indent + INDENT_STEP); + } +} + + +static void +print_tree(void) +{ + fprintf(stderr, " --- Size-Adress tree begin ---\r\n"); + print_tree_aux(root, 0); + fprintf(stderr, " --- Size-Adress tree end ---\r\n"); +} + +#endif + +#endif + +#endif /* ENABLE_ELIB_MALLOC */ diff --git a/erts/emulator/beam/elib_memmove.c b/erts/emulator/beam/elib_memmove.c new file mode 100644 index 0000000000..d2fe8649ed --- /dev/null +++ b/erts/emulator/beam/elib_memmove.c @@ -0,0 +1,113 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1997-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* + * This memmove assumes that both src and dst are aligned on an address + * divisible by 4 and that n is a multiple of four. + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#ifndef HAVE_MEMMOVE + +#define MEMCPY_LIMIT 12 +typedef unsigned long u_long; +typedef unsigned short u_short; + +static void copy_high(dst, src, n) +char* dst; char* src; int n; +{ + dst += n; + src += n; + + if (n >= MEMCPY_LIMIT) { + while(((u_long) dst) & 3) { + *--dst = *--src; + n--; + } + if ((((u_long) src) & 3) == 0) { + while(n >= sizeof(u_long)) { + src -= sizeof(u_long); + dst -= sizeof(u_long); + *((u_long*)dst) = *((u_long*)src); + n -= sizeof(u_long); + } + } + else if ((((u_short) src) & 3) == 2) { + while(n >= sizeof(u_short)) { + src -= sizeof(u_short); + dst -= sizeof(u_short); + *((u_short*)dst) = *((u_short*)src); + n -= sizeof(u_short); + } + } + } + while(n > 0) { + *--dst = *--src; + n--; + } +} + +static void copy_low(dst, src, n) +char* dst; char* src; int n; +{ + if (n >= MEMCPY_LIMIT) { + while(((u_long) dst) & 3) { + *dst++ = *src++; + n--; + } + if ((((u_long) src) & 3) == 0) { + while(n >= sizeof(u_long)) { + *((u_long*)dst) = *((u_long*)src); + src += sizeof(u_long); + dst += sizeof(u_long); + n -= sizeof(u_long); + } + } + else if ((((u_long) src) & 3) == 2) { + while(n >= sizeof(u_short)) { + *((u_short*)dst) = *((u_short*)src); + src += sizeof(u_short); + dst += sizeof(u_short); + n -= sizeof(u_short); + } + } + } + while(n > 0) { + *dst++ = *src++; + n--; + } +} + +/* +** Move memory (with overlap) +*/ +void* memmove(dst, src, n) +char* dst; char* src; int n; +{ + if (dst < src) + copy_low(dst, src, n); + else if (dst > src) + copy_high(dst, src, n); + return dst; +} + +#endif /* HAVE_MEMMOVE */ diff --git a/erts/emulator/beam/elib_stat.h b/erts/emulator/beam/elib_stat.h new file mode 100644 index 0000000000..d8c7f31737 --- /dev/null +++ b/erts/emulator/beam/elib_stat.h @@ -0,0 +1,45 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* +** Interface to elib statistics +** +*/ +#ifndef __ELIB_STAT_H__ +#define __ELIB_STAT_H__ + +struct elib_stat { + int mem_total; /* Number of heap words */ + int mem_blocks; /* Number of block */ + int mem_alloc; /* Number of words in use */ + int mem_free; /* Number of words free */ + int min_used; /* Size of the smallest block used */ + int max_free; /* Size of the largest free block */ + int free_blocks; /* Number of fragments in free list */ + int mem_max_alloc;/* Max number of words in use */ +}; + +EXTERN_FUNCTION(void, elib_statistics, (void*)); +EXTERN_FUNCTION(int, elib_check_heap, (_VOID_)); +EXTERN_FUNCTION(void, elib_heap_dump, (char*)); +EXTERN_FUNCTION(void, elib_stat, (struct elib_stat*)); +EXTERN_FUNCTION(int, elib_heap_map, (unsigned char*, int)); +EXTERN_FUNCTION(int, elib_histo, (unsigned long*, unsigned long*, int, int)); + +#endif diff --git a/erts/emulator/beam/erl_afit_alloc.c b/erts/emulator/beam/erl_afit_alloc.c new file mode 100644 index 0000000000..e8b594bb47 --- /dev/null +++ b/erts/emulator/beam/erl_afit_alloc.c @@ -0,0 +1,256 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2003-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + + +/* + * Description: A fast allocator intended for temporary allocation. + * When allocating, only the first block in the free list + * is inspected, if this block doesn't fit a new carrier + * is created. NOTE: this allocator can behave really bad + * if misused. + * + * This module is a callback-module for erl_alloc_util.c + * + * Author: Rickard Green + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif +#include "global.h" +#define GET_ERL_AF_ALLOC_IMPL +#include "erl_afit_alloc.h" + + +#define MIN_MBC_SZ (16*1024) +#define MIN_MBC_FIRST_FREE_SZ (4*1024) + +/* Prototypes of callback functions */ +static Block_t * get_free_block (Allctr_t *, Uint, + Block_t *, Uint); +static void link_free_block (Allctr_t *, Block_t *); +static void unlink_free_block (Allctr_t *, Block_t *); + + +static Eterm info_options (Allctr_t *, char *, int *, + void *arg, Uint **, Uint *); +static void init_atoms (void); + +static int atoms_initialized = 0; + +void +erts_afalc_init(void) +{ + atoms_initialized = 0; +} + +Allctr_t * +erts_afalc_start(AFAllctr_t *afallctr, + AFAllctrInit_t *afinit, + AllctrInit_t *init) +{ + AFAllctr_t nulled_state = {{0}}; + /* {{0}} is used instead of {0}, in order to avoid (an incorrect) gcc + warning. gcc warns if {0} is used as initializer of a struct when + the first member is a struct (not if, for example, the third member + is a struct). */ + Allctr_t *allctr = (Allctr_t *) afallctr; + + sys_memcpy((void *) afallctr, (void *) &nulled_state, sizeof(AFAllctr_t)); + + allctr->mbc_header_size = sizeof(Carrier_t); + allctr->min_mbc_size = MIN_MBC_SZ; + allctr->min_mbc_first_free_size = MIN_MBC_FIRST_FREE_SZ; + allctr->min_block_size = sizeof(AFFreeBlock_t); + allctr->vsn_str = ERTS_ALC_AF_ALLOC_VSN_STR; + + /* Callback functions */ + allctr->get_free_block = get_free_block; + allctr->link_free_block = link_free_block; + allctr->unlink_free_block = unlink_free_block; + allctr->info_options = info_options; + + allctr->get_next_mbc_size = NULL; + allctr->creating_mbc = NULL; + allctr->destroying_mbc = NULL; + allctr->init_atoms = init_atoms; + +#ifdef ERTS_ALLOC_UTIL_HARD_DEBUG + allctr->check_block = NULL; + allctr->check_mbc = NULL; +#endif + + allctr->atoms_initialized = 0; + + if (!erts_alcu_start(allctr, init)) + return NULL; + + return allctr; +} + +static Block_t * +get_free_block(Allctr_t *allctr, Uint size, Block_t *cand_blk, Uint cand_size) +{ + AFAllctr_t *afallctr = (AFAllctr_t *) allctr; + + ASSERT(!cand_blk || cand_size >= size); + + if (afallctr->free_list && BLK_SZ(afallctr->free_list) >= size) { + AFFreeBlock_t *res = afallctr->free_list; + afallctr->free_list = res->next; + if (res->next) + res->next->prev = NULL; + return (Block_t *) res; + } + else + return NULL; +} + +static void +link_free_block(Allctr_t *allctr, Block_t *block) +{ + AFFreeBlock_t *blk = (AFFreeBlock_t *) block; + AFAllctr_t *afallctr = (AFAllctr_t *) allctr; + + if (afallctr->free_list && BLK_SZ(afallctr->free_list) > BLK_SZ(blk)) { + blk->next = afallctr->free_list->next; + blk->prev = afallctr->free_list; + afallctr->free_list->next = blk; + } + else { + blk->next = afallctr->free_list; + blk->prev = NULL; + afallctr->free_list = blk; + } + + if (blk->next) + blk->next->prev = blk; +} + +static void +unlink_free_block(Allctr_t *allctr, Block_t *block) +{ + AFFreeBlock_t *blk = (AFFreeBlock_t *) block; + AFAllctr_t *afallctr = (AFAllctr_t *) allctr; + + if (blk->prev) + blk->prev->next = blk->next; + else + afallctr->free_list = blk->next; + if (blk->next) + blk->next->prev = blk->prev; +} + + +static struct { + Eterm as; + Eterm af; +#ifdef DEBUG + Eterm end_of_atoms; +#endif +} am; + +static void ERTS_INLINE atom_init(Eterm *atom, char *name) +{ + *atom = am_atom_put(name, strlen(name)); +} +#define AM_INIT(AM) atom_init(&am.AM, #AM) + +static void +init_atoms(void) +{ +#ifdef DEBUG + Eterm *atom; +#endif + + if (atoms_initialized) + return; + +#ifdef DEBUG + for (atom = (Eterm *) &am; atom <= &am.end_of_atoms; atom++) { + *atom = THE_NON_VALUE; + } +#endif + + AM_INIT(as); + AM_INIT(af); + +#ifdef DEBUG + for (atom = (Eterm *) &am; atom < &am.end_of_atoms; atom++) { + ASSERT(*atom != THE_NON_VALUE); + } +#endif + + atoms_initialized = 1; +} + + +#define bld_uint erts_bld_uint +#define bld_cons erts_bld_cons +#define bld_tuple erts_bld_tuple + +static ERTS_INLINE void +add_2tup(Uint **hpp, Uint *szp, Eterm *lp, Eterm el1, Eterm el2) +{ + *lp = bld_cons(hpp, szp, bld_tuple(hpp, szp, 2, el1, el2), *lp); +} + +static Eterm +info_options(Allctr_t *allctr, + char *prefix, + int *print_to_p, + void *print_to_arg, + Uint **hpp, + Uint *szp) +{ + Eterm res = THE_NON_VALUE; + + if (print_to_p) { + erts_print(*print_to_p, print_to_arg, "%sas: af\n", prefix); + } + + if (hpp || szp) { + + if (!atoms_initialized) + erl_exit(1, "%s:%d: Internal error: Atoms not initialized", + __FILE__, __LINE__);; + + res = NIL; + add_2tup(hpp, szp, &res, am.as, am.af); + } + + return res; +} + + + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *\ + * NOTE: erts_afalc_test() is only supposed to be used for testing. * + * * + * Keep alloc_SUITE_data/allocator_test.h updated if changes are made * + * to erts_afalc_test() * +\* */ + +unsigned long +erts_afalc_test(unsigned long op, unsigned long a1, unsigned long a2) +{ + switch (op) { + default: ASSERT(0); return ~((unsigned long) 0); + } +} diff --git a/erts/emulator/beam/erl_afit_alloc.h b/erts/emulator/beam/erl_afit_alloc.h new file mode 100644 index 0000000000..ea408a7194 --- /dev/null +++ b/erts/emulator/beam/erl_afit_alloc.h @@ -0,0 +1,67 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2003-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + + +#ifndef ERL_AFIT_ALLOC__ +#define ERL_AFIT_ALLOC__ + +#include "erl_alloc_util.h" + +#define ERTS_ALC_AF_ALLOC_VSN_STR "0.9" + +typedef struct AFAllctr_t_ AFAllctr_t; + +typedef struct { + int dummy; +} AFAllctrInit_t; + +#define ERTS_DEFAULT_AF_ALLCTR_INIT { \ + 0 /* dummy */\ +} + +void erts_afalc_init(void); +Allctr_t *erts_afalc_start(AFAllctr_t *, AFAllctrInit_t *, AllctrInit_t *); + +#endif /* #ifndef ERL_BESTFIT_ALLOC__ */ + + + +#if defined(GET_ERL_AF_ALLOC_IMPL) && !defined(ERL_AF_ALLOC_IMPL__) +#define ERL_AF_ALLOC_IMPL__ + +#define GET_ERL_ALLOC_UTIL_IMPL +#include "erl_alloc_util.h" + +typedef struct AFFreeBlock_t_ AFFreeBlock_t; +struct AFFreeBlock_t_ { + Block_t block_head; + AFFreeBlock_t *prev; + AFFreeBlock_t *next; +}; + +struct AFAllctr_t_ { + Allctr_t allctr; /* Has to be first! */ + + AFFreeBlock_t * free_list; +}; + +unsigned long erts_afalc_test(unsigned long, unsigned long, unsigned long); + +#endif /* #if defined(GET_ERL_AF_ALLOC_IMPL) + && !defined(ERL_AF_ALLOC_IMPL__) */ diff --git a/erts/emulator/beam/erl_alloc.c b/erts/emulator/beam/erl_alloc.c new file mode 100644 index 0000000000..b853ec0f01 --- /dev/null +++ b/erts/emulator/beam/erl_alloc.c @@ -0,0 +1,3157 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2002-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + + +/* + * Description: Management of memory allocators. + * + * Author: Rickard Green + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif +#define ERTS_ALLOC_C__ +#define ERTS_ALC_INTERNAL__ +#include "sys.h" +#define ERL_THREADS_EMU_INTERNAL__ +#include "erl_threads.h" +#include "global.h" +#include "erl_db.h" +#include "erl_binary.h" +#include "erl_bits.h" +#include "erl_instrument.h" +#include "erl_mseg.h" +#ifdef ELIB_ALLOC_IS_CLIB +#include "erl_version.h" +#endif +#include "erl_monitors.h" +#include "erl_bif_timer.h" +#if defined(ERTS_ALC_T_DRV_SEL_D_STATE) || defined(ERTS_ALC_T_DRV_EV_D_STATE) +#include "erl_check_io.h" +#endif + +#define GET_ERL_GF_ALLOC_IMPL +#include "erl_goodfit_alloc.h" +#define GET_ERL_BF_ALLOC_IMPL +#include "erl_bestfit_alloc.h" +#define GET_ERL_AF_ALLOC_IMPL +#include "erl_afit_alloc.h" + +#define ERTS_ALC_DEFAULT_MAX_THR_PREF 16 + +#if defined(SMALL_MEMORY) || defined(PURIFY) || defined(VALGRIND) +#define AU_ALLOC_DEFAULT_ENABLE(X) 0 +#else +#define AU_ALLOC_DEFAULT_ENABLE(X) (X) +#endif + +#ifdef DEBUG +static Uint install_debug_functions(void); +#endif +extern void elib_ensure_initialized(void); + +ErtsAllocatorFunctions_t erts_allctrs[ERTS_ALC_A_MAX+1]; +ErtsAllocatorInfo_t erts_allctrs_info[ERTS_ALC_A_MAX+1]; +ErtsAllocatorThrSpec_t erts_allctr_thr_spec[ERTS_ALC_A_MAX+1]; + +#define ERTS_MIN(A, B) ((A) < (B) ? (A) : (B)) +#define ERTS_MAX(A, B) ((A) > (B) ? (A) : (B)) + +typedef union { + GFAllctr_t gfa; + char align_gfa[ERTS_ALC_CACHE_LINE_ALIGN_SIZE(sizeof(GFAllctr_t))]; + BFAllctr_t bfa; + char align_bfa[ERTS_ALC_CACHE_LINE_ALIGN_SIZE(sizeof(BFAllctr_t))]; + AFAllctr_t afa; + char align_afa[ERTS_ALC_CACHE_LINE_ALIGN_SIZE(sizeof(AFAllctr_t))]; +} ErtsAllocatorState_t; + +static ErtsAllocatorState_t sl_alloc_state; +static ErtsAllocatorState_t std_alloc_state; +static ErtsAllocatorState_t ll_alloc_state; +static ErtsAllocatorState_t temp_alloc_state; +static ErtsAllocatorState_t eheap_alloc_state; +static ErtsAllocatorState_t binary_alloc_state; +static ErtsAllocatorState_t ets_alloc_state; +static ErtsAllocatorState_t driver_alloc_state; + +ErtsAlcType_t erts_fix_core_allocator_ix; +#ifdef ERTS_ALC_N_MIN_A_FIXED_SIZE +static void *(*fix_core_allocator)(ErtsAlcType_t, void *, Uint); +static void *fix_core_extra; +static void *fix_core_alloc(Uint size) +{ + void *res; + res = (*fix_core_allocator)(ERTS_ALC_T_UNDEF, fix_core_extra, size); + if (erts_mtrace_enabled) + erts_mtrace_crr_alloc(res, + ERTS_ALC_A_FIXED_SIZE, + erts_fix_core_allocator_ix, + size); + return res; +} +#endif + +enum allctr_type { + GOODFIT, + BESTFIT, + AFIT +}; + +struct au_init { + int enable; + int thr_spec; + enum allctr_type atype; + struct { + AllctrInit_t util; + GFAllctrInit_t gf; + BFAllctrInit_t bf; + AFAllctrInit_t af; + } init; + struct { + int mmbcs; + int lmbcs; + int smbcs; + int mmmbc; + } default_; +}; + +#define DEFAULT_ALLCTR_INIT { \ + ERTS_DEFAULT_ALLCTR_INIT, \ + ERTS_DEFAULT_GF_ALLCTR_INIT, \ + ERTS_DEFAULT_BF_ALLCTR_INIT, \ + ERTS_DEFAULT_AF_ALLCTR_INIT \ +} + +typedef struct { + int erts_alloc_config; +#if HAVE_ERTS_MSEG + ErtsMsegInit_t mseg; +#endif + int trim_threshold; + int top_pad; + AlcUInit_t alloc_util; + struct { + int stat; + int map; + char *mtrace; + char *nodename; + } instr; + struct au_init sl_alloc; + struct au_init std_alloc; + struct au_init ll_alloc; + struct au_init temp_alloc; + struct au_init eheap_alloc; + struct au_init binary_alloc; + struct au_init ets_alloc; + struct au_init driver_alloc; +} erts_alc_hndl_args_init_t; + +#define ERTS_AU_INIT__ {0, 0, GOODFIT, DEFAULT_ALLCTR_INIT, {1,1,1,1}} + +#define SET_DEFAULT_ALLOC_OPTS(IP) \ +do { \ + struct au_init aui__ = ERTS_AU_INIT__; \ + sys_memcpy((void *) (IP), (void *) &aui__, sizeof(struct au_init)); \ +} while (0) + +static void +set_default_sl_alloc_opts(struct au_init *ip) +{ + SET_DEFAULT_ALLOC_OPTS(ip); + ip->enable = AU_ALLOC_DEFAULT_ENABLE(1); + ip->thr_spec = 1; + ip->atype = GOODFIT; + ip->init.util.name_prefix = "sl_"; + ip->init.util.mmmbc = 5; + ip->init.util.alloc_no = ERTS_ALC_A_SHORT_LIVED; +#ifndef SMALL_MEMORY + ip->init.util.mmbcs = 128*1024; /* Main carrier size */ +#else + ip->init.util.mmbcs = 32*1024; /* Main carrier size */ +#endif + ip->init.util.ts = ERTS_ALC_MTA_SHORT_LIVED; + ip->init.util.rsbcst = 80; +} + +static void +set_default_std_alloc_opts(struct au_init *ip) +{ + SET_DEFAULT_ALLOC_OPTS(ip); + ip->enable = AU_ALLOC_DEFAULT_ENABLE(1); + ip->thr_spec = 1; + ip->atype = BESTFIT; + ip->init.util.name_prefix = "std_"; + ip->init.util.mmmbc = 5; + ip->init.util.alloc_no = ERTS_ALC_A_STANDARD; +#ifndef SMALL_MEMORY + ip->init.util.mmbcs = 128*1024; /* Main carrier size */ +#else + ip->init.util.mmbcs = 32*1024; /* Main carrier size */ +#endif + ip->init.util.ts = ERTS_ALC_MTA_STANDARD; +} + +static void +set_default_ll_alloc_opts(struct au_init *ip) +{ + SET_DEFAULT_ALLOC_OPTS(ip); + ip->enable = AU_ALLOC_DEFAULT_ENABLE(1); + ip->thr_spec = 0; + ip->atype = BESTFIT; + ip->init.bf.ao = 1; + ip->init.util.ramv = 0; + ip->init.util.mmsbc = 0; + ip->init.util.mmmbc = 0; + ip->init.util.sbct = ~((Uint) 0); + ip->init.util.name_prefix = "ll_"; + ip->init.util.alloc_no = ERTS_ALC_A_LONG_LIVED; +#ifndef SMALL_MEMORY + ip->init.util.mmbcs = 2*1024*1024; /* Main carrier size */ +#else + ip->init.util.mmbcs = 1*1024*1024; /* Main carrier size */ +#endif + ip->init.util.ts = ERTS_ALC_MTA_LONG_LIVED; + ip->init.util.asbcst = 0; + ip->init.util.rsbcst = 0; + ip->init.util.rsbcmt = 0; + ip->init.util.rmbcmt = 0; +} + +static void +set_default_temp_alloc_opts(struct au_init *ip) +{ + SET_DEFAULT_ALLOC_OPTS(ip); + ip->enable = AU_ALLOC_DEFAULT_ENABLE(1); + ip->thr_spec = 1; + ip->atype = AFIT; + ip->init.util.name_prefix = "temp_"; + ip->init.util.alloc_no = ERTS_ALC_A_TEMPORARY; +#ifndef SMALL_MEMORY + ip->init.util.mmbcs = 128*1024; /* Main carrier size */ +#else + ip->init.util.mmbcs = 32*1024; /* Main carrier size */ +#endif + ip->init.util.ts = ERTS_ALC_MTA_TEMPORARY; + ip->init.util.rsbcst = 90; + ip->init.util.rmbcmt = 100; +} + +static void +set_default_eheap_alloc_opts(struct au_init *ip) +{ + SET_DEFAULT_ALLOC_OPTS(ip); + ip->enable = AU_ALLOC_DEFAULT_ENABLE(1); + ip->thr_spec = 1; + ip->atype = GOODFIT; + ip->init.util.mmmbc = 100; + ip->init.util.name_prefix = "eheap_"; + ip->init.util.alloc_no = ERTS_ALC_A_EHEAP; +#ifndef SMALL_MEMORY + ip->init.util.mmbcs = 512*1024; /* Main carrier size */ +#else + ip->init.util.mmbcs = 256*1024; /* Main carrier size */ +#endif + ip->init.util.ts = ERTS_ALC_MTA_EHEAP; + ip->init.util.rsbcst = 50; +} + +static void +set_default_binary_alloc_opts(struct au_init *ip) +{ + SET_DEFAULT_ALLOC_OPTS(ip); + ip->enable = AU_ALLOC_DEFAULT_ENABLE(1); + ip->thr_spec = 1; + ip->atype = BESTFIT; + ip->init.util.mmmbc = 50; + ip->init.util.name_prefix = "binary_"; + ip->init.util.alloc_no = ERTS_ALC_A_BINARY; +#ifndef SMALL_MEMORY + ip->init.util.mmbcs = 128*1024; /* Main carrier size */ +#else + ip->init.util.mmbcs = 32*1024; /* Main carrier size */ +#endif + ip->init.util.ts = ERTS_ALC_MTA_BINARY; +} + +static void +set_default_ets_alloc_opts(struct au_init *ip) +{ + SET_DEFAULT_ALLOC_OPTS(ip); + ip->enable = AU_ALLOC_DEFAULT_ENABLE(1); + ip->thr_spec = 1; + ip->atype = BESTFIT; + ip->init.util.mmmbc = 100; + ip->init.util.name_prefix = "ets_"; + ip->init.util.alloc_no = ERTS_ALC_A_ETS; +#ifndef SMALL_MEMORY + ip->init.util.mmbcs = 128*1024; /* Main carrier size */ +#else + ip->init.util.mmbcs = 32*1024; /* Main carrier size */ +#endif + ip->init.util.ts = ERTS_ALC_MTA_ETS; +} + +static void +set_default_driver_alloc_opts(struct au_init *ip) +{ + SET_DEFAULT_ALLOC_OPTS(ip); + ip->enable = AU_ALLOC_DEFAULT_ENABLE(1); + ip->thr_spec = 1; + ip->atype = BESTFIT; + ip->init.util.name_prefix = "driver_"; + ip->init.util.alloc_no = ERTS_ALC_A_DRIVER; +#ifndef SMALL_MEMORY + ip->init.util.mmbcs = 128*1024; /* Main carrier size */ +#else + ip->init.util.mmbcs = 32*1024; /* Main carrier size */ +#endif + ip->init.util.ts = ERTS_ALC_MTA_DRIVER; +} + +#ifdef ERTS_SMP + +static void +adjust_tpref(struct au_init *ip, int no_sched) +{ + if (ip->thr_spec) { + Uint allocs; + if (ip->thr_spec < 0) {/* User specified amount */ + allocs = abs(ip->thr_spec); + if (allocs > no_sched) + allocs = no_sched; + } + else if (no_sched > ERTS_ALC_DEFAULT_MAX_THR_PREF) + allocs = ERTS_ALC_DEFAULT_MAX_THR_PREF; + else + allocs = no_sched; + if (allocs <= 1) + ip->thr_spec = 0; + else { + ip->thr_spec = (int) allocs; + ip->thr_spec *= -1; /* thread preferred */ + + /* If default ... */ + + /* ... shrink main multi-block carrier size */ + if (ip->default_.mmbcs) + ip->init.util.mmbcs /= ERTS_MIN(4, allocs); + /* ... shrink largest multi-block carrier size */ + if (ip->default_.lmbcs) + ip->init.util.lmbcs /= ERTS_MIN(2, allocs); + /* ... shrink smallest multi-block carrier size */ + if (ip->default_.smbcs) + ip->init.util.smbcs /= ERTS_MIN(4, allocs); + /* ... and more than three allocators shrink + max mseg multi-block carriers */ + if (ip->default_.mmmbc && allocs > 2) { + ip->init.util.mmmbc /= ERTS_MIN(4, allocs - 1); + if (ip->init.util.mmmbc < 3) + ip->init.util.mmmbc = 3; + } + } + } +} + +#endif + +static void handle_args(int *, char **, erts_alc_hndl_args_init_t *); + +static void +set_au_allocator(ErtsAlcType_t alctr_n, struct au_init *init); + +static void +start_au_allocator(ErtsAlcType_t alctr_n, + struct au_init *init, + ErtsAllocatorState_t *state); + +static void +refuse_af_strategy(struct au_init *init) +{ + if (init->atype == AFIT) + init->atype = GOODFIT; +} + +static void init_thr_ix(int static_ixs); + +void +erts_alloc_init(int *argc, char **argv, ErtsAllocInitOpts *eaiop) +{ + Uint extra_block_size = 0; + int i; + erts_alc_hndl_args_init_t init = { + 0, +#if HAVE_ERTS_MSEG + ERTS_MSEG_INIT_DEFAULT_INITIALIZER, +#endif + ERTS_DEFAULT_TRIM_THRESHOLD, + ERTS_DEFAULT_TOP_PAD, + ERTS_DEFAULT_ALCU_INIT + }; + + erts_sys_alloc_init(); + init_thr_ix(erts_no_schedulers); + erts_init_utils_mem(); + + set_default_sl_alloc_opts(&init.sl_alloc); + set_default_std_alloc_opts(&init.std_alloc); + set_default_ll_alloc_opts(&init.ll_alloc); + set_default_temp_alloc_opts(&init.temp_alloc); + set_default_eheap_alloc_opts(&init.eheap_alloc); + set_default_binary_alloc_opts(&init.binary_alloc); + set_default_ets_alloc_opts(&init.ets_alloc); + set_default_driver_alloc_opts(&init.driver_alloc); + + if (argc && argv) + handle_args(argc, argv, &init); + + if (erts_no_schedulers <= 1) { + init.sl_alloc.thr_spec = 0; + init.std_alloc.thr_spec = 0; + init.ll_alloc.thr_spec = 0; + init.eheap_alloc.thr_spec = 0; + init.binary_alloc.thr_spec = 0; + init.ets_alloc.thr_spec = 0; + init.driver_alloc.thr_spec = 0; + } + + if (init.erts_alloc_config) { + /* Adjust flags that erts_alloc_config won't like */ + init.temp_alloc.thr_spec = 0; + init.sl_alloc.thr_spec = 0; + init.std_alloc.thr_spec = 0; + init.ll_alloc.thr_spec = 0; + init.eheap_alloc.thr_spec = 0; + init.binary_alloc.thr_spec = 0; + init.ets_alloc.thr_spec = 0; + init.driver_alloc.thr_spec = 0; + } + +#ifdef ERTS_SMP + /* Only temp_alloc can use thread specific interface */ + if (init.temp_alloc.thr_spec) + init.temp_alloc.thr_spec = erts_no_schedulers; + + /* Others must use thread preferred interface */ + adjust_tpref(&init.sl_alloc, erts_no_schedulers); + adjust_tpref(&init.std_alloc, erts_no_schedulers); + adjust_tpref(&init.ll_alloc, erts_no_schedulers); + adjust_tpref(&init.eheap_alloc, erts_no_schedulers); + adjust_tpref(&init.binary_alloc, erts_no_schedulers); + adjust_tpref(&init.ets_alloc, erts_no_schedulers); + adjust_tpref(&init.driver_alloc, erts_no_schedulers); + +#else + /* No thread specific if not smp */ + init.temp_alloc.thr_spec = 0; +#endif + + /* + * The following allocators cannot be run with afit strategy. + * Make sure they don't... + */ + refuse_af_strategy(&init.sl_alloc); + refuse_af_strategy(&init.std_alloc); + refuse_af_strategy(&init.ll_alloc); + refuse_af_strategy(&init.eheap_alloc); + refuse_af_strategy(&init.binary_alloc); + refuse_af_strategy(&init.ets_alloc); + refuse_af_strategy(&init.driver_alloc); + +#ifdef ERTS_SMP + if (!init.temp_alloc.thr_spec) + refuse_af_strategy(&init.temp_alloc); +#endif + + erts_mtrace_pre_init(); +#if HAVE_ERTS_MSEG + erts_mseg_init(&init.mseg); +#endif + erts_alcu_init(&init.alloc_util); + erts_afalc_init(); + erts_bfalc_init(); + erts_gfalc_init(); + + for (i = ERTS_ALC_A_MIN; i <= ERTS_ALC_A_MAX; i++) { + erts_allctrs[i].alloc = NULL; + erts_allctrs[i].realloc = NULL; + erts_allctrs[i].free = NULL; + erts_allctrs[i].extra = NULL; + erts_allctrs_info[i].alloc_util = 0; + erts_allctrs_info[i].enabled = 0; + erts_allctrs_info[i].thr_spec = 0; + erts_allctrs_info[i].extra = NULL; + } + +#ifdef ERTS_ALC_N_MIN_A_FIXED_SIZE +#if !defined(PURIFY) && !defined(VALGRIND) + erts_allctrs[ERTS_ALC_A_FIXED_SIZE].alloc = erts_fix_alloc; + erts_allctrs[ERTS_ALC_A_FIXED_SIZE].realloc = erts_fix_realloc; + erts_allctrs[ERTS_ALC_A_FIXED_SIZE].free = erts_fix_free; + erts_allctrs_info[ERTS_ALC_A_FIXED_SIZE].enabled = 1; +#else + erts_allctrs[ERTS_ALC_A_FIXED_SIZE].alloc = erts_sys_alloc; + erts_allctrs[ERTS_ALC_A_FIXED_SIZE].realloc = erts_sys_realloc; + erts_allctrs[ERTS_ALC_A_FIXED_SIZE].free = erts_sys_free; + erts_allctrs_info[ERTS_ALC_A_FIXED_SIZE].enabled = 0; +#endif +#endif + + erts_allctrs[ERTS_ALC_A_SYSTEM].alloc = erts_sys_alloc; + erts_allctrs[ERTS_ALC_A_SYSTEM].realloc = erts_sys_realloc; + erts_allctrs[ERTS_ALC_A_SYSTEM].free = erts_sys_free; + erts_allctrs_info[ERTS_ALC_A_SYSTEM].enabled = 1; + + set_au_allocator(ERTS_ALC_A_TEMPORARY, &init.temp_alloc); + set_au_allocator(ERTS_ALC_A_SHORT_LIVED, &init.sl_alloc); + set_au_allocator(ERTS_ALC_A_STANDARD, &init.std_alloc); + set_au_allocator(ERTS_ALC_A_LONG_LIVED, &init.ll_alloc); + set_au_allocator(ERTS_ALC_A_EHEAP, &init.eheap_alloc); + set_au_allocator(ERTS_ALC_A_BINARY, &init.binary_alloc); + set_au_allocator(ERTS_ALC_A_ETS, &init.ets_alloc); + set_au_allocator(ERTS_ALC_A_DRIVER, &init.driver_alloc); + + for (i = ERTS_ALC_A_MIN; i <= ERTS_ALC_A_MAX; i++) { + if (!erts_allctrs[i].alloc) + erl_exit(ERTS_ABORT_EXIT, + "Missing alloc function for %s\n", ERTS_ALC_A2AD(i)); + if (!erts_allctrs[i].realloc) + erl_exit(ERTS_ABORT_EXIT, + "Missing realloc function for %s\n", ERTS_ALC_A2AD(i)); + if (!erts_allctrs[i].free) + erl_exit(ERTS_ABORT_EXIT, + "Missing free function for %s\n", ERTS_ALC_A2AD(i)); + } + + sys_alloc_opt(SYS_ALLOC_OPT_TRIM_THRESHOLD, init.trim_threshold); + sys_alloc_opt(SYS_ALLOC_OPT_TOP_PAD, init.top_pad); + + if (erts_allctrs_info[ERTS_FIX_CORE_ALLOCATOR].enabled) + erts_fix_core_allocator_ix = ERTS_FIX_CORE_ALLOCATOR; + else + erts_fix_core_allocator_ix = ERTS_ALC_A_SYSTEM; + + erts_mtrace_init(init.instr.mtrace, init.instr.nodename); + + start_au_allocator(ERTS_ALC_A_TEMPORARY, + &init.temp_alloc, + &temp_alloc_state); + + start_au_allocator(ERTS_ALC_A_SHORT_LIVED, + &init.sl_alloc, + &sl_alloc_state); + + start_au_allocator(ERTS_ALC_A_STANDARD, + &init.std_alloc, + &std_alloc_state); + + start_au_allocator(ERTS_ALC_A_LONG_LIVED, + &init.ll_alloc, + &ll_alloc_state); + + start_au_allocator(ERTS_ALC_A_EHEAP, + &init.eheap_alloc, + &eheap_alloc_state); + + start_au_allocator(ERTS_ALC_A_BINARY, + &init.binary_alloc, + &binary_alloc_state); + + start_au_allocator(ERTS_ALC_A_ETS, + &init.ets_alloc, + &ets_alloc_state); + + start_au_allocator(ERTS_ALC_A_DRIVER, + &init.driver_alloc, + &driver_alloc_state); + + fix_core_allocator = erts_allctrs[erts_fix_core_allocator_ix].alloc; + fix_core_extra = erts_allctrs[erts_fix_core_allocator_ix].extra; + + erts_mtrace_install_wrapper_functions(); + extra_block_size += erts_instr_init(init.instr.stat, init.instr.map); + +#ifdef DEBUG + extra_block_size += install_debug_functions(); +#endif + +#ifdef ERTS_ALC_N_MIN_A_FIXED_SIZE + + erts_init_fix_alloc(extra_block_size, fix_core_alloc); + + +#if !defined(PURIFY) && !defined(VALGRIND) + erts_set_fix_size(ERTS_ALC_T_PROC, sizeof(Process)); + erts_set_fix_size(ERTS_ALC_T_DB_TABLE, sizeof(DbTable)); + erts_set_fix_size(ERTS_ALC_T_ATOM, sizeof(Atom)); + erts_set_fix_size(ERTS_ALC_T_EXPORT, sizeof(Export)); + erts_set_fix_size(ERTS_ALC_T_MODULE, sizeof(Module)); + erts_set_fix_size(ERTS_ALC_T_REG_PROC, sizeof(RegProc)); + erts_set_fix_size(ERTS_ALC_T_MONITOR_SH, ERTS_MONITOR_SH_SIZE*sizeof(Uint)); + erts_set_fix_size(ERTS_ALC_T_NLINK_SH, ERTS_LINK_SH_SIZE*sizeof(Uint)); + erts_set_fix_size(ERTS_ALC_T_FUN_ENTRY, sizeof(ErlFunEntry)); +#ifdef ERTS_ALC_T_DRV_EV_D_STATE + erts_set_fix_size(ERTS_ALC_T_DRV_EV_D_STATE, + sizeof(ErtsDrvEventDataState)); +#endif +#ifdef ERTS_ALC_T_DRV_SEL_D_STATE + erts_set_fix_size(ERTS_ALC_T_DRV_SEL_D_STATE, + sizeof(ErtsDrvSelectDataState)); +#endif +#endif +#endif + +} + +static void +set_au_allocator(ErtsAlcType_t alctr_n, struct au_init *init) +{ + ErtsAllocatorFunctions_t *af = &erts_allctrs[alctr_n]; + ErtsAllocatorInfo_t *ai = &erts_allctrs_info[alctr_n]; + ErtsAllocatorThrSpec_t *tspec = &erts_allctr_thr_spec[alctr_n]; + + if (!init->enable) { + af->alloc = erts_sys_alloc; + af->realloc = erts_sys_realloc; + af->free = erts_sys_free; + af->extra = NULL; + ai->alloc_util = 0; + ai->enabled = 0; + ai->extra = NULL; + return; + } + + tspec->enabled = 0; + tspec->all_thr_safe = 0; + ai->thr_spec = 0; +#ifdef USE_THREADS + if (init->thr_spec) { + if (init->thr_spec > 0) { + af->alloc = erts_alcu_alloc_thr_spec; + if (init->init.util.ramv) + af->realloc = erts_alcu_realloc_mv_thr_spec; + else + af->realloc = erts_alcu_realloc_thr_spec; + af->free = erts_alcu_free_thr_spec; + } + else { + af->alloc = erts_alcu_alloc_thr_pref; + if (init->init.util.ramv) + af->realloc = erts_alcu_realloc_mv_thr_pref; + else + af->realloc = erts_alcu_realloc_thr_pref; + af->free = erts_alcu_free_thr_pref; + tspec->all_thr_safe = 1; + } + + tspec->enabled = 1; + tspec->size = abs(init->thr_spec) + 1; + + ai->thr_spec = tspec->size; + } + else if (init->init.util.ts) { + af->alloc = erts_alcu_alloc_ts; + if (init->init.util.ramv) + af->realloc = erts_alcu_realloc_mv_ts; + else + af->realloc = erts_alcu_realloc_ts; + af->free = erts_alcu_free_ts; + } + else +#endif + { + af->alloc = erts_alcu_alloc; + if (init->init.util.ramv) + af->realloc = erts_alcu_realloc_mv; + else + af->realloc = erts_alcu_realloc; + af->free = erts_alcu_free; + } + af->extra = NULL; + ai->alloc_util = 1; + ai->enabled = 1; +} + +static void +start_au_allocator(ErtsAlcType_t alctr_n, + struct au_init *init, + ErtsAllocatorState_t *state) +{ + int i; + int size = 1; + void *as0; + enum allctr_type atype; + ErtsAllocatorFunctions_t *af = &erts_allctrs[alctr_n]; + ErtsAllocatorInfo_t *ai = &erts_allctrs_info[alctr_n]; + ErtsAllocatorThrSpec_t *tspec = &erts_allctr_thr_spec[alctr_n]; + + if (!init->enable) + return; + + if (init->thr_spec) { + void *states = erts_sys_alloc(0, + NULL, + ((sizeof(Allctr_t *) + * (tspec->size + 1)) + + (sizeof(ErtsAllocatorState_t) + * tspec->size) + + ERTS_CACHE_LINE_SIZE - 1)); + if (!states) + erl_exit(ERTS_ABORT_EXIT, + "Failed to allocate allocator states for %salloc\n", + init->init.util.name_prefix); + tspec->allctr = (Allctr_t **) states; + states = ((char *) states) + sizeof(Allctr_t *) * (tspec->size + 1); + states = ((((Uint) states) & ERTS_CACHE_LINE_MASK) + ? (void *) ((((Uint) states) & ~ERTS_CACHE_LINE_MASK) + + ERTS_CACHE_LINE_SIZE) + : (void *) states); + tspec->allctr[0] = init->thr_spec > 0 ? (Allctr_t *) state : (Allctr_t *) NULL; + size = tspec->size; + for (i = 1; i < size; i++) + tspec->allctr[i] = (Allctr_t *) + &((ErtsAllocatorState_t *) states)[i-1]; + } + + for (i = 0; i < size; i++) { + void *as; + atype = init->atype; + + if (!init->thr_spec) + as0 = state; + else { + as0 = (void *) tspec->allctr[i]; + if (!as0) + continue; + if (i == 0) { + if (atype == AFIT) + atype = GOODFIT; + init->init.util.ts = 1; + } + else { + if (init->thr_spec < 0) { + init->init.util.ts = 1; + init->init.util.tspec = 0; + init->init.util.tpref = -1*init->thr_spec; + } + else { + init->init.util.ts = 0; + init->init.util.tspec = init->thr_spec + 1; + init->init.util.tpref = 0; + } + } + } + + switch (atype) { + case GOODFIT: + as = (void *) erts_gfalc_start((GFAllctr_t *) as0, + &init->init.gf, + &init->init.util); + break; + case BESTFIT: + as = (void *) erts_bfalc_start((BFAllctr_t *) as0, + &init->init.bf, + &init->init.util); + break; + case AFIT: + as = (void *) erts_afalc_start((AFAllctr_t *) as0, + &init->init.af, + &init->init.util); + break; + default: + as = NULL; + ASSERT(0); + } + + if (!as) + erl_exit(ERTS_ABORT_EXIT, + "Failed to start %salloc\n", init->init.util.name_prefix); + + ASSERT(as == (void *) as0); + af->extra = as; + } + + if (init->thr_spec) { + af->extra = tspec; + init->init.util.ts = 1; + } + + ai->extra = af->extra; +} + + +static void bad_param(char *param_start, char *param_end) +{ + size_t len = param_end - param_start; + char param[100]; + if (len > 99) + len = 99; + sys_memcpy((void *) param, (void *) param_start, len); + param[len] = '\0'; + erts_fprintf(stderr, "bad \"%s\" parameter\n", param); + erts_usage(); +} + +static void bad_value(char *param_start, char *param_end, char *value) +{ + size_t len = param_end - param_start; + char param[100]; + if (len > 99) + len = 99; + sys_memcpy((void *) param, (void *) param_start, len); + param[len] = '\0'; + erts_fprintf(stderr, "bad \"%s\" value: %s\n", param, value); + erts_usage(); +} + +/* Get arg marks argument as handled by + putting NULL in argv */ +static char * +get_value(char* rest, char** argv, int* ip) +{ + char *param = argv[*ip]+1; + argv[*ip] = NULL; + if (*rest == '\0') { + char *next = argv[*ip + 1]; + if (next[0] == '-' + && next[1] == '-' + && next[2] == '\0') { + bad_value(param, rest, ""); + } + (*ip)++; + argv[*ip] = NULL; + return next; + } + return rest; +} + +static ERTS_INLINE int +has_prefix(const char *prefix, const char *string) +{ + int i; + for (i = 0; prefix[i]; i++) + if (prefix[i] != string[i]) + return 0; + return 1; +} + +static int +get_bool_value(char *param_end, char** argv, int* ip) +{ + char *param = argv[*ip]+1; + char *value = get_value(param_end, argv, ip); + if (strcmp(value, "true") == 0) + return 1; + else if (strcmp(value, "false") == 0) + return 0; + else + bad_value(param, param_end, value); + return -1; +} + +static Uint +get_kb_value(char *param_end, char** argv, int* ip) +{ + Sint tmp; + Uint max = ((~((Uint) 0))/1024) + 1; + char *rest; + char *param = argv[*ip]+1; + char *value = get_value(param_end, argv, ip); + errno = 0; + tmp = (Sint) strtol(value, &rest, 10); + if (errno != 0 || rest == value || tmp < 0 || max < ((Uint) tmp)) + bad_value(param, param_end, value); + if (max == (Uint) tmp) + return ~((Uint) 0); + else + return ((Uint) tmp)*1024; +} + +static Uint +get_amount_value(char *param_end, char** argv, int* ip) +{ + Sint tmp; + char *rest; + char *param = argv[*ip]+1; + char *value = get_value(param_end, argv, ip); + errno = 0; + tmp = (Sint) strtol(value, &rest, 10); + if (errno != 0 || rest == value || tmp < 0) + bad_value(param, param_end, value); + return (Uint) tmp; +} + +static int +get_bool_or_possitive_amount_value(int *bool, Uint *amount, + char *param_end, char** argv, int* ip) +{ + char *param = argv[*ip]+1; + char *value = get_value(param_end, argv, ip); + if (strcmp(value, "true") == 0) { + *bool = 1; + return 1; + } + else if (strcmp(value, "false") == 0) { + *bool = 0; + return 1; + } + else { + Sint tmp; + char *rest; + errno = 0; + tmp = (Sint) strtol(value, &rest, 10); + if (errno != 0 || rest == value || tmp <= 0) { + bad_value(param, param_end, value); + return -1; + } + *amount = (Uint) tmp; + return 0; + } +} + +static void +handle_au_arg(struct au_init *auip, + char* sub_param, + char** argv, + int* ip) +{ + char *param = argv[*ip]+1; + + switch (sub_param[0]) { + case 'a': + if(has_prefix("asbcst", sub_param)) { + auip->init.util.asbcst = get_kb_value(sub_param + 6, argv, ip); + } + else if(has_prefix("as", sub_param)) { + char *alg = get_value(sub_param + 2, argv, ip); + if (strcmp("bf", alg) == 0) { + auip->atype = BESTFIT; + auip->init.bf.ao = 0; + } + else if (strcmp("aobf", alg) == 0) { + auip->atype = BESTFIT; + auip->init.bf.ao = 1; + } + else if (strcmp("gf", alg) == 0) { + auip->atype = GOODFIT; + } + else if (strcmp("af", alg) == 0) { + auip->atype = AFIT; + } + else { + bad_value(param, sub_param + 1, alg); + } + } + else + goto bad_switch; + break; + case 'e': + auip->enable = get_bool_value(sub_param+1, argv, ip); + break; + case 'l': + if (has_prefix("lmbcs", sub_param)) { + auip->default_.lmbcs = 0; + auip->init.util.lmbcs = get_kb_value(sub_param + 5, argv, ip); + } + else + goto bad_switch; + break; + case 'm': + if (has_prefix("mbcgs", sub_param)) { + auip->init.util.mbcgs = get_amount_value(sub_param + 5, argv, ip); + + } + else if (has_prefix("mbsd", sub_param)) { + auip->init.gf.mbsd = get_amount_value(sub_param + 4, argv, ip); + if (auip->init.gf.mbsd < 1) + auip->init.gf.mbsd = 1; + } + else if (has_prefix("mmbcs", sub_param)) { + auip->default_.mmbcs = 0; + auip->init.util.mmbcs = get_kb_value(sub_param + 5, argv, ip); + } + else if (has_prefix("mmmbc", sub_param)) { + auip->default_.mmmbc = 0; + auip->init.util.mmmbc = get_amount_value(sub_param + 5, argv, ip); + } + else if (has_prefix("mmsbc", sub_param)) { + auip->init.util.mmsbc = get_amount_value(sub_param + 5, argv, ip); + } + else + goto bad_switch; + break; + case 'r': + if(has_prefix("rsbcmt", sub_param)) { + auip->init.util.rsbcmt = get_amount_value(sub_param + 6, argv, ip); + if (auip->init.util.rsbcmt > 100) + auip->init.util.rsbcmt = 100; + } + else if(has_prefix("rsbcst", sub_param)) { + auip->init.util.rsbcst = get_amount_value(sub_param + 6, argv, ip); + if (auip->init.util.rsbcst > 100) + auip->init.util.rsbcst = 100; + } + else if (has_prefix("rmbcmt", sub_param)) { + auip->init.util.rmbcmt = get_amount_value(sub_param + 6, argv, ip); + if (auip->init.util.rmbcmt > 100) + auip->init.util.rmbcmt = 100; + } + else if (has_prefix("ramv", sub_param)) { + auip->init.util.ramv = get_bool_value(sub_param + 4, argv, ip); + } + else + goto bad_switch; + break; + case 's': + if(has_prefix("sbct", sub_param)) { + auip->init.util.sbct = get_kb_value(sub_param + 4, argv, ip); + } + else if (has_prefix("smbcs", sub_param)) { + auip->default_.smbcs = 0; + auip->init.util.smbcs = get_kb_value(sub_param + 5, argv, ip); + } + else + goto bad_switch; + break; + case 't': { + Uint no; + int enable; + int res = get_bool_or_possitive_amount_value(&enable, + &no, + sub_param+1, + argv, + ip); + if (res > 0) + auip->thr_spec = enable ? 1 : 0; + else if (res == 0) { + int allocs = (int) no; + if (allocs < 0) + allocs = INT_MIN; + else { + allocs *= -1; + } + auip->thr_spec = allocs; + } + break; + } + default: + bad_switch: + bad_param(param, sub_param); + } +} + +static void +handle_args(int *argc, char **argv, erts_alc_hndl_args_init_t *init) +{ + struct au_init *aui[] = { + &init->binary_alloc, + &init->std_alloc, + &init->ets_alloc, + &init->eheap_alloc, + &init->ll_alloc, + &init->driver_alloc, + &init->sl_alloc, + &init->temp_alloc + }; + int aui_sz = (int) sizeof(aui)/sizeof(aui[0]); + char *arg; + char *rest; + int i, j; + + i = 1; + + ASSERT(argc && argv && init); + + while (i < *argc) { + if(argv[i][0] == '-') { + char *param = argv[i]+1; + switch (argv[i][1]) { + case 'M': + switch (argv[i][2]) { + case 'B': + handle_au_arg(&init->binary_alloc, &argv[i][3], argv, &i); + break; + case 'D': + handle_au_arg(&init->std_alloc, &argv[i][3], argv, &i); + break; + case 'E': + handle_au_arg(&init->ets_alloc, &argv[i][3], argv, &i); + break; + case 'F': /* fix_alloc */ + if (has_prefix("e", param+2)) { + arg = get_value(param+3, argv, &i); + if (strcmp("true", arg) != 0) + bad_value(param, param+3, arg); + } + else + bad_param(param, param+2); + break; + case 'H': + handle_au_arg(&init->eheap_alloc, &argv[i][3], argv, &i); + break; + case 'L': + handle_au_arg(&init->ll_alloc, &argv[i][3], argv, &i); + break; + case 'M': + if (has_prefix("amcbf", argv[i]+3)) { +#if HAVE_ERTS_MSEG + init->mseg.amcbf = +#endif + get_kb_value(argv[i]+8, argv, &i); + } + else if (has_prefix("rmcbf", argv[i]+3)) { +#if HAVE_ERTS_MSEG + init->mseg.rmcbf = +#endif + get_amount_value(argv[i]+8, argv, &i); + } + else if (has_prefix("mcs", argv[i]+3)) { +#if HAVE_ERTS_MSEG + init->mseg.mcs = +#endif + get_amount_value(argv[i]+6, argv, &i); + } + else if (has_prefix("cci", argv[i]+3)) { +#if HAVE_ERTS_MSEG + init->mseg.cci = +#endif + get_amount_value(argv[i]+6, argv, &i); + } + else { + bad_param(param, param+2); + } + break; + case 'R': + handle_au_arg(&init->driver_alloc, &argv[i][3], argv, &i); + break; + case 'S': + handle_au_arg(&init->sl_alloc, &argv[i][3], argv, &i); + break; + case 'T': + handle_au_arg(&init->temp_alloc, &argv[i][3], argv, &i); + break; + case 'Y': { /* sys_alloc */ + if (has_prefix("tt", param+2)) { + /* set trim threshold */ + arg = get_value(param+4, argv, &i); + errno = 0; + init->trim_threshold = (int) strtol(arg, &rest, 10); + if (errno != 0 + || rest == arg + || init->trim_threshold < 0 + || (INT_MAX/1024) < init->trim_threshold) { + bad_value(param, param+4, arg); + } + VERBOSE(DEBUG_SYSTEM, + ("using trim threshold: %d\n", + init->trim_threshold)); + init->trim_threshold *= 1024; + } + else if (has_prefix("tp", param+2)) { + /* set top pad */ + arg = get_value(param+4, argv, &i); + errno = 0; + init->top_pad = (int) strtol(arg, &rest, 10); + if (errno != 0 + || rest == arg + || init->top_pad < 0 + || (INT_MAX/1024) < init->top_pad) { + bad_value(param, param+4, arg); + } + VERBOSE(DEBUG_SYSTEM, + ("using top pad: %d\n",init->top_pad)); + init->top_pad *= 1024; + } + else if (has_prefix("m", param+2)) { + /* Has been handled by erlexec */ + (void) get_value(param+3, argv, &i); + } + else if (has_prefix("e", param+2)) { + arg = get_value(param+3, argv, &i); + if (strcmp("true", arg) != 0) + bad_value(param, param+3, arg); + } + else + bad_param(param, param+2); + break; + } + case 'e': + switch (argv[i][3]) { + case 'a': { + int a; + arg = get_value(argv[i]+4, argv, &i); + if (strcmp("min", arg) == 0) { + for (a = 0; a < aui_sz; a++) + aui[a]->enable = 0; + } + else if (strcmp("max", arg) == 0) { + for (a = 0; a < aui_sz; a++) + aui[a]->enable = 1; + } + else if (strcmp("config", arg) == 0) { + init->erts_alloc_config = 1; + } + else if (strcmp("r9c", arg) == 0 + || strcmp("r10b", arg) == 0 + || strcmp("r11b", arg) == 0) { + set_default_sl_alloc_opts(&init->sl_alloc); + set_default_std_alloc_opts(&init->std_alloc); + set_default_ll_alloc_opts(&init->ll_alloc); + set_default_temp_alloc_opts(&init->temp_alloc); + set_default_eheap_alloc_opts(&init->eheap_alloc); + set_default_binary_alloc_opts(&init->binary_alloc); + set_default_ets_alloc_opts(&init->ets_alloc); + set_default_driver_alloc_opts(&init->driver_alloc); + + init->driver_alloc.enable = 0; + if (strcmp("r9c", arg) == 0) { + init->sl_alloc.enable = 0; + init->std_alloc.enable = 0; + init->binary_alloc.enable = 0; + init->ets_alloc.enable = 0; + } + + for (a = 0; a < aui_sz; a++) { + aui[a]->thr_spec = 0; + aui[a]->init.util.ramv = 0; + aui[a]->init.util.mmmbc = 10; + aui[a]->init.util.lmbcs = 5*1024*1024; + } + } + else { + bad_param(param, param+3); + } + break; + } + default: + bad_param(param, param+1); + } + break; + case 'i': + switch (argv[i][3]) { + case 's': + arg = get_value(argv[i]+4, argv, &i); + if (strcmp("true", arg) == 0) + init->instr.stat = 1; + else if (strcmp("false", arg) == 0) + init->instr.stat = 0; + else + bad_value(param, param+3, arg); + break; + case 'm': + arg = get_value(argv[i]+4, argv, &i); + if (strcmp("true", arg) == 0) + init->instr.map = 1; + else if (strcmp("false", arg) == 0) + init->instr.map = 0; + else + bad_value(param, param+3, arg); + break; + case 't': + init->instr.mtrace = get_value(argv[i]+4, argv, &i); + break; + default: + bad_param(param, param+2); + } + break; + case 'u': + if (has_prefix("ycs", argv[i]+3)) { + init->alloc_util.ycs + = get_kb_value(argv[i]+6, argv, &i); + } + else if (has_prefix("mmc", argv[i]+3)) { + init->alloc_util.mmc + = get_amount_value(argv[i]+6, argv, &i); + } + else { + int a; + int start = i; + char *param = argv[i]; + char *val = i+1 < *argc ? argv[i+1] : NULL; + + for (a = 0; a < aui_sz; a++) { + if (a > 0) { + ASSERT(i == start || i == start+1); + argv[start] = param; + if (i != start) + argv[start + 1] = val; + i = start; + } + handle_au_arg(aui[a], &argv[i][3], argv, &i); + } + } + break; + default: + bad_param(param, param+1); + } + break; + case '-': + if (argv[i][2] == '\0') { + /* End of system flags reached */ + if (init->instr.mtrace + /* || init->instr.stat + || init->instr.map */) { + while (i < *argc) { + if(strcmp(argv[i], "-sname") == 0 + || strcmp(argv[i], "-name") == 0) { + if (i + 1 <*argc) { + init->instr.nodename = argv[i+1]; + break; + } + } + i++; + } + } + goto args_parsed; + } + break; + default: + break; + } + } + i++; + } + + args_parsed: + /* Handled arguments have been marked with NULL. Slide arguments + not handled towards the beginning of argv. */ + for (i = 0, j = 0; i < *argc; i++) { + if (argv[i]) + argv[j++] = argv[i]; + } + *argc = j; + +} + +static char *type_no_str(ErtsAlcType_t n) +{ + +#if ERTS_ALC_N_MIN != 0 + if (n < ERTS_ALC_N_MIN) + return NULL; +#endif + if (n > ERTS_ALC_N_MAX) + return NULL; + return (char *) ERTS_ALC_N2TD(n); +} + +#define type_str(T) type_no_str(ERTS_ALC_T2N((T))) + +erts_tsd_key_t thr_ix_key; +erts_spinlock_t alloc_thr_ix_lock; +int last_thr_ix; +int first_dyn_thr_ix; + +static void +init_thr_ix(int static_ixs) +{ + erts_tsd_key_create(&thr_ix_key); + erts_spinlock_init(&alloc_thr_ix_lock, "alloc_thr_ix_lock"); + last_thr_ix = -4711; + first_dyn_thr_ix = static_ixs+1; +} + +int +erts_alc_get_thr_ix(void) +{ + int ix = (int)(long) erts_tsd_get(thr_ix_key); + if (ix == 0) { + erts_spin_lock(&alloc_thr_ix_lock); + last_thr_ix++; + if (last_thr_ix < 0) + last_thr_ix = first_dyn_thr_ix; + ix = last_thr_ix; + erts_spin_unlock(&alloc_thr_ix_lock); + erts_tsd_set(thr_ix_key, (void *)(long) ix); + } + ASSERT(ix > 0); + return ix; +} + +void erts_alloc_reg_scheduler_id(Uint id) +{ + int ix = (int) id; + ASSERT(0 < ix && ix <= first_dyn_thr_ix); + ASSERT(0 == (int) (long) erts_tsd_get(thr_ix_key)); + erts_tsd_set(thr_ix_key, (void *)(long) ix); +} + +__decl_noreturn void +erts_alc_fatal_error(int error, int func, ErtsAlcType_t n, ...) +{ + char buf[10]; + char *t_str; + char *allctr_str; + + ASSERT(n >= ERTS_ALC_N_MIN); + ASSERT(n <= ERTS_ALC_N_MAX); + + + if (n < ERTS_ALC_N_MIN || ERTS_ALC_N_MAX < n) + allctr_str = "UNKNOWN"; + else { + ErtsAlcType_t a = ERTS_ALC_T2A(ERTS_ALC_N2T(n)); + if (erts_allctrs_info[a].enabled) + allctr_str = (char *) ERTS_ALC_A2AD(a); + else + allctr_str = (char *) ERTS_ALC_A2AD(ERTS_ALC_A_SYSTEM); + } + + t_str = type_no_str(n); + if (!t_str) { + sprintf(buf, "%d", (int) n); + t_str = buf; + } + + switch (error) { + case ERTS_ALC_E_NOTSUP: { + char *op_str; + switch (func) { + case ERTS_ALC_O_ALLOC: op_str = "alloc"; break; + case ERTS_ALC_O_REALLOC: op_str = "realloc"; break; + case ERTS_ALC_O_FREE: op_str = "free"; break; + default: op_str = "UNKNOWN"; break; + } + erl_exit(ERTS_ABORT_EXIT, + "%s: %s operation not supported (memory type: \"%s\")\n", + allctr_str, op_str, t_str); + break; + } + case ERTS_ALC_E_NOMEM: { + Uint size; + va_list argp; + char *op = func == ERTS_ALC_O_REALLOC ? "reallocate" : "allocate"; + + + va_start(argp, n); + size = va_arg(argp, Uint); + va_end(argp); + erl_exit(1, + "%s: Cannot %s %lu bytes of memory (of type \"%s\").\n", + allctr_str, op, size, t_str); + break; + } + case ERTS_ALC_E_NOALLCTR: + erl_exit(ERTS_ABORT_EXIT, + "erts_alloc: Unknown allocator type: %d\n", + ERTS_ALC_T2A(ERTS_ALC_N2T(n))); + break; + default: + erl_exit(ERTS_ABORT_EXIT, "erts_alloc: Unknown error: %d\n", error); + break; + } +} + +__decl_noreturn void +erts_alloc_enomem(ErtsAlcType_t type, Uint size) +{ + erts_alloc_n_enomem(ERTS_ALC_T2N(type), size); +} + +__decl_noreturn void +erts_alloc_n_enomem(ErtsAlcType_t n, Uint size) +{ + erts_alc_fatal_error(ERTS_ALC_E_NOMEM, ERTS_ALC_O_ALLOC, n, size); +} + +__decl_noreturn void +erts_realloc_enomem(ErtsAlcType_t type, void *ptr, Uint size) +{ + erts_realloc_n_enomem(ERTS_ALC_T2N(type), ptr, size); +} + +__decl_noreturn void +erts_realloc_n_enomem(ErtsAlcType_t n, void *ptr, Uint size) +{ + erts_alc_fatal_error(ERTS_ALC_E_NOMEM, ERTS_ALC_O_REALLOC, n, size); +} + +static ERTS_INLINE Uint +alcu_size(ErtsAlcType_t ai) +{ + Uint res = 0; + + ASSERT(erts_allctrs_info[ai].enabled); + ASSERT(erts_allctrs_info[ai].alloc_util); + + if (!erts_allctrs_info[ai].thr_spec) { + Allctr_t *allctr = erts_allctrs_info[ai].extra; + AllctrSize_t asize; + erts_alcu_current_size(allctr, &asize); + res += asize.blocks; + } + else { + ErtsAllocatorThrSpec_t *tspec = &erts_allctr_thr_spec[ai]; + int i; + + ASSERT(tspec->all_thr_safe); + + ASSERT(tspec->enabled); + + for (i = tspec->size - 1; i >= 0; i--) { + Allctr_t *allctr = tspec->allctr[i]; + AllctrSize_t asize; + if (allctr) { + erts_alcu_current_size(allctr, &asize); + res += asize.blocks; + } + } + } + + return res; +} + +Eterm +erts_memory(int *print_to_p, void *print_to_arg, void *proc, Eterm earg) +{ +#define ERTS_MEM_NEED_ALL_ALCU (!erts_instr_stat && want_tot_or_sys) + ErtsFixInfo efi; + struct { + int total; + int processes; + int processes_used; + int system; + int atom; + int atom_used; + int binary; + int code; + int ets; + int maximum; + } want = {0}; + struct { + Uint total; + Uint processes; + Uint processes_used; + Uint system; + Uint atom; + Uint atom_used; + Uint binary; + Uint code; + Uint ets; + Uint maximum; + } size = {0}; + Eterm atoms[sizeof(size)/sizeof(Uint)]; + Uint *uintps[sizeof(size)/sizeof(Uint)]; + Eterm euints[sizeof(size)/sizeof(Uint)]; + int need_atom; + int want_tot_or_sys; + int length; + Eterm res = THE_NON_VALUE; + ErtsAlcType_t ai; + int only_one_value = 0; + + /* Figure out whats wanted... */ + + length = 0; + if (is_non_value(earg)) { /* i.e. wants all */ + want.total = 1; + atoms[length] = am_total; + uintps[length++] = &size.total; + + want.processes = 1; + atoms[length] = am_processes; + uintps[length++] = &size.processes; + + want.processes_used = 1; + atoms[length] = am_processes_used; + uintps[length++] = &size.processes_used; + + want.system = 1; + atoms[length] = am_system; + uintps[length++] = &size.system; + + want.atom = 1; + atoms[length] = am_atom; + uintps[length++] = &size.atom; + + want.atom_used = 1; + atoms[length] = am_atom_used; + uintps[length++] = &size.atom_used; + + want.binary = 1; + atoms[length] = am_binary; + uintps[length++] = &size.binary; + + want.code = 1; + atoms[length] = am_code; + uintps[length++] = &size.code; + + want.ets = 1; + atoms[length] = am_ets; + uintps[length++] = &size.ets; + + want.maximum = erts_instr_stat; + if (want.maximum) { + atoms[length] = am_maximum; + uintps[length++] = &size.maximum; + } + + } + else { + Eterm tmp_heap[2]; + Eterm wanted_list; + + if (is_nil(earg)) + return NIL; + + if (is_not_atom(earg)) + wanted_list = earg; + else { + wanted_list = CONS(&tmp_heap[0], earg, NIL); + only_one_value = 1; + } + + while (is_list(wanted_list)) { + switch (CAR(list_val(wanted_list))) { + case am_total: + if (!want.total) { + want.total = 1; + atoms[length] = am_total; + uintps[length++] = &size.total; + } + break; + case am_processes: + if (!want.processes) { + want.processes = 1; + atoms[length] = am_processes; + uintps[length++] = &size.processes; + } + break; + case am_processes_used: + if (!want.processes_used) { + want.processes_used = 1; + atoms[length] = am_processes_used; + uintps[length++] = &size.processes_used; + } + break; + case am_system: + if (!want.system) { + want.system = 1; + atoms[length] = am_system; + uintps[length++] = &size.system; + } + break; + case am_atom: + if (!want.atom) { + want.atom = 1; + atoms[length] = am_atom; + uintps[length++] = &size.atom; + } + break; + case am_atom_used: + if (!want.atom_used) { + want.atom_used = 1; + atoms[length] = am_atom_used; + uintps[length++] = &size.atom_used; + } + break; + case am_binary: + if (!want.binary) { + want.binary = 1; + atoms[length] = am_binary; + uintps[length++] = &size.binary; + } + break; + case am_code: + if (!want.code) { + want.code = 1; + atoms[length] = am_code; + uintps[length++] = &size.code; + } + break; + case am_ets: + if (!want.ets) { + want.ets = 1; + atoms[length] = am_ets; + uintps[length++] = &size.ets; + } + break; + case am_maximum: + if (erts_instr_stat) { + if (!want.maximum) { + want.maximum = 1; + atoms[length] = am_maximum; + uintps[length++] = &size.maximum; + } + } + else + return am_badarg; + break; + default: + return am_badarg; + } + wanted_list = CDR(list_val(wanted_list)); + } + if (is_not_nil(wanted_list)) + return am_badarg; + } + + /* All alloc_util allocators *have* to be enabled */ + + for (ai = ERTS_ALC_A_MIN; ai <= ERTS_ALC_A_MAX; ai++) { + switch (ai) { + case ERTS_ALC_A_SYSTEM: + case ERTS_ALC_A_FIXED_SIZE: + break; + default: + if (!erts_allctrs_info[ai].enabled + || !erts_allctrs_info[ai].alloc_util) { + return am_notsup; + } + break; + } + } + + ASSERT(length <= sizeof(atoms)/sizeof(Eterm)); + ASSERT(length <= sizeof(euints)/sizeof(Eterm)); + ASSERT(length <= sizeof(uintps)/sizeof(Uint)); + + + if (proc) { + ERTS_SMP_LC_ASSERT(ERTS_PROC_LOCK_MAIN + == erts_proc_lc_my_proc_locks(proc)); + /* We'll need locks early in the lock order */ + erts_smp_proc_unlock(proc, ERTS_PROC_LOCK_MAIN); + } + + /* Calculate values needed... */ + + want_tot_or_sys = want.total || want.system; + need_atom = ERTS_MEM_NEED_ALL_ALCU || want.atom; + + if (ERTS_MEM_NEED_ALL_ALCU) { + size.total = 0; + + for (ai = ERTS_ALC_A_MIN; ai <= ERTS_ALC_A_MAX; ai++) { + if (erts_allctrs_info[ai].alloc_util) { + Uint *save; + Uint asz; + switch (ai) { + case ERTS_ALC_A_TEMPORARY: + /* + * Often not thread safe and usually never + * contain any allocated memory. + */ + continue; + case ERTS_ALC_A_EHEAP: + save = &size.processes; + break; + case ERTS_ALC_A_ETS: + save = &size.ets; + break; + case ERTS_ALC_A_BINARY: + save = &size.binary; + break; + default: + save = NULL; + break; + } + asz = alcu_size(ai); + if (save) + *save = asz; + size.total += asz; + } + } + } + + + + if (want_tot_or_sys || want.processes || want.processes_used) { + Uint tmp; + + if (ERTS_MEM_NEED_ALL_ALCU) + tmp = size.processes; + else + tmp = alcu_size(ERTS_ALC_A_EHEAP); + tmp += erts_max_processes*sizeof(Process*); +#ifdef HYBRID + tmp += erts_max_processes*sizeof(Process*); +#endif + tmp += erts_bif_timer_memory_size(); + tmp += erts_tot_link_lh_size(); + + size.processes = size.processes_used = tmp; + + erts_fix_info(ERTS_ALC_T_NLINK_SH, &efi); + size.processes += efi.total; + size.processes_used += efi.used; + + erts_fix_info(ERTS_ALC_T_MONITOR_SH, &efi); + size.processes += efi.total; + size.processes_used += efi.used; + + erts_fix_info(ERTS_ALC_T_PROC, &efi); + size.processes += efi.total; + size.processes_used += efi.used; + + erts_fix_info(ERTS_ALC_T_REG_PROC, &efi); + size.processes += efi.total; + size.processes_used += efi.used; + + } + + if (want.atom || want.atom_used) { + Uint reserved_atom_space, atom_space; + erts_atom_get_text_space_sizes(&reserved_atom_space, &atom_space); + size.atom = size.atom_used = atom_table_sz(); + erts_fix_info(ERTS_ALC_T_ATOM, &efi); + + if (want.atom) { + size.atom += reserved_atom_space; + size.atom += efi.total; + } + + if (want.atom_used) { + size.atom_used += atom_space; + size.atom_used += efi.used; + } + } + + if (!ERTS_MEM_NEED_ALL_ALCU && want.binary) + size.binary = alcu_size(ERTS_ALC_A_BINARY); + + if (want.code) { + size.code = module_table_sz(); + erts_fix_info(ERTS_ALC_T_MODULE, &efi); + size.code += efi.used; + size.code += export_table_sz(); + erts_fix_info(ERTS_ALC_T_EXPORT, &efi); + size.code += efi.used; + size.code += erts_fun_table_sz(); + erts_fix_info(ERTS_ALC_T_FUN_ENTRY, &efi); + size.code += efi.used; + size.code += allocated_modules*sizeof(Range); + size.code += erts_total_code_size; + } + + if (want.ets) { + if (!ERTS_MEM_NEED_ALL_ALCU) + size.ets = alcu_size(ERTS_ALC_A_ETS); + size.ets += erts_get_ets_misc_mem_size(); + } + + if (erts_instr_stat && (want_tot_or_sys || want.maximum)) { + if (want_tot_or_sys) { + size.total = erts_instr_get_total(); + size.system = size.total - size.processes; + } + size.maximum = erts_instr_get_max_total(); + } + else if (want_tot_or_sys) { + size.system = size.total - size.processes; + } + + if (print_to_p) { + int i; + int to = *print_to_p; + void *arg = print_to_arg; + + /* Print result... */ + erts_print(to, arg, "=memory\n"); + for (i = 0; i < length; i++) + erts_print(to, arg, "%T: %bpu\n", atoms[i], *uintps[i]); + } + + if (proc) { + /* Build erlang term result... */ + Uint *hp; + Uint hsz; + + erts_smp_proc_lock(proc, ERTS_PROC_LOCK_MAIN); + + if (only_one_value) { + ASSERT(length == 1); + hsz = 0; + erts_bld_uint(NULL, &hsz, *uintps[0]); + hp = hsz ? HAlloc((Process *) proc, hsz) : NULL; + res = erts_bld_uint(&hp, NULL, *uintps[0]); + } + else { + Uint **hpp = NULL; + Uint *hszp = &hsz; + hsz = 0; + + while (1) { + int i; + for (i = 0; i < length; i++) + euints[i] = erts_bld_uint(hpp, hszp, *uintps[i]); + res = erts_bld_2tup_list(hpp, hszp, length, atoms, euints); + if (hpp) + break; + hp = HAlloc((Process *) proc, hsz); + hpp = &hp; + hszp = NULL; + } + } + } + + return res; + +#undef ERTS_MEM_NEED_ALL_ALCU +} + +struct aa_values { + Uint arity; + const char *name; + Uint ui[2]; +}; + +Eterm +erts_allocated_areas(int *print_to_p, void *print_to_arg, void *proc) +{ +#define MAX_AA_VALUES \ + (20 + (ERTS_ALC_N_MAX_A_FIXED_SIZE - ERTS_ALC_N_MIN_A_FIXED_SIZE + 1)) + + struct aa_values values[MAX_AA_VALUES]; + Eterm res = THE_NON_VALUE; + int i, length; + ErtsFixInfo efi; + Uint reserved_atom_space, atom_space; + + if (proc) { + ERTS_SMP_LC_ASSERT(ERTS_PROC_LOCK_MAIN + == erts_proc_lc_my_proc_locks(proc)); + + /* We'll need locks early in the lock order */ + erts_smp_proc_unlock(proc, ERTS_PROC_LOCK_MAIN); + } + + i = 0; + + if (erts_instr_stat) { + values[i].arity = 2; + values[i].name = "total"; + values[i].ui[0] = erts_instr_get_total(); + i++; + + values[i].arity = 2; + values[i].name = "maximum"; + values[i].ui[0] = erts_instr_get_max_total(); + i++; + } + + values[i].arity = 2; + values[i].name = "sys_misc"; + values[i].ui[0] = erts_sys_misc_mem_sz(); + i++; + + values[i].arity = 2; + values[i].name = "static"; + values[i].ui[0] = + erts_max_ports*sizeof(Port) /* Port table */ + + erts_timer_wheel_memory_size() /* Timer wheel */ +#ifdef SYS_TMP_BUF_SIZE + + SYS_TMP_BUF_SIZE /* tmp_buf in sys on vxworks & ose */ +#endif + ; + i++; + + erts_atom_get_text_space_sizes(&reserved_atom_space, &atom_space); + + values[i].arity = 3; + values[i].name = "atom_space"; + values[i].ui[0] = reserved_atom_space; + values[i].ui[1] = atom_space; + i++; + + values[i].arity = 2; + values[i].name = "atom_table"; + values[i].ui[0] = atom_table_sz(); + i++; + + values[i].arity = 2; + values[i].name = "module_table"; + values[i].ui[0] = module_table_sz(); + i++; + + values[i].arity = 2; + values[i].name = "export_table"; + values[i].ui[0] = export_table_sz(); + i++; + + values[i].arity = 2; + values[i].name = "register_table"; + values[i].ui[0] = process_reg_sz(); + i++; + + values[i].arity = 2; + values[i].name = "fun_table"; + values[i].ui[0] = erts_fun_table_sz(); + i++; + + values[i].arity = 2; + values[i].name = "module_refs"; + values[i].ui[0] = allocated_modules*sizeof(Range); + i++; + + values[i].arity = 2; + values[i].name = "loaded_code"; + values[i].ui[0] = erts_total_code_size; + i++; + + values[i].arity = 2; + values[i].name = "dist_table"; + values[i].ui[0] = erts_dist_table_size(); + i++; + + values[i].arity = 2; + values[i].name = "node_table"; + values[i].ui[0] = erts_node_table_size(); + i++; + + values[i].arity = 2; + values[i].name = "bits_bufs_size"; + values[i].ui[0] = erts_bits_bufs_size(); + i++; + + values[i].arity = 2; + values[i].name = "bif_timer"; + values[i].ui[0] = erts_bif_timer_memory_size(); + i++; + + values[i].arity = 2; + values[i].name = "link_lh"; + values[i].ui[0] = erts_tot_link_lh_size(); + i++; + + { + Uint n; + + for (n = ERTS_ALC_N_MIN_A_FIXED_SIZE; + n <= ERTS_ALC_N_MAX_A_FIXED_SIZE; + n++) { + erts_fix_info(ERTS_ALC_N2T(n), &efi); + + values[i].arity = 3; + values[i].name = ERTS_ALC_N2TD(n); + values[i].ui[0] = efi.total; + values[i].ui[1] = efi.used; + i++; + } + + } + + length = i; + ASSERT(length <= MAX_AA_VALUES); + + if (print_to_p) { + /* Print result... */ + int to = *print_to_p; + void *arg = print_to_arg; + + erts_print(to, arg, "=allocated_areas\n"); + for (i = 0; i < length; i++) { + switch (values[i].arity) { + case 2: + erts_print(to, arg, "%s: %bpu\n", + values[i].name, values[i].ui[0]); + break; + case 3: + erts_print(to, arg, "%s: %bpu %bpu\n", + values[i].name, values[i].ui[0], values[i].ui[1]); + break; + default: + erts_print(to, arg, "ERROR: internal_error\n"); + ASSERT(0); + return am_internal_error; + } + } + } + + if (proc) { + /* Build erlang term result... */ + Eterm tuples[MAX_AA_VALUES]; + Uint *hp; + Uint **hpp; + Uint hsz; + Uint *hszp; + + erts_smp_proc_lock(proc, ERTS_PROC_LOCK_MAIN); + + hpp = NULL; + hsz = 0; + hszp = &hsz; + + while (1) { + int i; + for (i = 0; i < length; i++) { + Eterm atom; + if (hpp) + atom = am_atom_put(values[i].name, + (int) strlen(values[i].name)); + else + atom = am_true; + + switch (values[i].arity) { + case 2: + tuples[i] = erts_bld_tuple(hpp, hszp, 2, + atom, + erts_bld_uint(hpp, hszp, + values[i].ui[0])); + break; + case 3: + tuples[i] = erts_bld_tuple(hpp, hszp, 3, + atom, + erts_bld_uint(hpp, hszp, + values[i].ui[0]), + erts_bld_uint(hpp, hszp, + values[i].ui[1])); + break; + default: + ASSERT(0); + return am_internal_error; + } + } + res = erts_bld_list(hpp, hszp, length, tuples); + if (hpp) + break; + hp = HAlloc((Process *) proc, hsz); + hpp = &hp; + hszp = NULL; + } + } + + return res; +#undef MAX_AA_VALUES +} + +Eterm +erts_alloc_util_allocators(void *proc) +{ + Eterm res; + Uint *hp; + Uint sz; + int i; + /* + * Currently all allocators except sys_alloc and fix_alloc are + * alloc_util allocators. + */ + sz = ((ERTS_ALC_A_MAX + 1 - ERTS_ALC_A_MIN) - 2)*2; + ASSERT(sz > 0); + hp = HAlloc((Process *) proc, sz); + res = NIL; + for (i = ERTS_ALC_A_MAX; i >= ERTS_ALC_A_MIN; i--) { + switch (i) { + case ERTS_ALC_A_SYSTEM: + case ERTS_ALC_A_FIXED_SIZE: + break; + default: { + char *alc_str = (char *) ERTS_ALC_A2AD(i); + Eterm alc = am_atom_put(alc_str, sys_strlen(alc_str)); + res = CONS(hp, alc, res); + hp += 2; + break; + } + } + } + return res; +} + +Eterm +erts_allocator_info_term(void *proc, Eterm which_alloc, int only_sz) +{ +#define ERTS_AIT_RET(R) \ + do { res = (R); goto done; } while (0) +#define ERTS_AIT_HALLOC(P, S) \ + do { hp = HAlloc((P), (S)); hp_end = hp + (S); } while (0) + + ErtsAlcType_t i; + Uint sz = 0; + Uint *hp = NULL; + Uint *hp_end = NULL; + Eterm res = am_undefined; + + if (is_not_atom(which_alloc)) + goto done; + + for (i = ERTS_ALC_A_MIN; i <= ERTS_ALC_A_MAX; i++) { + if (erts_is_atom_str((char *) ERTS_ALC_A2AD(i), which_alloc)) { + if (!erts_allctrs_info[i].enabled) + ERTS_AIT_RET(am_false); + else { + if (erts_allctrs_info[i].alloc_util) { + Eterm ires, tmp; + Eterm **hpp; + Uint *szp; + Eterm (*info_func)(Allctr_t *, + int, + int *, + void *, + Uint **, + Uint *); + + info_func = (only_sz + ? erts_alcu_sz_info + : erts_alcu_info); + + if (erts_allctrs_info[i].thr_spec) { + ErtsAllocatorThrSpec_t *tspec = &erts_allctr_thr_spec[i]; + int j; + int block_system = !tspec->all_thr_safe; + + if (block_system) { + erts_smp_proc_unlock(proc, ERTS_PROC_LOCK_MAIN); + erts_smp_block_system(0); + } + ASSERT(tspec->enabled); + + szp = &sz; + hpp = NULL; + + while (1) { + ires = NIL; + for (j = tspec->size - 1; j >= 0; j--) { + Allctr_t *allctr = tspec->allctr[j]; + if (allctr) { + tmp = erts_bld_tuple(hpp, + szp, + 3, + erts_bld_atom(hpp, + szp, + "instance"), + make_small((Uint) j), + (*info_func)(allctr, + hpp != NULL, + NULL, + NULL, + hpp, + szp)); + ires = erts_bld_cons(hpp, szp, tmp, ires); + } + } + if (hpp) + break; + ERTS_AIT_HALLOC((Process *) proc, sz); + hpp = &hp; + szp = NULL; + } + + if (block_system) { + erts_smp_release_system(); + erts_smp_proc_lock(proc, ERTS_PROC_LOCK_MAIN); + } + } + else { + Allctr_t *allctr = erts_allctrs_info[i].extra; + szp = &sz; + hpp = NULL; + while (1) { + ires = NIL; + tmp = erts_bld_tuple(hpp, + szp, + 3, + erts_bld_atom(hpp, + szp, + "instance"), + make_small((Uint) 0), + (*info_func)(allctr, + hpp != NULL, + NULL, + NULL, + hpp, + szp)); + ires = erts_bld_cons(hpp, szp, tmp, ires); + if (hpp) + break; + ERTS_AIT_HALLOC((Process *) proc, sz); + hpp = &hp; + szp = NULL; + } + } + ERTS_AIT_RET(ires); + } + else { + Eterm *szp, **hpp; + + switch (i) { + case ERTS_ALC_A_SYSTEM: { + SysAllocStat sas; + Eterm opts_am; + Eterm opts; + Eterm as[4]; + Eterm ts[4]; + int l; + + if (only_sz) + ERTS_AIT_RET(NIL); + + sys_alloc_stat(&sas); + opts_am = am_atom_put("options", 7); + + szp = &sz; + hpp = NULL; + + restart_sys_alloc: + l = 0; + as[l] = am_atom_put("e", 1); + ts[l++] = am_true; +#ifdef ELIB_ALLOC_IS_CLIB + as[l] = am_atom_put("m", 1); + ts[l++] = am_atom_put("elib", 4); +#else + as[l] = am_atom_put("m", 1); + ts[l++] = am_atom_put("libc", 4); +#endif + if(sas.trim_threshold >= 0) { + as[l] = am_atom_put("tt", 2); + ts[l++] = erts_bld_uint(hpp, szp, + (Uint) sas.trim_threshold); + } + if(sas.top_pad >= 0) { + as[l] = am_atom_put("tp", 2); + ts[l++] = erts_bld_uint(hpp, szp, (Uint) sas.top_pad); + } + + opts = erts_bld_2tup_list(hpp, szp, l, as, ts); + res = erts_bld_2tup_list(hpp, szp, 1, &opts_am, &opts); + + if (szp) { + ERTS_AIT_HALLOC((Process *) proc, sz); + szp = NULL; + hpp = &hp; + goto restart_sys_alloc; + } + ERTS_AIT_RET(res); + } + case ERTS_ALC_A_FIXED_SIZE: { + ErtsAlcType_t n; + Eterm as[2], vs[2]; + + if (only_sz) + ERTS_AIT_RET(NIL); + + as[0] = am_atom_put("options", 7); + as[1] = am_atom_put("pools", 5); + + szp = &sz; + hpp = NULL; + + restart_fix_alloc: + + vs[0] = erts_bld_cons(hpp, szp, + erts_bld_tuple(hpp, szp, 2, + am_atom_put("e", + 1), + am_true), + NIL); + + vs[1] = NIL; + for (n = ERTS_ALC_N_MIN_A_FIXED_SIZE; + n <= ERTS_ALC_N_MAX_A_FIXED_SIZE; + n++) { + ErtsFixInfo efi; + erts_fix_info(ERTS_ALC_N2T(n), &efi); + + vs[1] = erts_bld_cons( + hpp, szp, + erts_bld_tuple( + hpp, szp, 3, + am_atom_put((char *) ERTS_ALC_N2TD(n), + strlen(ERTS_ALC_N2TD(n))), + erts_bld_uint(hpp, szp, efi.total), + erts_bld_uint(hpp, szp, efi.used)), + vs[1]); + + } + + res = erts_bld_2tup_list(hpp, szp, 2, as, vs); + if (szp) { + ERTS_AIT_HALLOC((Process *) proc, sz); + szp = NULL; + hpp = &hp; + goto restart_fix_alloc; + } + ERTS_AIT_RET(res); + } + default: + ASSERT(0); + goto done; + } + } + } + } + } + + if (ERTS_IS_ATOM_STR("mseg_alloc", which_alloc)) { +#if HAVE_ERTS_MSEG + if (only_sz) + ERTS_AIT_RET(NIL); + erts_mseg_info(NULL, NULL, 0, NULL, &sz); + if (sz) + ERTS_AIT_HALLOC((Process *) proc, sz); + ERTS_AIT_RET(erts_mseg_info(NULL, NULL, 1, &hp, NULL)); +#else + ERTS_AIT_RET(am_false); +#endif + + } + else if (ERTS_IS_ATOM_STR("alloc_util", which_alloc)) { + if (only_sz) + ERTS_AIT_RET(NIL); + erts_alcu_au_info_options(NULL, NULL, NULL, &sz); + if (sz) + ERTS_AIT_HALLOC((Process *) proc, sz); + ERTS_AIT_RET(erts_alcu_au_info_options(NULL, NULL, &hp, NULL)); + } + + done: + if (hp) { + ASSERT(hp_end >= hp); + HRelease((Process *) proc, hp_end, hp); + } + return res; + +#undef ERTS_AIT_RET +#undef ERTS_AIT_HALLOC +} + +void +erts_allocator_info(int to, void *arg) +{ + ErtsAlcType_t a; + + ERTS_SMP_LC_ASSERT(erts_smp_is_system_blocked(0) + || (ERTS_IS_CRASH_DUMPING + && erts_smp_is_system_blocked(ERTS_BS_FLG_ALLOW_GC))); + + for (a = ERTS_ALC_A_MIN; a <= ERTS_ALC_A_MAX; a++) { + int ai; + for (ai = 0; ai == 0 || ai < erts_allctrs_info[a].thr_spec; ai++) { + if (erts_allctrs_info[a].thr_spec) { + if (!erts_allctr_thr_spec[a].allctr[ai]) + continue; + erts_print(to, arg, "=allocator:%s[%d]\n", + ERTS_ALC_A2AD(a), ai); + } + else { + erts_print(to, arg, "=allocator:%s\n", ERTS_ALC_A2AD(a)); + } + if (!erts_allctrs_info[a].enabled) + erts_print(to, arg, "option e: false\n"); + else { + if (erts_allctrs_info[a].alloc_util) { + void *as; + if (!erts_allctrs_info[a].thr_spec) + as = erts_allctrs_info[a].extra; + else { + ASSERT(erts_allctr_thr_spec[a].enabled); + as = erts_allctr_thr_spec[a].allctr[ai]; + } + /* Binary alloc has its own thread safety... */ + erts_alcu_info(as, 0, &to, arg, NULL, NULL); + } + else { + switch (a) { + case ERTS_ALC_A_SYSTEM: { + SysAllocStat sas; + erts_print(to, arg, "option e: true\n"); +#ifdef ELIB_ALLOC_IS_CLIB + erts_print(to, arg, "option m: elib\n"); +#else + erts_print(to, arg, "option m: libc\n"); +#endif + sys_alloc_stat(&sas); + if(sas.trim_threshold >= 0) + erts_print(to, arg, "option tt: %d\n", sas.trim_threshold); + if(sas.top_pad >= 0) + erts_print(to, arg, "option tp: %d\n", sas.top_pad); + break; + } + case ERTS_ALC_A_FIXED_SIZE: { + ErtsAlcType_t n; + erts_print(to, arg, "option e: true\n"); + + for (n = ERTS_ALC_N_MIN_A_FIXED_SIZE; + n <= ERTS_ALC_N_MAX_A_FIXED_SIZE; + n++) { + ErtsFixInfo efi; + erts_fix_info(ERTS_ALC_N2T(n), &efi); + erts_print(to, arg, "%s: %lu %lu\n", + ERTS_ALC_N2TD(n), + efi.total, + efi.used); + } + break; + } + default: + ASSERT(0); + break; + } + } + } + } + } + +#if HAVE_ERTS_MSEG + erts_print(to, arg, "=allocator:mseg_alloc\n"); + erts_mseg_info(&to, arg, 0, NULL, NULL); +#endif + + erts_print(to, arg, "=allocator:alloc_util\n"); + erts_alcu_au_info_options(&to, arg, NULL, NULL); + + erts_print(to, arg, "=allocator:instr\n"); + erts_print(to, arg, "option m: %s\n", + erts_instr_memory_map ? "true" : "false"); + erts_print(to, arg, "option s: %s\n", + erts_instr_stat ? "true" : "false"); + erts_print(to, arg, "option t: %s\n", + erts_mtrace_enabled ? "true" : "false"); + +} + +Eterm +erts_allocator_options(void *proc) +{ +#if HAVE_ERTS_MSEG + int use_mseg = 0; +#endif + Uint sz, *szp, *hp, **hpp; + Eterm res, features, settings; + Eterm atoms[ERTS_ALC_A_MAX-ERTS_ALC_A_MIN+5]; + Uint terms[ERTS_ALC_A_MAX-ERTS_ALC_A_MIN+5]; + int a, length; + SysAllocStat sas; + Uint *endp = NULL; + + sys_alloc_stat(&sas); + + /* First find out the heap size needed ... */ + hpp = NULL; + szp = &sz; + sz = 0; + + bld_term: + + length = 0; + features = NIL; + settings = NIL; + + for (a = ERTS_ALC_A_MIN; a <= ERTS_ALC_A_MAX; a++) { + Eterm tmp = NIL; + atoms[length] = am_atom_put((char *) ERTS_ALC_A2AD(a), + strlen(ERTS_ALC_A2AD(a))); + if (erts_allctrs_info[a].enabled) { + if (erts_allctrs_info[a].alloc_util) { + Allctr_t *allctr; +#if HAVE_ERTS_MSEG + use_mseg++; +#endif + if (erts_allctr_thr_spec[a].enabled) + allctr = erts_allctr_thr_spec[a].allctr[1]; + else + allctr = erts_allctrs_info[a].extra; + tmp = erts_alcu_info_options(allctr, NULL, NULL, hpp, szp); + } + else { + int l = 0; + Eterm as[4]; + Eterm ts[4]; + + as[l] = am_atom_put("e", 1); + ts[l++] = am_true; + + switch (a) { + case ERTS_ALC_A_SYSTEM: +#ifdef ELIB_ALLOC_IS_CLIB + as[l] = am_atom_put("m", 1); + ts[l++] = am_atom_put("elib", 4); +#else + as[l] = am_atom_put("m", 1); + ts[l++] = am_atom_put("libc", 4); +#endif + if(sas.trim_threshold >= 0) { + as[l] = am_atom_put("tt", 2); + ts[l++] = erts_bld_uint(hpp, szp, + (Uint) sas.trim_threshold); + } + if(sas.top_pad >= 0) { + as[l] = am_atom_put("tp", 2); + ts[l++] = erts_bld_uint(hpp, szp, (Uint) sas.top_pad); + } + break; + default: + break; + } + + tmp = erts_bld_2tup_list(hpp, szp, l, as, ts); + + } + + } + else { + Eterm atom = am_atom_put("e", 1); + Eterm term = am_false; + tmp = erts_bld_2tup_list(hpp, szp, 1, &atom, &term); + } + + terms[length++] = tmp; + + } + +#if HAVE_ERTS_MSEG + if (use_mseg) { + atoms[length] = am_atom_put("mseg_alloc", 10); + terms[length++] = erts_mseg_info_options(NULL, NULL, hpp, szp); + } +#endif + + atoms[length] = am_atom_put("alloc_util", 10); + terms[length++] = erts_alcu_au_info_options(NULL, NULL, hpp, szp); + + { + Eterm o[3], v[3]; + o[0] = am_atom_put("m", 1); + v[0] = erts_instr_memory_map ? am_true : am_false; + o[1] = am_atom_put("s", 1); + v[1] = erts_instr_stat ? am_true : am_false; + o[2] = am_atom_put("t", 1); + v[2] = erts_mtrace_enabled ? am_true : am_false; + + atoms[length] = am_atom_put("instr", 5); + terms[length++] = erts_bld_2tup_list(hpp, szp, 3, o, v); + } + + settings = erts_bld_2tup_list(hpp, szp, length, atoms, terms); + + length = 0; + + for (a = ERTS_ALC_A_MIN; a <= ERTS_ALC_A_MAX; a++) { + if (erts_allctrs_info[a].enabled) { + terms[length++] = am_atom_put((char *) ERTS_ALC_A2AD(a), + strlen(ERTS_ALC_A2AD(a))); + } + } + +#if HAVE_ERTS_MSEG + if (use_mseg) + terms[length++] = am_atom_put("mseg_alloc", 10); +#endif + + features = length ? erts_bld_list(hpp, szp, length, terms) : NIL; + +#if defined(ELIB_ALLOC_IS_CLIB) + { + Eterm version; + int i; + int ver[5]; + i = sscanf(ERLANG_VERSION, + "%d.%d.%d.%d.%d", + &ver[0], &ver[1], &ver[2], &ver[3], &ver[4]); + + version = NIL; + for(i--; i >= 0; i--) + version = erts_bld_cons(hpp, szp, make_small(ver[i]), version); + + res = erts_bld_tuple(hpp, szp, 4, + am_elib_malloc, version, features, settings); + } +#elif defined(__GLIBC__) + { + Eterm AM_glibc = am_atom_put("glibc", 5); + Eterm version; + + version = erts_bld_cons(hpp, + szp, + make_small(__GLIBC__), +#ifdef __GLIBC_MINOR__ + erts_bld_cons(hpp, + szp, + make_small(__GLIBC_MINOR__), + NIL) +#else + NIL +#endif + ); + + res = erts_bld_tuple(hpp, szp, 4, + AM_glibc, version, features, settings); + } + +#else /* unknown allocator */ + + res = erts_bld_tuple(hpp, szp, 4, + am_undefined, NIL, features, settings); + +#endif + + if (szp) { + /* ... and then build the term */ + hp = HAlloc((Process *) proc, sz); + endp = hp + sz; + hpp = &hp; + szp = NULL; + goto bld_term; + } + + ASSERT(endp >= hp); + HRelease((Process *) proc, endp, hp); + + return res; +} + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *\ + * Deprecated functions * + * * + * These functions are still defined since "non-OTP linked in drivers" may * + * contain (illegal) calls to them. * +\* */ + +/* --- DO *NOT* USE THESE FUNCTIONS --- */ + +void *sys_alloc(Uint sz) +{ return erts_alloc_fnf(ERTS_ALC_T_UNDEF, sz); } +void *sys_realloc(void *ptr, Uint sz) +{ return erts_realloc_fnf(ERTS_ALC_T_UNDEF, ptr, sz); } +void sys_free(void *ptr) +{ erts_free(ERTS_ALC_T_UNDEF, ptr); } +void *safe_alloc(Uint sz) +{ return erts_alloc(ERTS_ALC_T_UNDEF, sz); } +void *safe_realloc(void *ptr, Uint sz) +{ return erts_realloc(ERTS_ALC_T_UNDEF, ptr, sz); } + + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *\ + * NOTE: erts_alc_test() is only supposed to be used for testing. * + * * + * Keep alloc_SUITE_data/allocator_test.h updated if changes are made * + * to erts_alc_test() * +\* */ +#define ERTS_ALC_TEST_ABORT erl_exit(ERTS_ABORT_EXIT, "%s:%d: Internal error\n") + +unsigned long erts_alc_test(unsigned long op, + unsigned long a1, + unsigned long a2, + unsigned long a3) +{ + switch (op >> 8) { + case 0x0: return erts_alcu_test(op, a1, a2); + case 0x1: return erts_gfalc_test(op, a1, a2); + case 0x2: return erts_bfalc_test(op, a1, a2); + case 0x3: return erts_afalc_test(op, a1, a2); + case 0x4: return erts_mseg_test(op, a1, a2, a3); + case 0xf: + switch (op) { + case 0xf00: +#ifdef USE_THREADS + if (((Allctr_t *) a1)->thread_safe) + return (unsigned long) erts_alcu_alloc_ts(ERTS_ALC_T_UNDEF, + (void *) a1, + (Uint) a2); + else +#endif + return (unsigned long) erts_alcu_alloc(ERTS_ALC_T_UNDEF, + (void *) a1, + (Uint) a2); + case 0xf01: +#ifdef USE_THREADS + if (((Allctr_t *) a1)->thread_safe) + return (unsigned long) erts_alcu_realloc_ts(ERTS_ALC_T_UNDEF, + (void *) a1, + (void *) a2, + (Uint) a3); + else +#endif + return (unsigned long) erts_alcu_realloc(ERTS_ALC_T_UNDEF, + (void *) a1, + (void *) a2, + (Uint) a3); + case 0xf02: +#ifdef USE_THREADS + if (((Allctr_t *) a1)->thread_safe) + erts_alcu_free_ts(ERTS_ALC_T_UNDEF, (void *) a1, (void *) a2); + else +#endif + erts_alcu_free(ERTS_ALC_T_UNDEF, (void *) a1, (void *) a2); + return 0; + case 0xf03: { + Allctr_t *allctr; + struct au_init init; + + SET_DEFAULT_ALLOC_OPTS(&init); + init.enable = 1; + init.atype = GOODFIT; + init.init.util.name_prefix = (char *) a1; + init.init.util.ts = a2 ? 1 : 0; + + if ((char **) a3) { + char **argv = (char **) a3; + int i = 0; + while (argv[i]) { + if (argv[i][0] == '-' && argv[i][1] == 't') + handle_au_arg(&init, &argv[i][2], argv, &i); + else + return (unsigned long) NULL; + i++; + } + } + + switch (init.atype) { + case GOODFIT: + allctr = erts_gfalc_start((GFAllctr_t *) + erts_alloc(ERTS_ALC_T_UNDEF, + sizeof(GFAllctr_t)), + &init.init.gf, + &init.init.util); + break; + case BESTFIT: + allctr = erts_bfalc_start((BFAllctr_t *) + erts_alloc(ERTS_ALC_T_UNDEF, + sizeof(BFAllctr_t)), + &init.init.bf, + &init.init.util); + break; + case AFIT: + allctr = erts_afalc_start((AFAllctr_t *) + erts_alloc(ERTS_ALC_T_UNDEF, + sizeof(AFAllctr_t)), + &init.init.af, + &init.init.util); + break; + default: + ASSERT(0); + allctr = NULL; + break; + } + + return (unsigned long) allctr; + } + case 0xf04: + erts_alcu_stop((Allctr_t *) a1); + erts_free(ERTS_ALC_T_UNDEF, (void *) a1); + break; +#ifdef USE_THREADS + case 0xf05: return (unsigned long) 1; + case 0xf06: return (unsigned long) ((Allctr_t *) a1)->thread_safe; +#ifdef ETHR_NO_FORKSAFETY + case 0xf07: return (unsigned long) 0; +#else + case 0xf07: return (unsigned long) ((Allctr_t *) a1)->thread_safe; +#endif + case 0xf08: { + ethr_mutex *mtx = erts_alloc(ERTS_ALC_T_UNDEF, sizeof(ethr_mutex)); + if (ethr_mutex_init(mtx) != 0) + ERTS_ALC_TEST_ABORT; + return (unsigned long) mtx; + } + case 0xf09: { + ethr_mutex *mtx = (ethr_mutex *) a1; + if (ethr_mutex_destroy(mtx) != 0) + ERTS_ALC_TEST_ABORT; + erts_free(ERTS_ALC_T_UNDEF, (void *) mtx); + break; + } + case 0xf0a: + if (ethr_mutex_lock((ethr_mutex *) a1) != 0) + ERTS_ALC_TEST_ABORT; + break; + case 0xf0b: + if (ethr_mutex_unlock((ethr_mutex *) a1) != 0) + ERTS_ALC_TEST_ABORT; + break; + case 0xf0c: { + ethr_cond *cnd = erts_alloc(ERTS_ALC_T_UNDEF, sizeof(ethr_cond)); + if (ethr_cond_init(cnd) != 0) + ERTS_ALC_TEST_ABORT; + return (unsigned long) cnd; + } + case 0xf0d: { + ethr_cond *cnd = (ethr_cond *) a1; + if (ethr_cond_destroy(cnd) != 0) + ERTS_ALC_TEST_ABORT; + erts_free(ERTS_ALC_T_UNDEF, (void *) cnd); + break; + } + case 0xf0e: + if (ethr_cond_broadcast((ethr_cond *) a1) != 0) + ERTS_ALC_TEST_ABORT; + break; + case 0xf0f: { + int res; + do { + res = ethr_cond_wait((ethr_cond *) a1, (ethr_mutex *) a2); + } while (res == EINTR); + if (res != 0) + ERTS_ALC_TEST_ABORT; + break; + } + case 0xf10: { + ethr_tid *tid = erts_alloc(ERTS_ALC_T_UNDEF, sizeof(ethr_tid)); +#ifdef ERTS_ENABLE_LOCK_COUNT + if (erts_lcnt_thr_create(tid, + (void * (*)(void *)) a1, + (void *) a2, + NULL) != 0) +#else + if (ethr_thr_create(tid, + (void * (*)(void *)) a1, + (void *) a2, + NULL) != 0) +#endif + ERTS_ALC_TEST_ABORT; + return (unsigned long) tid; + } + case 0xf11: { + ethr_tid *tid = (ethr_tid *) a1; + if (ethr_thr_join(*tid, NULL) != 0) + ERTS_ALC_TEST_ABORT; + erts_free(ERTS_ALC_T_UNDEF, (void *) tid); + break; + } + case 0xf12: + ethr_thr_exit((void *) a1); + ERTS_ALC_TEST_ABORT; + break; +#endif /* #ifdef USE_THREADS */ + default: + break; + } + return (unsigned long) 0; + default: + break; + } + + ASSERT(0); + return ~((unsigned long) 0); +} + +#ifdef DEBUG +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *\ + * Debug stuff * +\* */ + +#if 0 +#define PRINT_OPS +#else +#undef PRINT_OPS +#endif + + +#define FENCE_SZ (3*sizeof(Uint)) + +#ifdef ARCH_64 +#define FENCE_PATTERN 0xABCDEF97ABCDEF97 +#else +#define FENCE_PATTERN 0xABCDEF97 +#endif + +#define TYPE_PATTERN_MASK ERTS_ALC_N_MASK +#define TYPE_PATTERN_SHIFT 16 + +#define FIXED_FENCE_PATTERN_MASK \ + (~((Uint) (TYPE_PATTERN_MASK << TYPE_PATTERN_SHIFT))) +#define FIXED_FENCE_PATTERN \ + (FENCE_PATTERN & FIXED_FENCE_PATTERN_MASK) + +#define MK_PATTERN(T) \ + (FIXED_FENCE_PATTERN | (((T) & TYPE_PATTERN_MASK) << TYPE_PATTERN_SHIFT)) + +#define GET_TYPE_OF_PATTERN(P) \ + (((P) >> TYPE_PATTERN_SHIFT) & TYPE_PATTERN_MASK) + + +static void * +set_memory_fence(void *ptr, Uint sz, ErtsAlcType_t n) +{ + Uint *ui_ptr; + Uint pattern; + + if (!ptr) + return NULL; + + ui_ptr = (Uint *) ptr; + pattern = MK_PATTERN(n); + + *(ui_ptr++) = sz; + *(ui_ptr++) = pattern; + memcpy((void *) (((char *) ui_ptr)+sz), (void *) &pattern, sizeof(Uint)); + + return (void *) ui_ptr; +} + +static void * +check_memory_fence(void *ptr, Uint *size, ErtsAlcType_t n, int func) +{ + Uint sz; + Uint found_type; + Uint pre_pattern; + Uint post_pattern; + Uint *ui_ptr; + + if (!ptr) + return NULL; + + ui_ptr = (Uint *) ptr; + pre_pattern = *(--ui_ptr); + *size = sz = *(--ui_ptr); + + found_type = GET_TYPE_OF_PATTERN(pre_pattern); + if (pre_pattern != MK_PATTERN(n)) { + if ((FIXED_FENCE_PATTERN_MASK & pre_pattern) != FIXED_FENCE_PATTERN) + erl_exit(ERTS_ABORT_EXIT, + "ERROR: Fence at beginning of memory block (p=0x%u) " + "clobbered.\n", + (unsigned long) ptr); + } + + memcpy((void *) &post_pattern, (void *) (((char *)ptr)+sz), sizeof(Uint)); + + if (post_pattern != MK_PATTERN(n) + || pre_pattern != post_pattern) { + char fbuf[10]; + char obuf[10]; + char *ftype; + char *otype; + char *op_str; + + if ((FIXED_FENCE_PATTERN_MASK & post_pattern) != FIXED_FENCE_PATTERN) + erl_exit(ERTS_ABORT_EXIT, + "ERROR: Fence at end of memory block (p=0x%u, sz=%u) " + "clobbered.\n", + (unsigned long) ptr, (unsigned long) sz); + if (found_type != GET_TYPE_OF_PATTERN(post_pattern)) + erl_exit(ERTS_ABORT_EXIT, + "ERROR: Fence around memory block (p=0x%u, sz=%u) " + "clobbered.\n", + (unsigned long) ptr, (unsigned long) sz); + + ftype = type_no_str(found_type); + if (!ftype) { + sprintf(fbuf, "%d", (int) found_type); + ftype = fbuf; + } + otype = type_no_str(n); + if (!otype) { + sprintf(obuf, "%d", (int) n); + otype = obuf; + } + + switch (func) { + case ERTS_ALC_O_ALLOC: op_str = "allocated"; break; + case ERTS_ALC_O_REALLOC: op_str = "reallocated"; break; + case ERTS_ALC_O_FREE: op_str = "freed"; break; + default: op_str = "???"; break; + } + + erl_exit(ERTS_ABORT_EXIT, + "ERROR: Memory block (p=0x%u, sz=%u) allocated as type \"%s\"," + " but %s as type \"%s\".\n", + (unsigned long) ptr, (unsigned long) sz, ftype, op_str, otype); + } + + return (void *) ui_ptr; +} + +static ErtsAllocatorFunctions_t real_allctrs[ERTS_ALC_A_MAX+1]; + +static void * +debug_alloc(ErtsAlcType_t n, void *extra, Uint size) +{ + ErtsAllocatorFunctions_t *real_af = (ErtsAllocatorFunctions_t *) extra; + Uint dsize; + void *res; + + ASSERT(ERTS_ALC_N_MIN <= n && n <= ERTS_ALC_N_MAX); + dsize = size + FENCE_SZ; + res = (*real_af->alloc)(n, real_af->extra, dsize); + + res = set_memory_fence(res, size, n); + +#ifdef PRINT_OPS + fprintf(stderr, "0x%lx = alloc(%s, %lu)\r\n", + (Uint) res, ERTS_ALC_N2TD(n), size); +#endif + + return res; +} + + +static void * +debug_realloc(ErtsAlcType_t n, void *extra, void *ptr, Uint size) +{ + ErtsAllocatorFunctions_t *real_af = (ErtsAllocatorFunctions_t *) extra; + Uint dsize; + Uint old_size; + void *dptr; + void *res; + + ASSERT(ERTS_ALC_N_MIN <= n && n <= ERTS_ALC_N_MAX); + + dsize = size + FENCE_SZ; + dptr = check_memory_fence(ptr, &old_size, n, ERTS_ALC_O_REALLOC); + + if (old_size > size) + sys_memset((void *) (((char *) ptr) + size), + 0xf, + sizeof(Uint) + old_size - size); + + res = (*real_af->realloc)(n, real_af->extra, dptr, dsize); + + res = set_memory_fence(res, size, n); + +#ifdef PRINT_OPS + fprintf(stderr, "0x%lx = realloc(%s, 0x%lx, %lu)\r\n", + (Uint) res, ERTS_ALC_N2TD(n), (Uint) ptr, size); +#endif + + return res; +} + +static void +debug_free(ErtsAlcType_t n, void *extra, void *ptr) +{ + ErtsAllocatorFunctions_t *real_af = (ErtsAllocatorFunctions_t *) extra; + void *dptr; + Uint size; + + ASSERT(ERTS_ALC_N_MIN <= n && n <= ERTS_ALC_N_MAX); + + dptr = check_memory_fence(ptr, &size, n, ERTS_ALC_O_FREE); + + sys_memset((void *) dptr, n, size + FENCE_SZ); + + (*real_af->free)(n, real_af->extra, dptr); + +#ifdef PRINT_OPS + fprintf(stderr, "free(%s, 0x%lx)\r\n", ERTS_ALC_N2TD(n), (Uint) ptr); +#endif + +} + +static Uint +install_debug_functions(void) +{ + int i; + ASSERT(sizeof(erts_allctrs) == sizeof(real_allctrs)); + + sys_memcpy((void *)real_allctrs,(void *)erts_allctrs,sizeof(erts_allctrs)); + + for (i = ERTS_ALC_A_MIN; i <= ERTS_ALC_A_MAX; i++) { + erts_allctrs[i].alloc = debug_alloc; + erts_allctrs[i].realloc = debug_realloc; + erts_allctrs[i].free = debug_free; + erts_allctrs[i].extra = (void *) &real_allctrs[i]; + } + return FENCE_SZ; +} + + + +#endif /* #ifdef DEBUG */ diff --git a/erts/emulator/beam/erl_alloc.h b/erts/emulator/beam/erl_alloc.h new file mode 100644 index 0000000000..e7a203002f --- /dev/null +++ b/erts/emulator/beam/erl_alloc.h @@ -0,0 +1,564 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2002-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifndef ERL_ALLOC_H__ +#define ERL_ALLOC_H__ + +#include "erl_alloc_types.h" +#include "erl_alloc_util.h" +#ifdef USE_THREADS +#include "erl_threads.h" +#endif + +#ifdef DEBUG +# undef ERTS_ALC_WANT_INLINE +# define ERTS_ALC_WANT_INLINE 0 +#endif + +#ifndef ERTS_ALC_WANT_INLINE +# define ERTS_ALC_WANT_INLINE 1 +#endif + +#if ERTS_CAN_INLINE && ERTS_ALC_WANT_INLINE +# define ERTS_ALC_DO_INLINE 1 +# define ERTS_ALC_INLINE static ERTS_INLINE +#else +# define ERTS_ALC_DO_INLINE 0 +# define ERTS_ALC_INLINE +#endif + +#define ERTS_FIX_CORE_ALLOCATOR ERTS_ALC_A_LONG_LIVED +extern ErtsAlcType_t erts_fix_core_allocator_ix; + +typedef struct { + Uint total; + Uint used; +} ErtsFixInfo; + +void erts_sys_alloc_init(void); +void *erts_sys_alloc(ErtsAlcType_t, void *, Uint); +void *erts_sys_realloc(ErtsAlcType_t, void *, void *, Uint); +void erts_sys_free(ErtsAlcType_t, void *, void *); + + +void erts_init_fix_alloc(Uint, void *(*)(Uint)); +Uint erts_get_fix_size(ErtsAlcType_t); +void erts_set_fix_size(ErtsAlcType_t, Uint); +void erts_fix_info(ErtsAlcType_t, ErtsFixInfo *); +void *erts_fix_alloc(ErtsAlcType_t, void *, Uint); +void *erts_fix_realloc(ErtsAlcType_t, void *, void*, Uint); +void erts_fix_free(ErtsAlcType_t, void *, void*); + + +Eterm erts_memory(int *, void *, void *, Eterm); +Eterm erts_allocated_areas(int *, void *, void *); + +Eterm erts_alloc_util_allocators(void *proc); +void erts_allocator_info(int, void *); +Eterm erts_allocator_info_term(void *proc, Eterm which_alloc, int only_sz); +Eterm erts_allocator_options(void *proc); + +#define ERTS_ALLOC_INIT_DEF_OPTS_INITER {0} +typedef struct { + int dummy; +} ErtsAllocInitOpts; + +void erts_alloc_init(int *argc, char **argv, ErtsAllocInitOpts *eaiop); + +#if defined(GET_ERTS_ALC_TEST) || defined(ERTS_ALC_INTERNAL__) +/* Only for testing */ +unsigned long erts_alc_test(unsigned long, + unsigned long, + unsigned long, + unsigned long); +#endif + +#define ERTS_ALC_O_ALLOC 0 +#define ERTS_ALC_O_REALLOC 1 +#define ERTS_ALC_O_FREE 2 + +#define ERTS_ALC_E_NOTSUP 0 +#define ERTS_ALC_E_NOMEM 1 +#define ERTS_ALC_E_NOALLCTR 2 + +#define ERTS_ALC_MIN_LONG_LIVED_TIME (10*60*1000) + +typedef struct { + int alloc_util; + int enabled; + int thr_spec; + void *extra; +} ErtsAllocatorInfo_t; + +typedef struct { + void * (*alloc) (ErtsAlcType_t, void *, Uint); + void * (*realloc) (ErtsAlcType_t, void *, void *, Uint); + void (*free) (ErtsAlcType_t, void *, void *); + void *extra; +} ErtsAllocatorFunctions_t; + +extern ErtsAllocatorFunctions_t erts_allctrs[ERTS_ALC_A_MAX+1]; +extern ErtsAllocatorInfo_t erts_allctrs_info[ERTS_ALC_A_MAX+1]; + +typedef struct { + int enabled; + int all_thr_safe; + int size; + Allctr_t **allctr; +} ErtsAllocatorThrSpec_t; + +extern ErtsAllocatorThrSpec_t erts_allctr_thr_spec[ERTS_ALC_A_MAX+1]; + +int erts_alc_get_thr_ix(void); +void erts_alloc_reg_scheduler_id(Uint id); + +__decl_noreturn void erts_alloc_enomem(ErtsAlcType_t,Uint) + __noreturn; +__decl_noreturn void erts_alloc_n_enomem(ErtsAlcType_t,Uint) + __noreturn; +__decl_noreturn void erts_realloc_enomem(ErtsAlcType_t,void*,Uint) + __noreturn; +__decl_noreturn void erts_realloc_n_enomem(ErtsAlcType_t,void*,Uint) + __noreturn; +__decl_noreturn void erts_alc_fatal_error(int,int,ErtsAlcType_t,...) + __noreturn; + +/* --- DO *NOT* USE THESE DEPRECATED FUNCTIONS --- Instead use: */ +void *safe_alloc(Uint) __deprecated; /* erts_alloc() */ +void *safe_realloc(void *, Uint) __deprecated; /* erts_realloc() */ +void sys_free(void *) __deprecated; /* erts_free() */ +void *sys_alloc(Uint ) __deprecated; /* erts_alloc_fnf() */ +void *sys_realloc(void *, Uint) __deprecated; /* erts_realloc_fnf() */ + +/* + * erts_alloc[_fnf](), erts_realloc[_fnf](), erts_free() works as + * malloc(), realloc(), and free() with the following exceptions: + * + * * They take an extra type argument as first argument which is + * the memory type to operate on. Memory types are generated + * (as ERTS_ALC_T_[SOMETHING] defines) from the erl_alloc.types + * configuration file. + * * The erts_alloc() and erts_realloc() functions terminate the + * emulator if memory cannot be obtained. The _fnf (Failure Not + * Fatal) suffixed versions return NULL if memory cannot be + * obtained. + * * They may be static functions so function pointers to "the same" + * function may differ. + * + * IMPORTANT: Memory allocated or reallocated as type X, can only + * be reallocated or deallocated as type X. + */ + +#if !ERTS_ALC_DO_INLINE + +void *erts_alloc(ErtsAlcType_t type, Uint size); +void *erts_realloc(ErtsAlcType_t type, void *ptr, Uint size); +void erts_free(ErtsAlcType_t type, void *ptr); +void *erts_alloc_fnf(ErtsAlcType_t type, Uint size); +void *erts_realloc_fnf(ErtsAlcType_t type, void *ptr, Uint size); + +#endif /* #if !ERTS_ALC_DO_INLINE */ + +#if ERTS_ALC_DO_INLINE || defined(ERTS_ALC_INTERNAL__) + +ERTS_ALC_INLINE +void *erts_alloc(ErtsAlcType_t type, Uint size) +{ + void *res; + res = (*erts_allctrs[ERTS_ALC_T2A(type)].alloc)( + ERTS_ALC_T2N(type), + erts_allctrs[ERTS_ALC_T2A(type)].extra, + size); + if (!res) + erts_alloc_n_enomem(ERTS_ALC_T2N(type), size); + return res; +} + +ERTS_ALC_INLINE +void *erts_realloc(ErtsAlcType_t type, void *ptr, Uint size) +{ + void *res; + res = (*erts_allctrs[ERTS_ALC_T2A(type)].realloc)( + ERTS_ALC_T2N(type), + erts_allctrs[ERTS_ALC_T2A(type)].extra, + ptr, + size); + if (!res) + erts_realloc_n_enomem(ERTS_ALC_T2N(type), ptr, size); + return res; +} + +ERTS_ALC_INLINE +void erts_free(ErtsAlcType_t type, void *ptr) +{ + (*erts_allctrs[ERTS_ALC_T2A(type)].free)( + ERTS_ALC_T2N(type), + erts_allctrs[ERTS_ALC_T2A(type)].extra, + ptr); +} + + +ERTS_ALC_INLINE +void *erts_alloc_fnf(ErtsAlcType_t type, Uint size) +{ + return (*erts_allctrs[ERTS_ALC_T2A(type)].alloc)( + ERTS_ALC_T2N(type), + erts_allctrs[ERTS_ALC_T2A(type)].extra, + size); +} + + +ERTS_ALC_INLINE +void *erts_realloc_fnf(ErtsAlcType_t type, void *ptr, Uint size) +{ + return (*erts_allctrs[ERTS_ALC_T2A(type)].realloc)( + ERTS_ALC_T2N(type), + erts_allctrs[ERTS_ALC_T2A(type)].extra, + ptr, + size); +} + +#endif /* #if ERTS_ALC_DO_INLINE || defined(ERTS_ALC_INTERNAL__) */ + +#ifndef ERTS_CACHE_LINE_SIZE +/* Assume a cache line size of 64 bytes */ +# define ERTS_CACHE_LINE_SIZE ((Uint) 64) +# define ERTS_CACHE_LINE_MASK (ERTS_CACHE_LINE_SIZE - 1) +#endif + +#define ERTS_ALC_CACHE_LINE_ALIGN_SIZE(SZ) \ + (((((SZ) - 1) / ERTS_CACHE_LINE_SIZE) + 1) * ERTS_CACHE_LINE_SIZE) + +#define ERTS_QUALLOC_IMPL(NAME, TYPE, PASZ, ALCT) \ +ERTS_QUICK_ALLOC_IMPL(NAME, TYPE, PASZ, ALCT, \ + (void) 0, (void) 0, (void) 0) + +#define ERTS_SMP_QUALLOC_IMPL(NAME, TYPE, PASZ, ALCT) \ +static erts_smp_spinlock_t NAME##_lck; \ +ERTS_QUICK_ALLOC_IMPL(NAME, TYPE, PASZ, ALCT, \ + erts_smp_spinlock_init(&NAME##_lck, #NAME "_alloc_lock"),\ + erts_smp_spin_lock(&NAME##_lck), \ + erts_smp_spin_unlock(&NAME##_lck)) + +#ifdef ERTS_SMP + +#define ERTS_TS_QUALLOC_IMPL(NAME, TYPE, PASZ, ALCT) \ +ERTS_SMP_QUALLOC_IMPL(NAME, TYPE, PASZ, ALCT) + +#else /* !ERTS_SMP */ + +#define ERTS_TS_QUALLOC_IMPL(NAME, TYPE, PASZ, ALCT) \ +static erts_mtx_t NAME##_lck; \ +ERTS_QUICK_ALLOC_IMPL(NAME, TYPE, PASZ, ALCT, \ + erts_mtx_init(NAME##_lck, #NAME "_alloc_lock"), \ + erts_mtx_lock(&NAME##_lck), \ + erts_mtx_unlock(&NAME##_lck)) + + +#endif + +#define ERTS_PALLOC_IMPL(NAME, TYPE, PASZ) \ +ERTS_PRE_ALLOC_IMPL(NAME, TYPE, PASZ, (void) 0, (void) 0, (void) 0) + +#define ERTS_TS_PALLOC_IMPL(NAME, TYPE, PASZ) \ +static erts_spinlock_t NAME##_lck; \ +ERTS_PRE_ALLOC_IMPL(NAME, TYPE, PASZ, \ + erts_spinlock_init(&NAME##_lck, #NAME "_alloc_lock"),\ + erts_spin_lock(&NAME##_lck), \ + erts_spin_unlock(&NAME##_lck)) + +#ifdef ERTS_SMP + +#define ERTS_SMP_PALLOC_IMPL(NAME, TYPE, PASZ) \ + ERTS_TS_PALLOC_IMPL(NAME, TYPE, PASZ) + +#else /* !ERTS_SMP */ + +#define ERTS_SMP_PALLOC_IMPL(NAME, TYPE, PASZ) \ + ERTS_PALLOC_IMPL(NAME, TYPE, PASZ) + +#endif + +#define ERTS_QUICK_ALLOC_IMPL(NAME, TYPE, PASZ, ALCT, ILCK, LCK, ULCK) \ +ERTS_PRE_ALLOC_IMPL(NAME##_pre, TYPE, PASZ, ILCK, LCK, ULCK) \ +static void \ +init_##NAME##_alloc(void) \ +{ \ + init_##NAME##_pre_alloc(); \ +} \ +static ERTS_INLINE TYPE * \ +NAME##_alloc(void) \ +{ \ + TYPE *res = NAME##_pre_alloc(); \ + if (!res) \ + res = erts_alloc(ALCT, sizeof(TYPE)); \ + return res; \ +} \ +static ERTS_INLINE void \ +NAME##_free(TYPE *p) \ +{ \ + if (!NAME##_pre_free(p)) \ + erts_free(ALCT, (void *) p); \ +} + +#ifdef ERTS_SMP +#define ERTS_SCHED_PREF_PALLOC_IMPL(NAME, TYPE, PASZ) \ + ERTS_SCHED_PREF_PRE_ALLOC_IMPL(NAME, TYPE, PASZ) +#else +#define ERTS_SCHED_PREF_PALLOC_IMPL(NAME, TYPE, PASZ) \ + ERTS_PRE_ALLOC_IMPL(NAME, TYPE, PASZ, (void) 0, (void) 0, (void) 0) +#endif + +#ifdef ERTS_SMP +#define ERTS_SCHED_PREF_AUX(NAME, TYPE, PASZ) \ +ERTS_SCHED_PREF_PRE_ALLOC_IMPL(NAME##_pre, TYPE, PASZ) +#else +#define ERTS_SCHED_PREF_AUX(NAME, TYPE, PASZ) \ +ERTS_PRE_ALLOC_IMPL(NAME##_pre, TYPE, PASZ, (void) 0, (void) 0, (void) 0) +#endif + +#define ERTS_SCHED_PREF_QUICK_ALLOC_IMPL(NAME, TYPE, PASZ, ALCT) \ +ERTS_SCHED_PREF_AUX(NAME, TYPE, PASZ) \ +static void \ +init_##NAME##_alloc(void) \ +{ \ + init_##NAME##_pre_alloc(); \ +} \ +static ERTS_INLINE TYPE * \ +NAME##_alloc(void) \ +{ \ + TYPE *res = NAME##_pre_alloc(); \ + if (!res) \ + res = erts_alloc(ALCT, sizeof(TYPE)); \ + return res; \ +} \ +static ERTS_INLINE void \ +NAME##_free(TYPE *p) \ +{ \ + if (!NAME##_pre_free(p)) \ + erts_free(ALCT, (void *) p); \ +} + +#ifdef DEBUG +#define ERTS_PRE_ALLOC_SIZE(SZ) 2 +#define ERTS_PRE_ALLOC_CLOBBER(P, T) memset((void *) (P), 0xfd, sizeof(T)) +#else +#define ERTS_PRE_ALLOC_SIZE(SZ) ((SZ) > 1 ? (SZ) : 1) +#define ERTS_PRE_ALLOC_CLOBBER(P, T) +#endif + +#define ERTS_PRE_ALLOC_IMPL(NAME, TYPE, PASZ, ILCK, LCK, ULCK) \ +union erts_qa_##NAME##__ { \ + TYPE type; \ + union erts_qa_##NAME##__ *next; \ +}; \ +static union erts_qa_##NAME##__ \ + qa_prealcd_##NAME[ERTS_PRE_ALLOC_SIZE((PASZ))]; \ +static union erts_qa_##NAME##__ *qa_freelist_##NAME; \ +static void \ +init_##NAME##_alloc(void) \ +{ \ + int i; \ + qa_freelist_##NAME = &qa_prealcd_##NAME[0]; \ + for (i = 1; i < ERTS_PRE_ALLOC_SIZE((PASZ)); i++) { \ + ERTS_PRE_ALLOC_CLOBBER(&qa_prealcd_##NAME[i-1], \ + union erts_qa_##NAME##__); \ + qa_prealcd_##NAME[i-1].next = &qa_prealcd_##NAME[i]; \ + } \ + ERTS_PRE_ALLOC_CLOBBER(&qa_prealcd_##NAME[ERTS_PRE_ALLOC_SIZE((PASZ))-1],\ + union erts_qa_##NAME##__); \ + qa_prealcd_##NAME[ERTS_PRE_ALLOC_SIZE((PASZ))-1].next = NULL; \ + ILCK; \ +} \ +static ERTS_INLINE TYPE * \ +NAME##_alloc(void) \ +{ \ + TYPE *res; \ + LCK; \ + if (!qa_freelist_##NAME) \ + res = NULL; \ + else { \ + res = &qa_freelist_##NAME->type; \ + qa_freelist_##NAME = qa_freelist_##NAME->next; \ + } \ + ULCK; \ + return res; \ +} \ +static ERTS_INLINE int \ +NAME##_free(TYPE *p) \ +{ \ + union erts_qa_##NAME##__ * up; \ + up = ((union erts_qa_##NAME##__ *) \ + (((char *) p) \ + - ((char *) &((union erts_qa_##NAME##__ *) 0)->type))); \ + if (up > &qa_prealcd_##NAME[ERTS_PRE_ALLOC_SIZE((PASZ))-1] \ + || up < &qa_prealcd_##NAME[0]) \ + return 0; \ + else { \ + LCK; \ + ERTS_PRE_ALLOC_CLOBBER(up, union erts_qa_##NAME##__); \ + up->next = qa_freelist_##NAME; \ + qa_freelist_##NAME = up; \ + ULCK; \ + return 1; \ + } \ +} + +typedef struct { + void *start; + void *end; + int chunks_mem_size; +} erts_sched_pref_quick_alloc_data_t; + +#ifdef DEBUG +#define ERTS_SPPA_DBG_CHK_IN_CHNK(A, C, P) \ +do { \ + ASSERT((void *) (C) < (void *) (P)); \ + ASSERT((void *) (P) \ + < (void *) (((char *) (C)) + (A)->chunks_mem_size)); \ +} while (0) +#else +#define ERTS_SPPA_DBG_CHK_IN_CHNK(A, C, P) +#endif + +#define ERTS_SCHED_PREF_PRE_ALLOC_IMPL(NAME, TYPE, PASZ) \ +union erts_qa_##NAME##__ { \ + TYPE type; \ + union erts_qa_##NAME##__ *next; \ +}; \ +typedef struct { \ + erts_smp_spinlock_t lock; \ + union erts_qa_##NAME##__ *freelist; \ + union erts_qa_##NAME##__ pre_alloced[1]; \ +} erts_qa_##NAME##_chunk__; \ +static erts_sched_pref_quick_alloc_data_t *qa_data_##NAME##__; \ +static ERTS_INLINE erts_qa_##NAME##_chunk__ * \ +get_##NAME##_chunk_ix(int cix) \ +{ \ + char *ptr = (char *) qa_data_##NAME##__->start; \ + ptr += cix*qa_data_##NAME##__->chunks_mem_size; \ + return (erts_qa_##NAME##_chunk__ *) ptr; \ +} \ +static ERTS_INLINE erts_qa_##NAME##_chunk__ * \ +get_##NAME##_chunk_ptr(void *ptr) \ +{ \ + int cix; \ + size_t diff; \ + if (ptr < qa_data_##NAME##__->start || qa_data_##NAME##__->end <= ptr)\ + return NULL; \ + diff = ((char *) ptr) - ((char *) qa_data_##NAME##__->start); \ + cix = diff / qa_data_##NAME##__->chunks_mem_size; \ + return get_##NAME##_chunk_ix(cix); \ +} \ +static void \ +init_##NAME##_alloc(void) \ +{ \ + size_t tot_size; \ + size_t chunk_mem_size; \ + char *chunk_start; \ + int cix; \ + int no_blocks = ERTS_PRE_ALLOC_SIZE((PASZ)); \ + int no_blocks_per_chunk = 2*((no_blocks-1)/erts_no_schedulers + 1); \ + no_blocks = no_blocks_per_chunk * erts_no_schedulers; \ + chunk_mem_size = sizeof(erts_qa_##NAME##_chunk__); \ + chunk_mem_size += (sizeof(union erts_qa_##NAME##__) \ + * (no_blocks_per_chunk - 1)); \ + chunk_mem_size = ERTS_ALC_CACHE_LINE_ALIGN_SIZE(chunk_mem_size); \ + tot_size = sizeof(erts_sched_pref_quick_alloc_data_t); \ + tot_size += ERTS_CACHE_LINE_SIZE - 1; \ + tot_size += chunk_mem_size*erts_no_schedulers; \ + qa_data_##NAME##__ = erts_alloc(ERTS_ALC_T_PRE_ALLOC_DATA,tot_size);\ + chunk_start = (((char *) qa_data_##NAME##__) \ + + sizeof(erts_sched_pref_quick_alloc_data_t)); \ + if ((((Uint) chunk_start) & ERTS_CACHE_LINE_MASK) != ((Uint) 0)) \ + chunk_start = ((char *) \ + ((((Uint) chunk_start) & ~ERTS_CACHE_LINE_MASK) \ + + ERTS_CACHE_LINE_SIZE)); \ + qa_data_##NAME##__->chunks_mem_size = chunk_mem_size; \ + qa_data_##NAME##__->start = (void *) chunk_start; \ + qa_data_##NAME##__->end = (chunk_start \ + + chunk_mem_size*erts_no_schedulers); \ + for (cix = 0; cix < erts_no_schedulers; cix++) { \ + int i; \ + erts_qa_##NAME##_chunk__ *chunk = get_##NAME##_chunk_ix(cix); \ + erts_smp_spinlock_init(&chunk->lock, #NAME "_alloc_lock"); \ + chunk->freelist = &chunk->pre_alloced[0]; \ + for (i = 1; i < no_blocks_per_chunk; i++) { \ + ERTS_PRE_ALLOC_CLOBBER(&chunk->pre_alloced[i-1], \ + union erts_qa_##NAME##__); \ + chunk->pre_alloced[i-1].next = &chunk->pre_alloced[i]; \ + } \ + ERTS_PRE_ALLOC_CLOBBER(&chunk->pre_alloced[no_blocks_per_chunk-1],\ + union erts_qa_##NAME##__); \ + chunk->pre_alloced[no_blocks_per_chunk-1].next = NULL; \ + } \ +} \ +static ERTS_INLINE TYPE * \ +NAME##_alloc(void) \ +{ \ + int cix = ((int) erts_get_scheduler_id()) - 1; \ + TYPE *res; \ + if (cix < 0) \ + res = NULL; \ + else { \ + erts_qa_##NAME##_chunk__ *chunk = get_##NAME##_chunk_ix(cix); \ + erts_smp_spin_lock(&chunk->lock); \ + if (!chunk->freelist) \ + res = NULL; \ + else { \ + res = &chunk->freelist->type; \ + chunk->freelist = chunk->freelist->next; \ + ERTS_SPPA_DBG_CHK_IN_CHNK(qa_data_##NAME##__, chunk, res); \ + } \ + erts_smp_spin_unlock(&chunk->lock); \ + } \ + return res; \ +} \ +static ERTS_INLINE int \ +NAME##_free(TYPE *p) \ +{ \ + erts_qa_##NAME##_chunk__ *chunk; \ + chunk = get_##NAME##_chunk_ptr((void *) p); \ + if (!chunk) \ + return 0; \ + else { \ + union erts_qa_##NAME##__ *up; \ + ERTS_SPPA_DBG_CHK_IN_CHNK(qa_data_##NAME##__, chunk, p); \ + up = ((union erts_qa_##NAME##__ *) \ + (((char *) p) \ + - ((char *) &((union erts_qa_##NAME##__ *) 0)->type))); \ + erts_smp_spin_lock(&chunk->lock); \ + ERTS_PRE_ALLOC_CLOBBER(up, union erts_qa_##NAME##__); \ + up->next = chunk->freelist; \ + chunk->freelist = up; \ + erts_smp_spin_unlock(&chunk->lock); \ + return 1; \ + } \ +} + +#ifdef DEBUG +#define ERTS_ALC_DBG_BLK_SZ(PTR) (*(((Uint *) (PTR)) - 2)) +#endif /* #ifdef DEBUG */ + +#undef ERTS_ALC_INLINE +#undef ERTS_ALC_ATTRIBUTES + +#endif /* #ifndef ERL_ALLOC_H__ */ + + diff --git a/erts/emulator/beam/erl_alloc.types b/erts/emulator/beam/erl_alloc.types new file mode 100644 index 0000000000..f701f71c7d --- /dev/null +++ b/erts/emulator/beam/erl_alloc.types @@ -0,0 +1,383 @@ +# +# %CopyrightBegin% +# +# Copyright Ericsson AB 2003-2009. All Rights Reserved. +# +# The contents of this file are subject to the Erlang Public License, +# Version 1.1, (the "License"); you may not use this file except in +# compliance with the License. You should have received a copy of the +# Erlang Public License along with this software. If not, it can be +# retrieved online at http://www.erlang.org/. +# +# Software distributed under the License is distributed on an "AS IS" +# basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +# the License for the specific language governing rights and limitations +# under the License. +# +# %CopyrightEnd% +# + +# +# Rules: +# * Types, allocators, and classes can be declared. +# * Types, allocators, classes, and descriptions can only contain +# alphanumeric characters. +# * Allocators and classes have to be declared before they are used in +# type declarations. +# * Descriptions have only one name space (i.e. class descriptions, +# allocator descriptions, and type descriptions are all in the same +# name space). +# * Types, allocators, classes, and descriptions have different name +# spaces. +# * The type, allocator, and class names INVALID are reserved and can +# not be used. +# * The descriptions invalid_allocator, invalid_class, and invalid_type +# are reserved and can not be used. +# * Declarations can be done conditionally by use of a +# +if +# +# +else +# +# +endif +# or a +# +ifnot +# +# +else +# +# +endif +# construct (else branches are optional). The boolean variable X is +# true after a "+enable X" statement or if it has been passed as a +# command line argument to make_alloc_types. The variable X is false +# after a "+disable X" statement or if it has never been mentioned. + + +# --- Allocator declarations ------------------------------------------------- +# +# If, and only if, the same thread performes *all* allocations, +# reallocations and deallocations of all memory types that are handled +# by a specific allocator ( in type declaration), set +# for this specific allocator to false; otherwise, set +# it to true. +# +# Syntax: allocator +# +# + +allocator SYSTEM true sys_alloc + ++if smp + +allocator TEMPORARY true temp_alloc +allocator SHORT_LIVED true sl_alloc +allocator STANDARD true std_alloc +allocator LONG_LIVED true ll_alloc +allocator EHEAP true eheap_alloc +allocator ETS true ets_alloc +allocator FIXED_SIZE true fix_alloc + ++else # Non smp build + +allocator TEMPORARY false temp_alloc +allocator SHORT_LIVED false sl_alloc +allocator STANDARD false std_alloc +allocator LONG_LIVED false ll_alloc +allocator EHEAP false eheap_alloc +allocator ETS false ets_alloc +allocator FIXED_SIZE false fix_alloc + ++endif + +allocator BINARY true binary_alloc +allocator DRIVER true driver_alloc + + +# --- Class declarations ----------------------------------------------------- +# +# Syntax: class +# +# + +class PROCESSES process_data +class ATOM atom_data +class CODE code_data +class ETS ets_data +class BINARIES binary_data +class SYSTEM system_data + +# --- Type declarations ------------------------------------------------------ +# +# Syntax: type +# +# Use ERTS_ALC_T_ as first parameter to erts_alloc(), erts_alloc_fnf(), +# erts_realloc(), erts_realloc_fnf() or erts_free() in order to allocate, +# reallocate or deallocate a memory block of type . +# +# NOTE: Only use temp_alloc for memory types that *really* are *temporarily* +# allocated. A good thumb rule: all memory allocated by temp_alloc +# should be deallocated before the emulator starts executing Erlang +# code again. +# +# NOTE: When adding or removing a type which uses the FIXED_SIZE allocator, +# also add or remove initialization of the type in erts_alloc_init() +# (erl_alloc.c). +# +# + +type PROC FIXED_SIZE PROCESSES proc +type ATOM FIXED_SIZE ATOM atom_entry +type EXPORT FIXED_SIZE CODE export_entry +type MODULE FIXED_SIZE CODE module_entry +type REG_PROC FIXED_SIZE PROCESSES reg_proc +type LINK_LH STANDARD PROCESSES link_lh +type MONITOR_SH FIXED_SIZE PROCESSES monitor_sh +type MONITOR_LH STANDARD PROCESSES monitor_lh +type NLINK_SH FIXED_SIZE PROCESSES nlink_sh +type NLINK_LH STANDARD PROCESSES nlink_lh +type SUSPEND_MON STANDARD PROCESSES suspend_monitor +type PEND_SUSPEND SHORT_LIVED PROCESSES pending_suspend +type PROC_LIST SHORT_LIVED PROCESSES proc_list +type FUN_ENTRY FIXED_SIZE CODE fun_entry +type ATOM_TXT LONG_LIVED ATOM atom_text +type HEAP EHEAP PROCESSES heap +type OLD_HEAP EHEAP PROCESSES old_heap +type HEAP_FRAG EHEAP PROCESSES heap_frag +type TMP_HEAP TEMPORARY PROCESSES tmp_heap +type MSG_REF SHORT_LIVED PROCESSES msg_ref +type MSG_ROOTS TEMPORARY PROCESSES msg_roots +type ROOTSET TEMPORARY PROCESSES root_set +type LOADER_TMP TEMPORARY CODE loader_tmp +type BIF_TIMER_TABLE LONG_LIVED SYSTEM bif_timer_table +type SL_BIF_TIMER SHORT_LIVED PROCESSES bif_timer_sl +type LL_BIF_TIMER STANDARD PROCESSES bif_timer_ll +type REG_TABLE STANDARD SYSTEM reg_tab +type FUN_TABLE STANDARD CODE fun_tab +type DIST_TABLE STANDARD SYSTEM dist_tab +type NODE_TABLE STANDARD SYSTEM node_tab +type ATOM_TABLE LONG_LIVED ATOM atom_tab +type EXPORT_TABLE LONG_LIVED CODE export_tab +type MODULE_TABLE LONG_LIVED CODE module_tab +type TAINT LONG_LIVED CODE taint_list +type MODULE_REFS STANDARD CODE module_refs +type NC_TMP TEMPORARY SYSTEM nc_tmp +type TMP TEMPORARY SYSTEM tmp +type UNDEF SYSTEM SYSTEM undefined +type DCACHE STANDARD SYSTEM dcache +type DCTRL_BUF TEMPORARY SYSTEM dctrl_buf +type DIST_ENTRY STANDARD SYSTEM dist_entry +type NODE_ENTRY STANDARD SYSTEM node_entry +type PROC_TABLE LONG_LIVED PROCESSES proc_tab +type PORT_TABLE LONG_LIVED SYSTEM port_tab +type TIMER_WHEEL LONG_LIVED SYSTEM timer_wheel +type DRV DRIVER SYSTEM drv_internal +type DRV_BINARY BINARY BINARIES drv_binary +type DRIVER STANDARD SYSTEM driver +type NIF DRIVER SYSTEM nif_internal +type BINARY BINARY BINARIES binary +type NBIF_TABLE SYSTEM SYSTEM nbif_tab +type CODE LONG_LIVED CODE code +type ARG_REG STANDARD PROCESSES arg_reg +type PROC_DICT STANDARD PROCESSES proc_dict +type CALLS_BUF STANDARD PROCESSES calls_buf +type BPD STANDARD SYSTEM bpd +type PORT_NAME STANDARD SYSTEM port_name +type LINEBUF STANDARD SYSTEM line_buf +type IOQ STANDARD SYSTEM io_queue +type BITS_BUF STANDARD SYSTEM bits_buf +type TMP_DIST_BUF TEMPORARY SYSTEM tmp_dist_buf +type ASYNC_Q LONG_LIVED SYSTEM async_queue +type ESTACK TEMPORARY SYSTEM estack +type PORT_CALL_BUF TEMPORARY SYSTEM port_call_buf +type DB_TABLE FIXED_SIZE ETS db_tab +type DB_FIXATION SHORT_LIVED ETS db_fixation +type DB_FIX_DEL SHORT_LIVED ETS fixed_del +type DB_TABLES LONG_LIVED ETS db_tabs +type DB_NTAB_ENT STANDARD ETS db_named_table_entry +type DB_TMP TEMPORARY ETS db_tmp +type DB_MC_STK TEMPORARY ETS db_mc_stack +type DB_MS_PSDO_PROC LONG_LIVED ETS db_match_pseudo_proc +type DB_MS_RUN_HEAP SHORT_LIVED ETS db_match_spec_run_heap +type DB_MS_CMPL_HEAP TEMPORARY ETS db_match_spec_cmpl_heap +type DB_SEG ETS ETS db_segment +type DB_SEG_TAB ETS ETS db_segment_tab +type DB_STK ETS ETS db_stack +type DB_TRANS_TAB ETS ETS db_trans_tab +type DB_SEL_LIST ETS ETS db_select_list +type DB_DMC_ERROR ETS ETS db_dmc_error +type DB_DMC_ERR_INFO ETS ETS db_dmc_error_info +type DB_TERM ETS ETS db_term +type DB_PROC_CLEANUP SHORT_LIVED ETS db_proc_cleanup_state +type INSTR_INFO LONG_LIVED SYSTEM instr_info +type LOGGER_DSBUF TEMPORARY SYSTEM logger_dsbuf +type TMP_DSBUF TEMPORARY SYSTEM tmp_dsbuf +type INFO_DSBUF SYSTEM SYSTEM info_dsbuf +# INFO_DSBUF have to use the SYSTEM allocator; otherwise, a deadlock might occur +type SCHDLR_DATA LONG_LIVED PROCESSES scheduler_data +type RUNQS LONG_LIVED SYSTEM run_queues +type DDLL_PROCESS STANDARD SYSTEM ddll_processes +type DDLL_HANDLE STANDARD SYSTEM ddll_handle +type DDLL_ERRCODES LONG_LIVED SYSTEM ddll_errcodes +type DDLL_TMP_BUF TEMPORARY SYSTEM ddll_tmp_buf +type PORT_TASK SHORT_LIVED SYSTEM port_task +type PORT_TASKQ SHORT_LIVED SYSTEM port_task_queue +type MISC_OP_LIST SHORT_LIVED SYSTEM misc_op_list +type PORT_NAMES SHORT_LIVED SYSTEM port_names +type PORT_DATA_LOCK STANDARD SYSTEM port_data_lock +type NODES_MON STANDARD PROCESSES nodes_monitor +type PROCS_TPROC_EL SHORT_LIVED PROCESSES processes_term_proc_el +type PROCS_CNKINF SHORT_LIVED PROCESSES processes_chunk_info +type PROCS_PIDS SHORT_LIVED PROCESSES processes_pids +type RE_TMP_BUF TEMPORARY SYSTEM re_tmp_buf +type RE_SUBJECT SHORT_LIVED SYSTEM re_subject +type RE_HEAP STANDARD SYSTEM re_heap +type RE_STACK SHORT_LIVED SYSTEM re_stack +type UNICODE_BUFFER SHORT_LIVED SYSTEM unicode_buffer +type PRE_ALLOC_DATA LONG_LIVED SYSTEM pre_alloc_data +type DRV_THR_OPTS DRIVER SYSTEM driver_thread_opts +type DRV_TID DRIVER SYSTEM driver_tid +type DRV_MTX DRIVER SYSTEM driver_mutex +type DRV_CND DRIVER SYSTEM driver_cond +type DRV_RWLCK DRIVER SYSTEM driver_rwlock +type DRV_TSD DRIVER SYSTEM driver_tsd +type PSD STANDARD PROCESSES process_specific_data +type PRTSD STANDARD SYSTEM port_specific_data +type CPUDATA LONG_LIVED SYSTEM cpu_data +type TMP_CPU_IDS SHORT_LIVED SYSTEM tmp_cpu_ids +type EXT_TERM_DATA SHORT_LIVED PROCESSES external_term_data +type ZLIB STANDARD SYSTEM zlib + ++if smp +type ASYNC SHORT_LIVED SYSTEM async ++else +# sl_alloc is not thread safe in non smp build; therefore, we use driver_alloc +type ASYNC DRIVER SYSTEM async ++endif + ++if smp +type PORT_LOCK STANDARD SYSTEM port_lock +type DRIVER_LOCK STANDARD SYSTEM driver_lock +type XPORTS_LIST SHORT_LIVED SYSTEM extra_port_list +type PROC_LCK_WTR LONG_LIVED SYSTEM proc_lock_waiter +type PROC_LCK_QS LONG_LIVED SYSTEM proc_lock_queues +type RUNQ_BLNS LONG_LIVED SYSTEM run_queue_balancing ++endif + +# +# Types used for special emulators +# + ++if threads + +type ETHR_INTERNAL SYSTEM SYSTEM ethread_internal + ++ifnot smp + +type ARCALLBACK LONG_LIVED SYSTEM async_ready_callback + ++endif + ++endif + ++if shared_heap + +type STACK STANDARD PROCESSES stack +type ACTIVE_PROCS STANDARD PROCESSES active_procs + ++endif + ++if hybrid + +type ACTIVE_PROCS STANDARD PROCESSES active_procs + +# Used for all memory involved in incremental gc of the message area +# that is, young (x2) and old generation, forwarding pointers and blackmap +type MESSAGE_AREA LONG_LIVED PROCESSES message_area + +# Used in MA_STACK (global.h) and INC_STORAGE (erl_nmgc.h) +type OBJECT_STACK STANDARD PROCESSES object_stack + ++endif + ++if smp +type SL_PTIMER SHORT_LIVED SYSTEM ptimer_sl +type LL_PTIMER STANDARD SYSTEM ptimer_ll +type SYS_MSG_Q SHORT_LIVED PROCESSES system_messages_queue +type FP_EXCEPTION LONG_LIVED SYSTEM fp_exception ++endif + ++if hipe + +# Currently most hipe code use this type. +type HIPE SYSTEM SYSTEM hipe_data + ++endif + ++if heap_frag_elim_test + +type SSB SHORT_LIVED PROCESSES ssb + ++endif + + +# +# Types used by system specific code +# + +type DRV_TAB LONG_LIVED SYSTEM drv_tab +type DRV_EV_STATE LONG_LIVED SYSTEM driver_event_state +type DRV_EV_D_STATE FIXED_SIZE SYSTEM driver_event_data_state +type DRV_SEL_D_STATE FIXED_SIZE SYSTEM driver_select_data_state +type FD_LIST SHORT_LIVED SYSTEM fd_list +type POLLSET LONG_LIVED SYSTEM pollset +type POLLSET_UPDREQ SHORT_LIVED SYSTEM pollset_update_req +type POLL_FDS LONG_LIVED SYSTEM poll_fds +type POLL_RES_EVS LONG_LIVED SYSTEM poll_result_events +type FD_STATUS LONG_LIVED SYSTEM fd_status + ++if unix + +type SYS_READ_BUF TEMPORARY SYSTEM sys_read_buf +type FD_TAB LONG_LIVED SYSTEM fd_tab +type FD_ENTRY_BUF STANDARD SYSTEM fd_entry_buf +type CS_PROG_PATH LONG_LIVED SYSTEM cs_prog_path +type ENVIRONMENT TEMPORARY SYSTEM environment +type PUTENV_STR SYSTEM SYSTEM putenv_string +type PRT_REP_EXIT STANDARD SYSTEM port_report_exit + ++endif + ++if win32 + +type DRV_DATA_BUF SYSTEM SYSTEM drv_data_buf +type PRELOADED LONG_LIVED SYSTEM preloaded +type PUTENV_STR SYSTEM SYSTEM putenv_string +type WAITER_OBJ LONG_LIVED SYSTEM waiter_object +type ENVIRONMENT SYSTEM SYSTEM environment +type CON_VPRINTF_BUF TEMPORARY SYSTEM con_vprintf_buf + ++endif + ++if vxworks + +type SYS_TMP_BUF LONG_LIVED SYSTEM sys_tmp_buf +type PEND_DATA SYSTEM SYSTEM pending_data +type FD_TAB LONG_LIVED SYSTEM fd_tab +type FD_ENTRY_BUF SYSTEM SYSTEM fd_entry_buf + ++endif + ++if ose + +type SYS_TMP_BUF LONG_LIVED SYSTEM sys_tmp_buf +type PUTENV_STR SYSTEM SYSTEM putenv_string +type GETENV_STR SYSTEM SYSTEM getenv_string +type GETENV_STATE SYSTEM SYSTEM getenv_state +type SIG_ENTRY SYSTEM SYSTEM sig_entry +type DRIVER_DATA SYSTEM SYSTEM driver_data +type PGM_TAB SYSTEM SYSTEM pgm_tab +type PGM_ENTRY SYSTEM SYSTEM pgm_entry +type PRT_TAB SYSTEM SYSTEM prt_tab +type PRT_ENTRY SYSTEM SYSTEM prt_entry + ++endif + +# ---------------------------------------------------------------------------- diff --git a/erts/emulator/beam/erl_alloc_util.c b/erts/emulator/beam/erl_alloc_util.c new file mode 100644 index 0000000000..9b7bc24c1c --- /dev/null +++ b/erts/emulator/beam/erl_alloc_util.c @@ -0,0 +1,3467 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2002-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + + +/* + * Description: A memory allocator utility. This utility provides + * management of (multiple) memory segments, coalescing + * of free blocks, etc. Allocators are implemented by + * implementing a callback-interface which is called by + * this utility. The only task the callback-module has to + * perform is to supervise the free blocks. + * + * Author: Rickard Green + */ + +/* + * Alloc util will enforce 8 byte alignment if sys_alloc and mseg_alloc at + * least enforces 8 byte alignment. If sys_alloc only enforces 4 byte + * alignment then alloc util will do so too. + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "global.h" +#include "big.h" +#include "erl_mtrace.h" +#define GET_ERL_ALLOC_UTIL_IMPL +#include "erl_alloc_util.h" +#include "erl_mseg.h" +#include "erl_threads.h" + +#ifdef ERTS_ENABLE_LOCK_COUNT +#include "erl_lock_count.h" +#endif + +#if defined(ERTS_ALLOC_UTIL_HARD_DEBUG) && defined(__GNUC__) +#warning "* * * * * * * * * *" +#warning "* * * * * * * * * *" +#warning "* * NOTE: * *" +#warning "* * Hard debug * *" +#warning "* * is enabled! * *" +#warning "* * * * * * * * * *" +#warning "* * * * * * * * * *" +#endif + +#define ALLOC_ZERO_EQ_NULL 0 + +static int atoms_initialized = 0; +static int initialized = 0; + + +#if HAVE_ERTS_MSEG + +#define INV_MSEG_UNIT_MASK ((Uint) (mseg_unit_size - 1)) +#define MSEG_UNIT_MASK (~INV_MSEG_UNIT_MASK) +#define MSEG_UNIT_FLOOR(X) ((X) & MSEG_UNIT_MASK) +#define MSEG_UNIT_CEILING(X) MSEG_UNIT_FLOOR((X) + INV_MSEG_UNIT_MASK) + +#endif + +#define INV_SYS_ALLOC_CARRIER_MASK ((Uint) (sys_alloc_carrier_size - 1)) +#define SYS_ALLOC_CARRIER_MASK (~INV_SYS_ALLOC_CARRIER_MASK) +#define SYS_ALLOC_CARRIER_FLOOR(X) ((X) & SYS_ALLOC_CARRIER_MASK) +#define SYS_ALLOC_CARRIER_CEILING(X) \ + SYS_ALLOC_CARRIER_FLOOR((X) + INV_SYS_ALLOC_CARRIER_MASK) + +#undef ASSERT +#define ASSERT ASSERT_EXPR + +#define ERTS_ALCU_FLG_FAIL_REALLOC_MOVE ((Uint) 1) + +#if 0 +/* Can be useful for debugging */ +#define MBC_REALLOC_ALWAYS_MOVES +#endif + + +/* alloc_util global parameters */ +static Uint sys_alloc_carrier_size; +#if HAVE_ERTS_MSEG +static Uint max_mseg_carriers; +static Uint mseg_unit_size; +#endif + +#define ONE_GIGA (1000000000) + +#define INC_CC(CC) ((CC).no == ONE_GIGA - 1 \ + ? ((CC).giga_no++, (CC).no = 0) \ + : (CC).no++) + +#define DEC_CC(CC) ((CC).no == 0 \ + ? ((CC).giga_no--, (CC).no = ONE_GIGA - 1) \ + : (CC).no--) + +/* ... */ + +/* Blocks ... */ + +#define SBC_BLK_FTR_FLG (((Uint) 1) << 0) +#define UNUSED1_BLK_FTR_FLG (((Uint) 1) << 1) +#define UNUSED2_BLK_FTR_FLG (((Uint) 1) << 2) + +#define ABLK_HDR_SZ (sizeof(Block_t)) +#define FBLK_FTR_SZ (sizeof(Uint)) + +#define UMEMSZ2BLKSZ(AP, SZ) \ + (ABLK_HDR_SZ + (SZ) <= (AP)->min_block_size \ + ? (AP)->min_block_size \ + : UNIT_CEILING(ABLK_HDR_SZ + (SZ))) + +#define UMEM2BLK(P) ((Block_t *) (((char *) (P)) - ABLK_HDR_SZ)) +#define BLK2UMEM(P) ((void *) (((char *) (P)) + ABLK_HDR_SZ)) + +#define PREV_BLK_SZ(B) \ + ((Uint) (*(((Uint *) (B)) - 1) & SZ_MASK)) + +#define SET_BLK_SZ_FTR(B, SZ) \ + (*((Uint *) (((char *) (B)) + (SZ) - sizeof(Uint))) = (SZ)) + +#define THIS_FREE_BLK_HDR_FLG (((Uint) 1) << 0) +#define PREV_FREE_BLK_HDR_FLG (((Uint) 1) << 1) +#define LAST_BLK_HDR_FLG (((Uint) 1) << 2) + +#define SET_BLK_SZ(B, SZ) \ + (ASSERT(((SZ) & FLG_MASK) == 0), \ + (*((Block_t *) (B)) = ((*((Block_t *) (B)) & FLG_MASK) | (SZ)))) +#define SET_BLK_FREE(B) \ + (*((Block_t *) (B)) |= THIS_FREE_BLK_HDR_FLG) +#define SET_BLK_ALLOCED(B) \ + (*((Block_t *) (B)) &= ~THIS_FREE_BLK_HDR_FLG) +#define SET_PREV_BLK_FREE(B) \ + (*((Block_t *) (B)) |= PREV_FREE_BLK_HDR_FLG) +#define SET_PREV_BLK_ALLOCED(B) \ + (*((Block_t *) (B)) &= ~PREV_FREE_BLK_HDR_FLG) +#define SET_LAST_BLK(B) \ + (*((Block_t *) (B)) |= LAST_BLK_HDR_FLG) +#define SET_NOT_LAST_BLK(B) \ + (*((Block_t *) (B)) &= ~LAST_BLK_HDR_FLG) + +#define SBH_THIS_FREE THIS_FREE_BLK_HDR_FLG +#define SBH_THIS_ALLOCED ((Uint) 0) +#define SBH_PREV_FREE PREV_FREE_BLK_HDR_FLG +#define SBH_PREV_ALLOCED ((Uint) 0) +#define SBH_LAST_BLK LAST_BLK_HDR_FLG +#define SBH_NOT_LAST_BLK ((Uint) 0) + +#define SET_BLK_HDR(B, Sz, F) \ + (ASSERT(((Sz) & FLG_MASK) == 0), *((Block_t *) (B)) = ((Sz) | (F))) + +#define BLK_UMEM_SZ(B) \ + (BLK_SZ(B) - (ABLK_HDR_SZ)) +#define IS_PREV_BLK_FREE(B) \ + (*((Block_t *) (B)) & PREV_FREE_BLK_HDR_FLG) +#define IS_PREV_BLK_ALLOCED(B) \ + (!IS_PREV_BLK_FREE((B))) +#define IS_FREE_BLK(B) \ + (*((Block_t *) (B)) & THIS_FREE_BLK_HDR_FLG) +#define IS_ALLOCED_BLK(B) \ + (!IS_FREE_BLK((B))) +#define IS_LAST_BLK(B) \ + (*((Block_t *) (B)) & LAST_BLK_HDR_FLG) +#define IS_NOT_LAST_BLK(B) \ + (!IS_LAST_BLK((B))) + +#define GET_LAST_BLK_HDR_FLG(B) \ + (*((Block_t*) (B)) & LAST_BLK_HDR_FLG) +#define GET_THIS_FREE_BLK_HDR_FLG(B) \ + (*((Block_t*) (B)) & THIS_FREE_BLK_HDR_FLG) +#define GET_PREV_FREE_BLK_HDR_FLG(B) \ + (*((Block_t*) (B)) & PREV_FREE_BLK_HDR_FLG) +#define GET_BLK_HDR_FLGS(B) \ + (*((Block_t*) (B)) & FLG_MASK) + +#define IS_FIRST_BLK(B) \ + (IS_PREV_BLK_FREE((B)) && (PREV_BLK_SZ((B)) == 0)) +#define IS_NOT_FIRST_BLK(B) \ + (!IS_FIRST_BLK((B))) + +#define SET_SBC_BLK_FTR(FTR) \ + ((FTR) = (0 | SBC_BLK_FTR_FLG)) +#define SET_MBC_BLK_FTR(FTR) \ + ((FTR) = 0) + +#define IS_SBC_BLK(B) \ + (IS_PREV_BLK_FREE((B)) && (((Uint *) (B))[-1] & SBC_BLK_FTR_FLG)) +#define IS_MBC_BLK(B) \ + (!IS_SBC_BLK((B))) + +#define NXT_BLK(B) \ + ((Block_t *) (((char *) (B)) + BLK_SZ((B)))) +#define PREV_BLK(B) \ + ((Block_t *) (((char *) (B)) - PREV_BLK_SZ((B)))) + +/* Carriers ... */ + +#define MSEG_CARRIER_HDR_FLAG (((Uint) 1) << 0) +#define SBC_CARRIER_HDR_FLAG (((Uint) 1) << 1) + +#define SCH_SYS_ALLOC 0 +#define SCH_MSEG MSEG_CARRIER_HDR_FLAG +#define SCH_MBC 0 +#define SCH_SBC SBC_CARRIER_HDR_FLAG + +#define SET_CARRIER_HDR(C, Sz, F) \ + (ASSERT(((Sz) & FLG_MASK) == 0), (C)->chdr = ((Sz) | (F))) + +#define BLK2SBC(AP, B) \ + ((Carrier_t *) (((char *) (B)) - (AP)->sbc_header_size)) +#define FBLK2MBC(AP, B) \ + ((Carrier_t *) (((char *) (B)) - (AP)->mbc_header_size)) + +#define MBC2FBLK(AP, P) \ + ((Block_t *) (((char *) (P)) + (AP)->mbc_header_size)) +#define SBC2BLK(AP, P) \ + ((Block_t *) (((char *) (P)) + (AP)->sbc_header_size)) +#define SBC2UMEM(AP, P) \ + ((void *) (((char *) (P)) + ((AP)->sbc_header_size + ABLK_HDR_SZ))) + +#define IS_MSEG_CARRIER(C) \ + ((C)->chdr & MSEG_CARRIER_HDR_FLAG) +#define IS_SYS_ALLOC_CARRIER(C) \ + (!IS_MSEG_CARRIER((C))) +#define IS_SB_CARRIER(C) \ + ((C)->chdr & SBC_CARRIER_HDR_FLAG) +#define IS_MB_CARRIER(C) \ + (!IS_SB_CARRIER((C))) + +#define SET_MSEG_CARRIER(C) \ + ((C)->chdr |= MSEG_CARRIER_HDR_FLAG) +#define SET_SYS_ALLOC_CARRIER(C) \ + ((C)->chdr &= ~MSEG_CARRIER_HDR_FLAG) +#define SET_SB_CARRIER(C) \ + ((C)->chdr |= SBC_CARRIER_HDR_FLAG) +#define SET_MB_CARRIER(C) \ + ((C)->chdr &= ~SBC_CARRIER_HDR_FLAG) + +#define SET_CARRIER_SZ(C, SZ) \ + (ASSERT(((SZ) & FLG_MASK) == 0), \ + ((C)->chdr = ((C)->chdr & FLG_MASK) | (SZ))) + +#define CFLG_SBC (1 << 0) +#define CFLG_MBC (1 << 1) +#define CFLG_FORCE_MSEG (1 << 2) +#define CFLG_FORCE_SYS_ALLOC (1 << 3) +#define CFLG_FORCE_SIZE (1 << 4) +#define CFLG_MAIN_CARRIER (1 << 5) + +#ifdef ERTS_ALLOC_UTIL_HARD_DEBUG +static void check_blk_carrier(Allctr_t *, Block_t *); +#define HARD_CHECK_BLK_CARRIER(A, B) check_blk_carrier((A), (B)) +#else +#define HARD_CHECK_BLK_CARRIER(A, B) +#endif + + +/* Statistics updating ... */ + +#ifdef DEBUG +#define DEBUG_CHECK_CARRIER_NO_SZ(AP) \ + ASSERT(((AP)->sbcs.curr_mseg.no && (AP)->sbcs.curr_mseg.size) \ + || (!(AP)->sbcs.curr_mseg.no && !(AP)->sbcs.curr_mseg.size));\ + ASSERT(((AP)->sbcs.curr_sys_alloc.no && (AP)->sbcs.curr_sys_alloc.size)\ + || (!(AP)->sbcs.curr_sys_alloc.no && !(AP)->sbcs.curr_sys_alloc.size));\ + ASSERT(((AP)->mbcs.curr_mseg.no && (AP)->mbcs.curr_mseg.size) \ + || (!(AP)->mbcs.curr_mseg.no && !(AP)->mbcs.curr_mseg.size));\ + ASSERT(((AP)->mbcs.curr_sys_alloc.no && (AP)->mbcs.curr_sys_alloc.size)\ + || (!(AP)->mbcs.curr_sys_alloc.no && !(AP)->mbcs.curr_sys_alloc.size)) + +#else +#define DEBUG_CHECK_CARRIER_NO_SZ(AP) +#endif + +#define STAT_SBC_ALLOC(AP, BSZ) \ + (AP)->sbcs.blocks.curr.size += (BSZ); \ + if ((AP)->sbcs.blocks.max.size < (AP)->sbcs.blocks.curr.size) \ + (AP)->sbcs.blocks.max.size = (AP)->sbcs.blocks.curr.size; \ + if ((AP)->sbcs.max.no < ((AP)->sbcs.curr_mseg.no \ + + (AP)->sbcs.curr_sys_alloc.no)) \ + (AP)->sbcs.max.no = ((AP)->sbcs.curr_mseg.no \ + + (AP)->sbcs.curr_sys_alloc.no); \ + if ((AP)->sbcs.max.size < ((AP)->sbcs.curr_mseg.size \ + + (AP)->sbcs.curr_sys_alloc.size)) \ + (AP)->sbcs.max.size = ((AP)->sbcs.curr_mseg.size \ + + (AP)->sbcs.curr_sys_alloc.size) + +#define STAT_MSEG_SBC_ALLOC(AP, CSZ, BSZ) \ +do { \ + (AP)->sbcs.curr_mseg.no++; \ + (AP)->sbcs.curr_mseg.size += (CSZ); \ + STAT_SBC_ALLOC((AP), (BSZ)); \ + DEBUG_CHECK_CARRIER_NO_SZ((AP)); \ +} while (0) + +#define STAT_SYS_ALLOC_SBC_ALLOC(AP, CSZ, BSZ) \ +do { \ + (AP)->sbcs.curr_sys_alloc.no++; \ + (AP)->sbcs.curr_sys_alloc.size += (CSZ); \ + STAT_SBC_ALLOC((AP), (BSZ)); \ + DEBUG_CHECK_CARRIER_NO_SZ((AP)); \ +} while (0) + + +#define STAT_SBC_FREE(AP, BSZ) \ + ASSERT((AP)->sbcs.blocks.curr.size >= (BSZ)); \ + (AP)->sbcs.blocks.curr.size -= (BSZ) + +#define STAT_MSEG_SBC_FREE(AP, CSZ, BSZ) \ +do { \ + ASSERT((AP)->sbcs.curr_mseg.no > 0); \ + (AP)->sbcs.curr_mseg.no--; \ + ASSERT((AP)->sbcs.curr_mseg.size >= (CSZ)); \ + (AP)->sbcs.curr_mseg.size -= (CSZ); \ + STAT_SBC_FREE((AP), (BSZ)); \ + DEBUG_CHECK_CARRIER_NO_SZ((AP)); \ +} while (0) + +#define STAT_SYS_ALLOC_SBC_FREE(AP, CSZ, BSZ) \ +do { \ + ASSERT((AP)->sbcs.curr_sys_alloc.no > 0); \ + (AP)->sbcs.curr_sys_alloc.no--; \ + ASSERT((AP)->sbcs.curr_sys_alloc.size >= (CSZ)); \ + (AP)->sbcs.curr_sys_alloc.size -= (CSZ); \ + STAT_SBC_FREE((AP), (BSZ)); \ + DEBUG_CHECK_CARRIER_NO_SZ((AP)); \ +} while (0) + +#define STAT_MBC_ALLOC(AP) \ + if ((AP)->mbcs.max.no < ((AP)->mbcs.curr_mseg.no \ + + (AP)->mbcs.curr_sys_alloc.no)) \ + (AP)->mbcs.max.no = ((AP)->mbcs.curr_mseg.no \ + + (AP)->mbcs.curr_sys_alloc.no); \ + if ((AP)->mbcs.max.size < ((AP)->mbcs.curr_mseg.size \ + + (AP)->mbcs.curr_sys_alloc.size)) \ + (AP)->mbcs.max.size = ((AP)->mbcs.curr_mseg.size \ + + (AP)->mbcs.curr_sys_alloc.size) + + +#define STAT_MSEG_MBC_ALLOC(AP, CSZ) \ +do { \ + (AP)->mbcs.curr_mseg.no++; \ + (AP)->mbcs.curr_mseg.size += (CSZ); \ + STAT_MBC_ALLOC((AP)); \ + DEBUG_CHECK_CARRIER_NO_SZ((AP)); \ +} while (0) + +#define STAT_SYS_ALLOC_MBC_ALLOC(AP, CSZ) \ +do { \ + (AP)->mbcs.curr_sys_alloc.no++; \ + (AP)->mbcs.curr_sys_alloc.size += (CSZ); \ + STAT_MBC_ALLOC((AP)); \ + DEBUG_CHECK_CARRIER_NO_SZ((AP)); \ +} while (0) + +#define STAT_MSEG_MBC_FREE(AP, CSZ) \ +do { \ + ASSERT((AP)->mbcs.curr_mseg.no > 0); \ + (AP)->mbcs.curr_mseg.no--; \ + ASSERT((AP)->mbcs.curr_mseg.size >= (CSZ)); \ + (AP)->mbcs.curr_mseg.size -= (CSZ); \ + DEBUG_CHECK_CARRIER_NO_SZ((AP)); \ +} while (0) + +#define STAT_SYS_ALLOC_MBC_FREE(AP, CSZ) \ +do { \ + ASSERT((AP)->mbcs.curr_sys_alloc.no > 0); \ + (AP)->mbcs.curr_sys_alloc.no--; \ + ASSERT((AP)->mbcs.curr_sys_alloc.size >= (CSZ)); \ + (AP)->mbcs.curr_sys_alloc.size -= (CSZ); \ + DEBUG_CHECK_CARRIER_NO_SZ((AP)); \ +} while (0) + +#define STAT_MBC_BLK_ALLOC(AP, BSZ) \ +do { \ + (AP)->mbcs.blocks.curr.no++; \ + if ((AP)->mbcs.blocks.max.no < (AP)->mbcs.blocks.curr.no) \ + (AP)->mbcs.blocks.max.no = (AP)->mbcs.blocks.curr.no; \ + (AP)->mbcs.blocks.curr.size += (BSZ); \ + if ((AP)->mbcs.blocks.max.size < (AP)->mbcs.blocks.curr.size) \ + (AP)->mbcs.blocks.max.size = (AP)->mbcs.blocks.curr.size; \ +} while (0) + +#define STAT_MBC_BLK_FREE(AP, BSZ) \ +do { \ + ASSERT((AP)->mbcs.blocks.curr.no > 0); \ + (AP)->mbcs.blocks.curr.no--; \ + ASSERT((AP)->mbcs.blocks.curr.size >= (BSZ)); \ + (AP)->mbcs.blocks.curr.size -= (BSZ); \ +} while (0) + +/* Debug stuff... */ +#ifdef DEBUG +static Uint carrier_alignment; +#define DEBUG_SAVE_ALIGNMENT(C) \ +do { \ + Uint algnmnt__ = sizeof(Unit_t) - (((Uint) (C)) % sizeof(Unit_t)); \ + carrier_alignment = MIN(carrier_alignment, algnmnt__); \ + ASSERT(((Uint) (C)) % sizeof(Uint) == 0); \ +} while (0) +#define DEBUG_CHECK_ALIGNMENT(P) \ +do { \ + ASSERT(sizeof(Unit_t) - (((Uint) (P)) % sizeof(Unit_t)) \ + >= carrier_alignment); \ + ASSERT(((Uint) (P)) % sizeof(Uint) == 0); \ +} while (0) + +#else +#define DEBUG_SAVE_ALIGNMENT(C) +#define DEBUG_CHECK_ALIGNMENT(P) +#endif + +#ifdef DEBUG +#ifdef USE_THREADS +#define ERTS_ALCU_DBG_CHK_THR_SPEC(A) \ +do { \ + if (!(A)->thread_safe) { \ + if (!(A)->debug.saved_tid) \ + (A)->debug.tid = erts_thr_self(); \ + else { \ + ASSERT(ethr_equal_tids((A)->debug.tid, erts_thr_self())); \ + } \ + } \ +} while (0) +#else +#define ERTS_ALCU_DBG_CHK_THR_SPEC(A) +#endif +#else +#define ERTS_ALCU_DBG_CHK_THR_SPEC(A) +#endif + + +static void make_name_atoms(Allctr_t *allctr); + + +/* mseg ... */ + +#if HAVE_ERTS_MSEG + +static ERTS_INLINE void * +alcu_mseg_alloc(Allctr_t *allctr, Uint *size_p) +{ + void *res; + + res = erts_mseg_alloc_opt(allctr->alloc_no, size_p, &allctr->mseg_opt); + INC_CC(allctr->calls.mseg_alloc); + return res; +} + +static ERTS_INLINE void * +alcu_mseg_realloc(Allctr_t *allctr, void *seg, Uint old_size, Uint *new_size_p) +{ + void *res; + + res = erts_mseg_realloc_opt(allctr->alloc_no, seg, old_size, new_size_p, + &allctr->mseg_opt); + INC_CC(allctr->calls.mseg_realloc); + return res; +} + +static ERTS_INLINE void +alcu_mseg_dealloc(Allctr_t *allctr, void *seg, Uint size) +{ + erts_mseg_dealloc_opt(allctr->alloc_no, seg, size, &allctr->mseg_opt); + INC_CC(allctr->calls.mseg_dealloc); +} + +#endif + +static ERTS_INLINE void * +alcu_sys_alloc(Allctr_t *allctr, Uint size) +{ + void *res; + + res = erts_sys_alloc(0, NULL, size); + INC_CC(allctr->calls.sys_alloc); + if (erts_mtrace_enabled) + erts_mtrace_crr_alloc(res, allctr->alloc_no, ERTS_ALC_A_SYSTEM, size); + return res; +} + +static ERTS_INLINE void * +alcu_sys_realloc(Allctr_t *allctr, void *ptr, Uint size) +{ + void *res; + + res = erts_sys_realloc(0, NULL, ptr, size); + INC_CC(allctr->calls.sys_realloc); + if (erts_mtrace_enabled) + erts_mtrace_crr_realloc(res, + allctr->alloc_no, + ERTS_ALC_A_SYSTEM, + ptr, + size); + return res; +} + +static ERTS_INLINE void +alcu_sys_free(Allctr_t *allctr, void *ptr) +{ + erts_sys_free(0, NULL, ptr); + INC_CC(allctr->calls.sys_free); + if (erts_mtrace_enabled) + erts_mtrace_crr_free(allctr->alloc_no, ERTS_ALC_A_SYSTEM, ptr); +} + +static Uint +get_next_mbc_size(Allctr_t *allctr) +{ + Uint size; + int cs = (allctr->mbcs.curr_mseg.no + + allctr->mbcs.curr_sys_alloc.no + - (allctr->main_carrier ? 1 : 0)); + + ASSERT(cs >= 0); + ASSERT(allctr->largest_mbc_size >= allctr->smallest_mbc_size); + + if (cs >= allctr->mbc_growth_stages) + size = allctr->largest_mbc_size; + else + size = ((cs*(allctr->largest_mbc_size - allctr->smallest_mbc_size) + / allctr->mbc_growth_stages) + + allctr->smallest_mbc_size); + + if (size < allctr->min_mbc_size) + size = allctr->min_mbc_size; + + return size; +} + +static ERTS_INLINE void +link_carrier(CarrierList_t *cl, Carrier_t *crr) +{ + crr->next = NULL; + if (!cl->last) { + ASSERT(!cl->first); + cl->first = cl->last = crr; + crr->prev = NULL; + } + else { + ASSERT(cl->first); + ASSERT(!cl->first->prev); + ASSERT(cl->last); + ASSERT(!cl->last->next); + crr->prev = cl->last; + cl->last->next = crr; + cl->last = crr; + } + ASSERT(crr->next != crr); + ASSERT(crr->prev != crr); +} + +static ERTS_INLINE void +relink_carrier(CarrierList_t *cl, Carrier_t *crr) +{ + if (crr->next) { + if (crr->next->prev != crr) + crr->next->prev = crr; + } + else if (cl->last != crr) + cl->last = crr; + + if (crr->prev) { + if (crr->prev->next != crr) + crr->prev->next = crr; + } + else if (cl->first != crr) + cl->first = crr; +} + +static ERTS_INLINE void +unlink_carrier(CarrierList_t *cl, Carrier_t *crr) +{ + ASSERT(crr->next != crr); + ASSERT(crr->prev != crr); + + if (cl->first == crr) { + ASSERT(!crr->prev); + cl->first = crr->next; + } + else { + ASSERT(crr->prev); + crr->prev->next = crr->next; + } + + if (cl->last == crr) { + ASSERT(!crr->next); + cl->last = crr->prev; + } + else { + ASSERT(crr->next); + crr->next->prev = crr->prev; + } +} + + +static Block_t *create_carrier(Allctr_t *, Uint, Uint); +static void destroy_carrier(Allctr_t *, Block_t *); + +/* Multi block carrier alloc/realloc/free ... */ + +/* NOTE! mbc_alloc() may in case of memory shortage place the requested + * block in a sbc. + */ +static ERTS_INLINE void * +mbc_alloc_block(Allctr_t *allctr, Uint size, Uint *blk_szp) +{ + Block_t *blk; + + ASSERT(size); + ASSERT(size < allctr->sbc_threshold); + + *blk_szp = UMEMSZ2BLKSZ(allctr, size); + + blk = (*allctr->get_free_block)(allctr, *blk_szp, NULL, 0); + + if (!blk) { + blk = create_carrier(allctr, *blk_szp, CFLG_MBC); + if (!blk) { + /* Emergency! We couldn't create the carrier as we wanted. + Try to place it in a sys_alloced sbc. */ + blk = create_carrier(allctr, + size, + CFLG_SBC|CFLG_FORCE_SIZE|CFLG_FORCE_SYS_ALLOC); + } + } + +#ifdef ERTS_ALLOC_UTIL_HARD_DEBUG + if (IS_MBC_BLK(blk)) { + (*allctr->link_free_block)(allctr, blk); + HARD_CHECK_BLK_CARRIER(allctr, blk); + (*allctr->unlink_free_block)(allctr, blk); + } +#endif + + return blk; +} + +static ERTS_INLINE void +mbc_alloc_finalize(Allctr_t *allctr, + Block_t *blk, + Uint org_blk_sz, + Uint flags, + Uint want_blk_sz, + int valid_blk_info) +{ + Uint blk_sz; + Uint nxt_blk_sz; + Block_t *nxt_blk; + Uint prev_free_flg = flags & PREV_FREE_BLK_HDR_FLG; + + ASSERT(org_blk_sz >= want_blk_sz); + ASSERT(blk); + +#ifdef DEBUG + nxt_blk = NULL; +#endif + + if (org_blk_sz - allctr->min_block_size >= want_blk_sz) { + /* Shrink block... */ + blk_sz = want_blk_sz; + nxt_blk_sz = org_blk_sz - blk_sz; + SET_BLK_HDR(blk, + blk_sz, + SBH_THIS_ALLOCED|SBH_NOT_LAST_BLK|prev_free_flg); + + nxt_blk = NXT_BLK(blk); + SET_BLK_HDR(nxt_blk, + nxt_blk_sz, + (SBH_THIS_FREE + | SBH_PREV_ALLOCED + | (flags & LAST_BLK_HDR_FLG))); + + if (!(flags & LAST_BLK_HDR_FLG)) { + SET_BLK_SZ_FTR(nxt_blk, nxt_blk_sz); + if (!valid_blk_info) { + Block_t *nxt_nxt_blk = NXT_BLK(nxt_blk); + SET_PREV_BLK_FREE(nxt_nxt_blk); + } + } + (*allctr->link_free_block)(allctr, nxt_blk); + + ASSERT(IS_NOT_LAST_BLK(blk)); + ASSERT(IS_FREE_BLK(nxt_blk)); + ASSERT((flags & LAST_BLK_HDR_FLG) + ? IS_LAST_BLK(nxt_blk) + : IS_NOT_LAST_BLK(nxt_blk)); + ASSERT((flags & LAST_BLK_HDR_FLG) + || nxt_blk == PREV_BLK(NXT_BLK(nxt_blk))); + ASSERT((flags & LAST_BLK_HDR_FLG) + || IS_PREV_BLK_FREE(NXT_BLK(nxt_blk))); + ASSERT(nxt_blk_sz == BLK_SZ(nxt_blk)); + ASSERT(nxt_blk_sz % sizeof(Unit_t) == 0); + ASSERT(nxt_blk_sz >= allctr->min_block_size); + } + else { + blk_sz = org_blk_sz; + if (flags & LAST_BLK_HDR_FLG) { + if (valid_blk_info) + SET_BLK_ALLOCED(blk); + else + SET_BLK_HDR(blk, + blk_sz, + SBH_THIS_ALLOCED|SBH_LAST_BLK|prev_free_flg); + } + else { + if (valid_blk_info) + SET_BLK_ALLOCED(blk); + else + SET_BLK_HDR(blk, + blk_sz, + SBH_THIS_ALLOCED|SBH_NOT_LAST_BLK|prev_free_flg); + nxt_blk = NXT_BLK(blk); + SET_PREV_BLK_ALLOCED(nxt_blk); + } + + ASSERT((flags & LAST_BLK_HDR_FLG) + ? IS_LAST_BLK(blk) + : IS_NOT_LAST_BLK(blk)); + } + + STAT_MBC_BLK_ALLOC(allctr, blk_sz); + + ASSERT(IS_ALLOCED_BLK(blk)); + ASSERT(blk_sz == BLK_SZ(blk)); + ASSERT(blk_sz % sizeof(Unit_t) == 0); + ASSERT(blk_sz >= allctr->min_block_size); + ASSERT(blk_sz >= want_blk_sz); + ASSERT(IS_MBC_BLK(blk)); + + ASSERT(!nxt_blk || IS_PREV_BLK_ALLOCED(nxt_blk)); + ASSERT(!nxt_blk || IS_MBC_BLK(nxt_blk)); + + HARD_CHECK_BLK_CARRIER(allctr, blk); +} + +static void * +mbc_alloc(Allctr_t *allctr, Uint size) +{ + Block_t *blk; + Uint blk_sz; + blk = mbc_alloc_block(allctr, size, &blk_sz); + if (!blk) + return NULL; + if (IS_MBC_BLK(blk)) + mbc_alloc_finalize(allctr, + blk, + BLK_SZ(blk), + GET_BLK_HDR_FLGS(blk), + blk_sz, + 1); + return BLK2UMEM(blk); +} + +static void +mbc_free(Allctr_t *allctr, void *p) +{ + Uint is_first_blk; + Uint is_last_blk; + Uint blk_sz; + Block_t *blk; + Block_t *nxt_blk; + + + ASSERT(p); + + blk = UMEM2BLK(p); + blk_sz = BLK_SZ(blk); + + ASSERT(IS_MBC_BLK(blk)); + ASSERT(blk_sz >= allctr->min_block_size); + + HARD_CHECK_BLK_CARRIER(allctr, blk); + + STAT_MBC_BLK_FREE(allctr, blk_sz); + + is_first_blk = IS_FIRST_BLK(blk); + is_last_blk = IS_LAST_BLK(blk); + + if (!is_first_blk && IS_PREV_BLK_FREE(blk)) { + /* Coalesce with previous block... */ + blk = PREV_BLK(blk); + (*allctr->unlink_free_block)(allctr, blk); + + blk_sz += BLK_SZ(blk); + is_first_blk = IS_FIRST_BLK(blk); + SET_BLK_SZ(blk, blk_sz); + } + else { + SET_BLK_FREE(blk); + } + + if (is_last_blk) + SET_LAST_BLK(blk); + else { + nxt_blk = NXT_BLK(blk); + if (IS_FREE_BLK(nxt_blk)) { + /* Coalesce with next block... */ + (*allctr->unlink_free_block)(allctr, nxt_blk); + blk_sz += BLK_SZ(nxt_blk); + SET_BLK_SZ(blk, blk_sz); + + is_last_blk = IS_LAST_BLK(nxt_blk); + if (is_last_blk) + SET_LAST_BLK(blk); + else { + SET_NOT_LAST_BLK(blk); + SET_BLK_SZ_FTR(blk, blk_sz); + } + } + else { + SET_PREV_BLK_FREE(nxt_blk); + SET_NOT_LAST_BLK(blk); + SET_BLK_SZ_FTR(blk, blk_sz); + } + + } + + ASSERT(is_last_blk ? IS_LAST_BLK(blk) : IS_NOT_LAST_BLK(blk)); + ASSERT(is_first_blk ? IS_FIRST_BLK(blk) : IS_NOT_FIRST_BLK(blk)); + ASSERT(IS_FREE_BLK(blk)); + ASSERT(is_first_blk || IS_PREV_BLK_ALLOCED(blk)); + ASSERT(is_last_blk || IS_PREV_BLK_FREE(NXT_BLK(blk))); + ASSERT(blk_sz == BLK_SZ(blk)); + ASSERT(is_last_blk || blk == PREV_BLK(NXT_BLK(blk))); + ASSERT(blk_sz % sizeof(Unit_t) == 0); + ASSERT(IS_MBC_BLK(blk)); + + if (is_first_blk + && is_last_blk + && allctr->main_carrier != FBLK2MBC(allctr, blk)) + destroy_carrier(allctr, blk); + else { + (*allctr->link_free_block)(allctr, blk); + HARD_CHECK_BLK_CARRIER(allctr, blk); + } +} + +static void * +mbc_realloc(Allctr_t *allctr, void *p, Uint size, Uint flgs) +{ + void *new_p; + Uint old_blk_sz; + Block_t *blk; +#ifndef MBC_REALLOC_ALWAYS_MOVES + Block_t *new_blk, *cand_blk; + Uint cand_blk_sz; + Uint blk_sz; + Block_t *nxt_blk; + Uint nxt_blk_sz; + Uint is_last_blk; +#endif /* #ifndef MBC_REALLOC_ALWAYS_MOVES */ + + ASSERT(p); + ASSERT(size); + ASSERT(size < allctr->sbc_threshold); + + blk = (Block_t *) UMEM2BLK(p); + old_blk_sz = BLK_SZ(blk); + + ASSERT(old_blk_sz >= allctr->min_block_size); + +#ifdef MBC_REALLOC_ALWAYS_MOVES + if (flgs & ERTS_ALCU_FLG_FAIL_REALLOC_MOVE) + return NULL; +#else /* !MBC_REALLOC_ALWAYS_MOVES */ + blk_sz = UMEMSZ2BLKSZ(allctr, size); + + ASSERT(IS_ALLOCED_BLK(blk)); + ASSERT(IS_MBC_BLK(blk)); + + is_last_blk = IS_LAST_BLK(blk); + + if (old_blk_sz == blk_sz) + return p; + else if (blk_sz < old_blk_sz) { + /* Shrink block... */ + Block_t *nxt_nxt_blk; + Uint diff_sz_val = old_blk_sz - blk_sz; + Uint old_blk_sz_val = old_blk_sz; + + if (diff_sz_val >= (~((Uint) 0) / 100)) { + /* div both by 128 */ + old_blk_sz_val >>= 7; + diff_sz_val >>= 7; + } + + /* Avoid fragmentation by moving the block if it is shrunk much */ + if (100*diff_sz_val > allctr->mbc_move_threshold*old_blk_sz_val) { + if (flgs & ERTS_ALCU_FLG_FAIL_REALLOC_MOVE) + return NULL; + + cand_blk_sz = old_blk_sz; + if (!IS_PREV_BLK_FREE(blk) || IS_FIRST_BLK(blk)) + cand_blk = blk; + else { + cand_blk = PREV_BLK(blk); + cand_blk_sz += PREV_BLK_SZ(blk); + } + if (!is_last_blk) { + nxt_blk = NXT_BLK(blk); + if (IS_FREE_BLK(nxt_blk)) + cand_blk_sz += BLK_SZ(nxt_blk); + } + + new_blk = (*allctr->get_free_block)(allctr, + blk_sz, + cand_blk, + cand_blk_sz); + + if (new_blk || cand_blk != blk) + goto move_into_new_blk; + } + + /* Shrink at current location */ + + nxt_blk_sz = old_blk_sz - blk_sz; + + if ((is_last_blk || IS_ALLOCED_BLK(NXT_BLK(blk))) + && (nxt_blk_sz < allctr->min_block_size)) + return p; + + HARD_CHECK_BLK_CARRIER(allctr, blk); + + SET_BLK_SZ(blk, blk_sz); + SET_NOT_LAST_BLK(blk); + + nxt_blk = NXT_BLK(blk); + SET_BLK_HDR(nxt_blk, + nxt_blk_sz, + SBH_THIS_FREE|SBH_PREV_ALLOCED|SBH_NOT_LAST_BLK); + + STAT_MBC_BLK_FREE(allctr, old_blk_sz); + STAT_MBC_BLK_ALLOC(allctr, blk_sz); + + ASSERT(BLK_SZ(blk) >= allctr->min_block_size); + + if (is_last_blk) + SET_LAST_BLK(nxt_blk); + else { + nxt_nxt_blk = NXT_BLK(nxt_blk); + if (IS_FREE_BLK(nxt_nxt_blk)) { + /* Coalesce with next free block... */ + nxt_blk_sz += BLK_SZ(nxt_nxt_blk); + (*allctr->unlink_free_block)(allctr, nxt_nxt_blk); + SET_BLK_SZ(nxt_blk, nxt_blk_sz); + + is_last_blk = IS_LAST_BLK(nxt_nxt_blk); + if (is_last_blk) + SET_LAST_BLK(nxt_blk); + else + SET_BLK_SZ_FTR(nxt_blk, nxt_blk_sz); + } + else { + SET_BLK_SZ_FTR(nxt_blk, nxt_blk_sz); + SET_PREV_BLK_FREE(nxt_nxt_blk); + } + } + + (*allctr->link_free_block)(allctr, nxt_blk); + + + ASSERT(IS_ALLOCED_BLK(blk)); + ASSERT(blk_sz == BLK_SZ(blk)); + ASSERT(blk_sz % sizeof(Unit_t) == 0); + ASSERT(blk_sz >= allctr->min_block_size); + ASSERT(blk_sz >= size + ABLK_HDR_SZ); + ASSERT(IS_MBC_BLK(blk)); + + ASSERT(IS_FREE_BLK(nxt_blk)); + ASSERT(IS_PREV_BLK_ALLOCED(nxt_blk)); + ASSERT(nxt_blk_sz == BLK_SZ(nxt_blk)); + ASSERT(nxt_blk_sz % sizeof(Unit_t) == 0); + ASSERT(nxt_blk_sz >= allctr->min_block_size); + ASSERT(IS_MBC_BLK(nxt_blk)); + ASSERT(is_last_blk ? IS_LAST_BLK(nxt_blk) : IS_NOT_LAST_BLK(nxt_blk)); + ASSERT(is_last_blk || nxt_blk == PREV_BLK(NXT_BLK(nxt_blk))); + ASSERT(is_last_blk || IS_PREV_BLK_FREE(NXT_BLK(nxt_blk))); + + HARD_CHECK_BLK_CARRIER(allctr, blk); + + return p; + } + + /* Need larger block... */ + + if (!is_last_blk) { + nxt_blk = NXT_BLK(blk); + nxt_blk_sz = BLK_SZ(nxt_blk); + if (IS_FREE_BLK(nxt_blk) && blk_sz <= old_blk_sz + nxt_blk_sz) { + /* Grow into next block... */ + + HARD_CHECK_BLK_CARRIER(allctr, blk); + + (*allctr->unlink_free_block)(allctr, nxt_blk); + nxt_blk_sz -= blk_sz - old_blk_sz; + + is_last_blk = IS_LAST_BLK(nxt_blk); + if (nxt_blk_sz < allctr->min_block_size) { + blk_sz += nxt_blk_sz; + + SET_BLK_SZ(blk, blk_sz); + + if (is_last_blk) { + SET_LAST_BLK(blk); +#ifdef DEBUG + nxt_blk = NULL; +#endif + } + else { + nxt_blk = NXT_BLK(blk); + SET_PREV_BLK_ALLOCED(nxt_blk); +#ifdef DEBUG + is_last_blk = IS_LAST_BLK(nxt_blk); + nxt_blk_sz = BLK_SZ(nxt_blk); +#endif + } + } + else { + SET_BLK_SZ(blk, blk_sz); + + nxt_blk = NXT_BLK(blk); + SET_BLK_HDR(nxt_blk, + nxt_blk_sz, + SBH_THIS_FREE|SBH_PREV_ALLOCED|SBH_NOT_LAST_BLK); + + if (is_last_blk) + SET_LAST_BLK(nxt_blk); + else + SET_BLK_SZ_FTR(nxt_blk, nxt_blk_sz); + + (*allctr->link_free_block)(allctr, nxt_blk); + + ASSERT(IS_FREE_BLK(nxt_blk)); + } + + STAT_MBC_BLK_FREE(allctr, old_blk_sz); + STAT_MBC_BLK_ALLOC(allctr, blk_sz); + + + ASSERT(IS_ALLOCED_BLK(blk)); + ASSERT(blk_sz == BLK_SZ(blk)); + ASSERT(blk_sz % sizeof(Unit_t) == 0); + ASSERT(blk_sz >= allctr->min_block_size); + ASSERT(blk_sz >= size + ABLK_HDR_SZ); + ASSERT(IS_MBC_BLK(blk)); + + ASSERT(!nxt_blk || IS_PREV_BLK_ALLOCED(nxt_blk)); + ASSERT(!nxt_blk || nxt_blk_sz == BLK_SZ(nxt_blk)); + ASSERT(!nxt_blk || nxt_blk_sz % sizeof(Unit_t) == 0); + ASSERT(!nxt_blk || nxt_blk_sz >= allctr->min_block_size); + ASSERT(!nxt_blk || IS_MBC_BLK(nxt_blk)); + ASSERT(!nxt_blk || (is_last_blk + ? IS_LAST_BLK(nxt_blk) + : IS_NOT_LAST_BLK(nxt_blk))); + ASSERT(!nxt_blk || is_last_blk + || IS_ALLOCED_BLK(nxt_blk) + || nxt_blk == PREV_BLK(NXT_BLK(nxt_blk))); + ASSERT(!nxt_blk || is_last_blk + || IS_ALLOCED_BLK(nxt_blk) + || IS_PREV_BLK_FREE(NXT_BLK(nxt_blk))); + + HARD_CHECK_BLK_CARRIER(allctr, blk); + + return p; + } + } + + if (flgs & ERTS_ALCU_FLG_FAIL_REALLOC_MOVE) + return NULL; + + /* Need to grow in another block */ + + if (!IS_PREV_BLK_FREE(blk) || IS_FIRST_BLK(blk)) { + cand_blk = NULL; + cand_blk_sz = 0; + } + else { + cand_blk = PREV_BLK(blk); + cand_blk_sz = old_blk_sz + PREV_BLK_SZ(blk); + + if (!is_last_blk) { + nxt_blk = NXT_BLK(blk); + if (IS_FREE_BLK(nxt_blk)) + cand_blk_sz += BLK_SZ(nxt_blk); + } + } + + if (cand_blk_sz < blk_sz) { + /* We wont fit in cand_blk get a new one */ +#endif /* !MBC_REALLOC_ALWAYS_MOVES */ + + new_p = mbc_alloc(allctr, size); + if (!new_p) + return NULL; + sys_memcpy(new_p, p, MIN(size, old_blk_sz - ABLK_HDR_SZ)); + mbc_free(allctr, p); + + return new_p; + +#ifndef MBC_REALLOC_ALWAYS_MOVES + + } + else { + /* We will at least fit in cand_blk */ + + new_blk = (*allctr->get_free_block)(allctr, + blk_sz, + cand_blk, + cand_blk_sz); + move_into_new_blk: + /* + * new_blk, and cand_blk have to be correctly set + * when jumping to this label. + */ + + if (new_blk) { + mbc_alloc_finalize(allctr, + new_blk, + BLK_SZ(new_blk), + GET_BLK_HDR_FLGS(new_blk), + blk_sz, + 1); + new_p = BLK2UMEM(new_blk); + sys_memcpy(new_p, p, MIN(size, old_blk_sz - ABLK_HDR_SZ)); + mbc_free(allctr, p); + return new_p; + } + else { + Uint new_blk_sz; + Uint new_blk_flgs; + Uint prev_blk_sz; + Uint blk_cpy_sz; + + ASSERT(IS_PREV_BLK_FREE(blk)); + ASSERT(cand_blk == PREV_BLK(blk)); + + prev_blk_sz = PREV_BLK_SZ(blk); + new_blk = cand_blk; + new_blk_sz = prev_blk_sz + old_blk_sz; + new_blk_flgs = GET_BLK_HDR_FLGS(new_blk); + + HARD_CHECK_BLK_CARRIER(allctr, blk); + + (*allctr->unlink_free_block)(allctr, new_blk); /* prev */ + + if (is_last_blk) + new_blk_flgs |= LAST_BLK_HDR_FLG; + else { + nxt_blk = NXT_BLK(blk); + if (IS_FREE_BLK(nxt_blk)) { + new_blk_flgs |= GET_LAST_BLK_HDR_FLG(nxt_blk); + new_blk_sz += BLK_SZ(nxt_blk); + (*allctr->unlink_free_block)(allctr, nxt_blk); + } + } + + /* + * Copy user-data then update new blocks in mbc_alloc_finalize(). + * mbc_alloc_finalize() may write headers at old location of + * user data; therfore, order is important. + */ + + new_p = BLK2UMEM(new_blk); + blk_cpy_sz = MIN(blk_sz, old_blk_sz); + + if (prev_blk_sz >= blk_cpy_sz) + sys_memcpy(new_p, p, blk_cpy_sz - ABLK_HDR_SZ); + else + sys_memmove(new_p, p, blk_cpy_sz - ABLK_HDR_SZ); + + mbc_alloc_finalize(allctr, + new_blk, + new_blk_sz, + new_blk_flgs, + blk_sz, + 0); + + STAT_MBC_BLK_FREE(allctr, old_blk_sz); + + return new_p; + } + } +#endif /* !MBC_REALLOC_ALWAYS_MOVES */ +} + +#ifdef DEBUG + +#if HAVE_ERTS_MSEG +#define ASSERT_MSEG_UNIT_SIZE_MULTIPLE(CSZ) ASSERT((CSZ) % mseg_unit_size == 0) +#else +#define ASSERT_MSEG_UNIT_SIZE_MULTIPLE(CSZ) +#endif + +#define CHECK_1BLK_CARRIER(A, SBC, MSEGED, C, CSZ, B, BSZ) \ +do { \ + ASSERT(IS_FIRST_BLK((B))); \ + ASSERT(IS_LAST_BLK((B))); \ + ASSERT((CSZ) == CARRIER_SZ((C))); \ + ASSERT((BSZ) == BLK_SZ((B))); \ + ASSERT((BSZ) % sizeof(Unit_t) == 0); \ + if ((SBC)) { \ + ASSERT(IS_SBC_BLK((B))); \ + ASSERT(IS_SB_CARRIER((C))); \ + } \ + else { \ + ASSERT(IS_MBC_BLK((B))); \ + ASSERT(IS_MB_CARRIER((C))); \ + } \ + if ((MSEGED)) { \ + ASSERT(IS_MSEG_CARRIER((C))); \ + ASSERT_MSEG_UNIT_SIZE_MULTIPLE((CSZ)); \ + } \ + else { \ + ASSERT(IS_SYS_ALLOC_CARRIER((C))); \ + ASSERT((CSZ) % sizeof(Unit_t) == 0); \ + } \ +} while (0) + +#else +#define CHECK_1BLK_CARRIER(A, SBC, MSEGED, C, CSZ, B, BSZ) +#endif + + +static Block_t * +create_carrier(Allctr_t *allctr, Uint umem_sz, Uint flags) +{ + Block_t *blk; + Carrier_t *crr; + Uint blk_sz, bcrr_sz, crr_sz; +#if HAVE_ERTS_MSEG + int have_tried_sys_alloc = 0, have_tried_mseg = 0; +#endif +#ifdef DEBUG + int is_mseg = 0; +#endif + + ASSERT((flags & CFLG_SBC && !(flags & CFLG_MBC)) + || (flags & CFLG_MBC && !(flags & CFLG_SBC))); + + blk_sz = UMEMSZ2BLKSZ(allctr, umem_sz); + +#if HAVE_ERTS_MSEG + + if (flags & CFLG_FORCE_SYS_ALLOC) + goto try_sys_alloc; + if (flags & CFLG_FORCE_MSEG) + goto try_mseg; + if (erts_mseg_no() >= max_mseg_carriers) + goto try_sys_alloc; + if (flags & CFLG_SBC) { + if (allctr->sbcs.curr_mseg.no >= allctr->max_mseg_sbcs) + goto try_sys_alloc; + } + else { + if (allctr->mbcs.curr_mseg.no >= allctr->max_mseg_mbcs) + goto try_sys_alloc; + } + + try_mseg: + + if (flags & CFLG_SBC) { + crr_sz = blk_sz + allctr->sbc_header_size; + } + else { + crr_sz = (*allctr->get_next_mbc_size)(allctr); + if (crr_sz < allctr->mbc_header_size + blk_sz) + crr_sz = allctr->mbc_header_size + blk_sz; +#ifdef ERTS_ALLOC_UTIL_HARD_DEBUG + if (sizeof(Unit_t) == sizeof(Uint)) + crr_sz += sizeof(Uint); +#endif + } + crr_sz = MSEG_UNIT_CEILING(crr_sz); + ASSERT(crr_sz % mseg_unit_size == 0); + + crr = (Carrier_t *) alcu_mseg_alloc(allctr, &crr_sz); + if (!crr) { + have_tried_mseg = 1; + if (!(have_tried_sys_alloc || flags & CFLG_FORCE_MSEG)) + goto try_sys_alloc; + return NULL; + } + +#ifdef DEBUG + is_mseg = 1; +#endif + if (flags & CFLG_SBC) { + SET_CARRIER_HDR(crr, crr_sz, SCH_MSEG|SCH_SBC); + STAT_MSEG_SBC_ALLOC(allctr, crr_sz, blk_sz); + goto sbc_final_touch; + } + else { + SET_CARRIER_HDR(crr, crr_sz, SCH_MSEG|SCH_MBC); + STAT_MSEG_MBC_ALLOC(allctr, crr_sz); + goto mbc_final_touch; + } + + try_sys_alloc: +#endif /* #if HAVE_ERTS_MSEG */ + + if (flags & CFLG_SBC) { + bcrr_sz = blk_sz + allctr->sbc_header_size; + } + else { + bcrr_sz = allctr->mbc_header_size + blk_sz; + if (!(flags & CFLG_MAIN_CARRIER) + && bcrr_sz < allctr->smallest_mbc_size) + bcrr_sz = allctr->smallest_mbc_size; +#ifdef ERTS_ALLOC_UTIL_HARD_DEBUG + if (sizeof(Unit_t) == sizeof(Uint)) + bcrr_sz += sizeof(Uint); +#endif + + } + + crr_sz = (flags & CFLG_FORCE_SIZE + ? UNIT_CEILING(bcrr_sz) + : SYS_ALLOC_CARRIER_CEILING(bcrr_sz)); + + crr = (Carrier_t *) alcu_sys_alloc(allctr, crr_sz); + + if (!crr) { + if (crr_sz > UNIT_CEILING(bcrr_sz)) { + crr_sz = UNIT_CEILING(bcrr_sz); + crr = (Carrier_t *) alcu_sys_alloc(allctr, crr_sz); + } + if (!crr) { +#if HAVE_ERTS_MSEG + have_tried_sys_alloc = 1; + if (!(have_tried_mseg || flags & CFLG_FORCE_SYS_ALLOC)) + goto try_mseg; +#endif + return NULL; + } + } + if (flags & CFLG_SBC) { + SET_CARRIER_HDR(crr, crr_sz, SCH_SYS_ALLOC|SCH_SBC); + STAT_SYS_ALLOC_SBC_ALLOC(allctr, crr_sz, blk_sz); + +#if HAVE_ERTS_MSEG + sbc_final_touch: +#endif + + blk = SBC2BLK(allctr, crr); + + SET_SBC_BLK_FTR(((Uint *) blk)[-1]); + SET_BLK_HDR(blk, blk_sz, SBH_THIS_ALLOCED|SBH_PREV_FREE|SBH_LAST_BLK); + + link_carrier(&allctr->sbc_list, crr); + + CHECK_1BLK_CARRIER(allctr, 1, is_mseg, crr, crr_sz, blk, blk_sz); + + } + else { + SET_CARRIER_HDR(crr, crr_sz, SCH_SYS_ALLOC|SCH_MBC); + STAT_SYS_ALLOC_MBC_ALLOC(allctr, crr_sz); + +#if HAVE_ERTS_MSEG + mbc_final_touch: +#endif + + blk = MBC2FBLK(allctr, crr); + +#ifdef ERTS_ALLOC_UTIL_HARD_DEBUG + if (sizeof(Unit_t) == sizeof(Uint)) + crr_sz -= sizeof(Uint); +#endif + + blk_sz = UNIT_FLOOR(crr_sz - allctr->mbc_header_size); + + SET_MBC_BLK_FTR(((Uint *) blk)[-1]); + SET_BLK_HDR(blk, blk_sz, SBH_THIS_FREE|SBH_PREV_FREE|SBH_LAST_BLK); + +#ifdef ERTS_ALLOC_UTIL_HARD_DEBUG + *((Carrier_t **) NXT_BLK(blk)) = crr; +#endif + + if (flags & CFLG_MAIN_CARRIER) { + ASSERT(!allctr->main_carrier); + allctr->main_carrier = crr; + } + + link_carrier(&allctr->mbc_list, crr); + +#ifdef ERTS_ALLOC_UTIL_HARD_DEBUG + if (sizeof(Unit_t) == sizeof(Uint)) + crr_sz += sizeof(Uint); +#endif + CHECK_1BLK_CARRIER(allctr, 0, is_mseg, crr, crr_sz, blk, blk_sz); +#ifdef ERTS_ALLOC_UTIL_HARD_DEBUG + if (sizeof(Unit_t) == sizeof(Uint)) + crr_sz -= sizeof(Uint); +#endif + if (allctr->creating_mbc) + (*allctr->creating_mbc)(allctr, crr); + + } + + DEBUG_SAVE_ALIGNMENT(crr); + return blk; +} + +static Block_t * +resize_carrier(Allctr_t *allctr, Block_t *old_blk, Uint umem_sz, Uint flags) +{ + Block_t *new_blk; + Carrier_t *new_crr, *old_crr; + Uint create_flags, old_crr_sz, old_blk_sz, new_blk_sz, new_crr_sz; + Uint new_bcrr_sz; + + if (flags & CFLG_MBC) { + ASSERT(0); + return NULL; + } + + ASSERT(flags & CFLG_SBC); + create_flags = flags|CFLG_SBC; + + HARD_CHECK_BLK_CARRIER(allctr, old_blk); + + old_blk_sz = BLK_SZ(old_blk); + old_crr = BLK2SBC(allctr, old_blk); + old_crr_sz = CARRIER_SZ(old_crr); + ASSERT(IS_SB_CARRIER(old_crr)); + ASSERT(IS_SBC_BLK(old_blk)); + + new_blk_sz = UMEMSZ2BLKSZ(allctr, umem_sz); + +#if HAVE_ERTS_MSEG + + if (IS_MSEG_CARRIER(old_crr)) { + STAT_MSEG_SBC_FREE(allctr, old_crr_sz, old_blk_sz); + + if (!(flags & CFLG_FORCE_SYS_ALLOC)) { + + new_crr_sz = new_blk_sz + allctr->sbc_header_size; + new_crr_sz = MSEG_UNIT_CEILING(new_crr_sz); + new_crr = (Carrier_t *) alcu_mseg_realloc(allctr, + old_crr, + old_crr_sz, + &new_crr_sz); + if (new_crr) { + SET_CARRIER_SZ(new_crr, new_crr_sz); + new_blk = SBC2BLK(allctr, new_crr); + SET_BLK_SZ(new_blk, new_blk_sz); + STAT_MSEG_SBC_ALLOC(allctr, new_crr_sz, new_blk_sz); + relink_carrier(&allctr->sbc_list, new_crr); + CHECK_1BLK_CARRIER(allctr, 1, 1, new_crr, new_crr_sz, + new_blk, new_blk_sz); + DEBUG_SAVE_ALIGNMENT(new_crr); + return new_blk; + } + create_flags |= CFLG_FORCE_SYS_ALLOC; /* since mseg_realloc() + failed */ + } + + new_blk = create_carrier(allctr, umem_sz, create_flags); + if (new_blk) { + sys_memcpy((void *) BLK2UMEM(new_blk), + (void *) BLK2UMEM(old_blk), + MIN(new_blk_sz, old_blk_sz) - ABLK_HDR_SZ); + unlink_carrier(&allctr->sbc_list, old_crr); + alcu_mseg_dealloc(allctr, old_crr, old_crr_sz); + } + else { + /* Old carrier unchanged; restore stat */ + STAT_MSEG_SBC_ALLOC(allctr, old_crr_sz, old_blk_sz); + } + + return new_blk; + } + else { + if (!(flags & CFLG_FORCE_MSEG)) { +#endif /* #if HAVE_ERTS_MSEG */ + new_bcrr_sz = new_blk_sz + allctr->sbc_header_size; + new_crr_sz = (flags & CFLG_FORCE_SIZE + ? UNIT_CEILING(new_bcrr_sz) + : SYS_ALLOC_CARRIER_CEILING(new_bcrr_sz)); + + new_crr = (Carrier_t *) alcu_sys_realloc(allctr, + (void *) old_crr, + new_crr_sz); + if (new_crr) { + sys_realloc_success: + SET_CARRIER_SZ(new_crr, new_crr_sz); + new_blk = SBC2BLK(allctr, new_crr); + SET_BLK_SZ(new_blk, new_blk_sz); + STAT_SYS_ALLOC_SBC_FREE(allctr, old_crr_sz, old_blk_sz); + STAT_SYS_ALLOC_SBC_ALLOC(allctr, new_crr_sz, new_blk_sz); + relink_carrier(&allctr->sbc_list, new_crr); + CHECK_1BLK_CARRIER(allctr, 1, 0, new_crr, new_crr_sz, + new_blk, new_blk_sz); + DEBUG_SAVE_ALIGNMENT(new_crr); + return new_blk; + } + else if (new_crr_sz > UNIT_CEILING(new_bcrr_sz)) { + new_crr_sz = new_blk_sz + allctr->sbc_header_size; + new_crr_sz = UNIT_CEILING(new_crr_sz); + new_crr = (Carrier_t *) alcu_sys_realloc(allctr, + (void *) old_crr, + new_crr_sz); + if (new_crr) + goto sys_realloc_success; + } + +#if !HAVE_ERTS_MSEG + return NULL; +#else + create_flags |= CFLG_FORCE_MSEG; /* Since sys_realloc() failed */ + } + + STAT_SYS_ALLOC_SBC_FREE(allctr, old_crr_sz, old_blk_sz); + + new_blk = create_carrier(allctr, umem_sz, create_flags); + if (new_blk) { + sys_memcpy((void *) BLK2UMEM(new_blk), + (void *) BLK2UMEM(old_blk), + MIN(new_blk_sz, old_blk_sz) - ABLK_HDR_SZ); + unlink_carrier(&allctr->sbc_list, old_crr); + alcu_sys_free(allctr, old_crr); + } + else { + /* Old carrier unchanged; restore... */ + STAT_SYS_ALLOC_SBC_ALLOC(allctr, old_crr_sz, old_blk_sz); + } + DEBUG_SAVE_ALIGNMENT(new_crr); + return new_blk; + } +#endif +} + +static void +destroy_carrier(Allctr_t *allctr, Block_t *blk) +{ + Uint crr_sz; + Carrier_t *crr; +#if HAVE_ERTS_MSEG + Uint is_mseg = 0; +#endif + + ASSERT(IS_FIRST_BLK(blk)); + + if (IS_SBC_BLK(blk)) { + Uint blk_sz = BLK_SZ(blk); + crr = BLK2SBC(allctr, blk); + crr_sz = CARRIER_SZ(crr); + + ASSERT(IS_LAST_BLK(blk)); + + HARD_CHECK_BLK_CARRIER(allctr, blk); + +#if HAVE_ERTS_MSEG + if (IS_MSEG_CARRIER(crr)) { + is_mseg++; + ASSERT(crr_sz % mseg_unit_size == 0); + STAT_MSEG_SBC_FREE(allctr, crr_sz, blk_sz); + } + else +#endif + STAT_SYS_ALLOC_SBC_FREE(allctr, crr_sz, blk_sz); + + unlink_carrier(&allctr->sbc_list, crr); + + } + else { + crr = FBLK2MBC(allctr, blk); + crr_sz = CARRIER_SZ(crr); + +#ifdef DEBUG + if (!allctr->stopped) { + ASSERT(IS_LAST_BLK(blk)); + +#ifdef ERTS_ALLOC_UTIL_HARD_DEBUG + (*allctr->link_free_block)(allctr, blk); + HARD_CHECK_BLK_CARRIER(allctr, blk); + (*allctr->unlink_free_block)(allctr, blk); +#endif + } +#endif + +#if HAVE_ERTS_MSEG + if (IS_MSEG_CARRIER(crr)) { + is_mseg++; + ASSERT(crr_sz % mseg_unit_size == 0); + STAT_MSEG_MBC_FREE(allctr, crr_sz); + } + else +#endif + STAT_SYS_ALLOC_MBC_FREE(allctr, crr_sz); + + unlink_carrier(&allctr->mbc_list, crr); + if (allctr->destroying_mbc) + (*allctr->destroying_mbc)(allctr, crr); + } + + +#if HAVE_ERTS_MSEG + if (is_mseg) { + alcu_mseg_dealloc(allctr, crr, crr_sz); + } + else +#endif + alcu_sys_free(allctr, crr); +} + + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *\ + * Info stuff * +\* */ + +static struct { + Eterm versions; + + Eterm options; + Eterm e; + Eterm t; + Eterm ramv; + Eterm sbct; +#if HAVE_ERTS_MSEG + Eterm asbcst; + Eterm rsbcst; +#endif + Eterm rsbcmt; + Eterm rmbcmt; + Eterm mmbcs; + Eterm msbclt; +#if HAVE_ERTS_MSEG + Eterm mmsbc; + Eterm mmmbc; +#endif + Eterm lmbcs; + Eterm smbcs; + Eterm mbcgs; + +#if HAVE_ERTS_MSEG + Eterm mmc; +#endif + Eterm ycs; + + Eterm mbcs; + Eterm sbcs; + Eterm sys_alloc_carriers_size; +#if HAVE_ERTS_MSEG + Eterm mseg_alloc_carriers_size; +#endif + Eterm carriers_size; + Eterm sys_alloc_carriers; +#if HAVE_ERTS_MSEG + Eterm mseg_alloc_carriers; +#endif + Eterm carriers; + Eterm blocks_size; + Eterm blocks; + + Eterm calls; + Eterm sys_alloc; + Eterm sys_free; + Eterm sys_realloc; +#if HAVE_ERTS_MSEG + Eterm mseg_alloc; + Eterm mseg_dealloc; + Eterm mseg_realloc; +#endif +#ifdef DEBUG + Eterm end_of_atoms; +#endif +} am; + +static ERTS_INLINE void atom_init(Eterm *atom, char *name) +{ + *atom = am_atom_put(name, strlen(name)); +} +#define AM_INIT(AM) atom_init(&am.AM, #AM) + +static erts_mtx_t init_atoms_mtx; + +static void +init_atoms(Allctr_t *allctr) +{ + +#ifdef USE_THREADS + if (allctr && allctr->thread_safe) + erts_mtx_unlock(&allctr->mutex); +#endif + + erts_mtx_lock(&init_atoms_mtx); + + if (!atoms_initialized) { +#ifdef DEBUG + Eterm *atom; + + for (atom = (Eterm *) &am; atom <= &am.end_of_atoms; atom++) { + *atom = THE_NON_VALUE; + } +#endif + + AM_INIT(versions); + + AM_INIT(options); + AM_INIT(e); + AM_INIT(t); + AM_INIT(ramv); + AM_INIT(sbct); +#if HAVE_ERTS_MSEG + AM_INIT(asbcst); + AM_INIT(rsbcst); +#endif + AM_INIT(rsbcmt); + AM_INIT(rmbcmt); + AM_INIT(mmbcs); + AM_INIT(msbclt); +#if HAVE_ERTS_MSEG + AM_INIT(mmsbc); + AM_INIT(mmmbc); +#endif + AM_INIT(lmbcs); + AM_INIT(smbcs); + AM_INIT(mbcgs); + +#if HAVE_ERTS_MSEG + AM_INIT(mmc); +#endif + AM_INIT(ycs); + + AM_INIT(mbcs); + AM_INIT(sbcs); + AM_INIT(sys_alloc_carriers_size); +#if HAVE_ERTS_MSEG + AM_INIT(mseg_alloc_carriers_size); +#endif + AM_INIT(carriers_size); + AM_INIT(sys_alloc_carriers); +#if HAVE_ERTS_MSEG + AM_INIT(mseg_alloc_carriers); +#endif + AM_INIT(carriers); + AM_INIT(blocks_size); + AM_INIT(blocks); + + AM_INIT(calls); + AM_INIT(sys_alloc); + AM_INIT(sys_free); + AM_INIT(sys_realloc); +#if HAVE_ERTS_MSEG + AM_INIT(mseg_alloc); + AM_INIT(mseg_dealloc); + AM_INIT(mseg_realloc); +#endif + +#ifdef DEBUG + for (atom = (Eterm *) &am; atom < &am.end_of_atoms; atom++) { + ASSERT(*atom != THE_NON_VALUE); + } +#endif + } + + + if (allctr) { + + make_name_atoms(allctr); + + (*allctr->init_atoms)(); + +#ifdef USE_THREADS + if (allctr->thread_safe) + erts_mtx_lock(&allctr->mutex); +#endif + allctr->atoms_initialized = 1; + } + + atoms_initialized = 1; + erts_mtx_unlock(&init_atoms_mtx); + +} + +static ERTS_INLINE void +ensure_atoms_initialized(Allctr_t *allctr) +{ + if (!allctr || !allctr->atoms_initialized) + init_atoms(allctr); +} + +#define bld_uint erts_bld_uint +#define bld_cons erts_bld_cons +#define bld_tuple erts_bld_tuple +#define bld_string erts_bld_string + +/* + * bld_unstable_uint() (instead bld_uint()) is used when values may + * change between size check and actual build. This because a value + * that would fit a small when size check is done may need to be built + * as a big when the actual build is performed. Caller is required to + * HRelease after build. + */ +static ERTS_INLINE Eterm +bld_unstable_uint(Uint **hpp, Uint *szp, Uint ui) +{ + Eterm res = THE_NON_VALUE; + if (szp) + *szp += BIG_UINT_HEAP_SIZE; + if (hpp) { + if (IS_USMALL(0, ui)) + res = make_small(ui); + else { + res = uint_to_big(ui, *hpp); + *hpp += BIG_UINT_HEAP_SIZE; + } + } + return res; +} + +static ERTS_INLINE void +add_2tup(Uint **hpp, Uint *szp, Eterm *lp, Eterm el1, Eterm el2) +{ + *lp = bld_cons(hpp, szp, bld_tuple(hpp, szp, 2, el1, el2), *lp); +} + +static ERTS_INLINE void +add_3tup(Uint **hpp, Uint *szp, Eterm *lp, Eterm el1, Eterm el2, Eterm el3) +{ + *lp = bld_cons(hpp, szp, bld_tuple(hpp, szp, 3, el1, el2, el3), *lp); +} + +static ERTS_INLINE void +add_4tup(Uint **hpp, Uint *szp, Eterm *lp, + Eterm el1, Eterm el2, Eterm el3, Eterm el4) +{ + *lp = + bld_cons(hpp, szp, bld_tuple(hpp, szp, 4, el1, el2, el3, el4), *lp); +} + +static Eterm +sz_info_carriers(Allctr_t *allctr, + CarriersStats_t *cs, + char *prefix, + int *print_to_p, + void *print_to_arg, + Uint **hpp, + Uint *szp) +{ + Eterm res = THE_NON_VALUE; + Uint curr_size = cs->curr_mseg.size + cs->curr_sys_alloc.size; + + if (print_to_p) { + int to = *print_to_p; + void *arg = print_to_arg; + erts_print(to, + arg, + "%sblocks size: %bpu %bpu %bpu\n", + prefix, + cs->blocks.curr.size, + cs->blocks.max.size, + cs->blocks.max_ever.size); + erts_print(to, + arg, + "%scarriers size: %bpu %bpu %bpu\n", + prefix, + curr_size, + cs->max.size, + cs->max_ever.size); + } + + if (hpp || szp) { + res = NIL; + add_4tup(hpp, szp, &res, + am.carriers_size, + bld_unstable_uint(hpp, szp, curr_size), + bld_unstable_uint(hpp, szp, cs->max.size), + bld_unstable_uint(hpp, szp, cs->max_ever.size)); + add_4tup(hpp, szp, &res, + am.blocks_size, + bld_unstable_uint(hpp, szp, cs->blocks.curr.size), + bld_unstable_uint(hpp, szp, cs->blocks.max.size), + bld_unstable_uint(hpp, szp, cs->blocks.max_ever.size)); + } + + return res; +} + +static Eterm +info_carriers(Allctr_t *allctr, + CarriersStats_t *cs, + char *prefix, + int *print_to_p, + void *print_to_arg, + Uint **hpp, + Uint *szp) +{ + Eterm res = THE_NON_VALUE; + Uint curr_no = cs->curr_mseg.no + cs->curr_sys_alloc.no; + Uint curr_size = cs->curr_mseg.size + cs->curr_sys_alloc.size; + + if (print_to_p) { + int to = *print_to_p; + void *arg = print_to_arg; + erts_print(to, + arg, + "%sblocks: %bpu %bpu %bpu\n", + prefix, + cs->blocks.curr.no, + cs->blocks.max.no, + cs->blocks.max_ever.no); + erts_print(to, + arg, + "%sblocks size: %bpu %bpu %bpu\n", + prefix, + cs->blocks.curr.size, + cs->blocks.max.size, + cs->blocks.max_ever.size); + erts_print(to, + arg, + "%scarriers: %bpu %bpu %bpu\n", + prefix, + curr_no, + cs->max.no, + cs->max_ever.no); +#if HAVE_ERTS_MSEG + erts_print(to, + arg, + "%smseg carriers: %bpu\n", + prefix, + cs->curr_mseg.no); +#endif + erts_print(to, + arg, + "%ssys_alloc carriers: %bpu\n", + prefix, + cs->curr_sys_alloc.no); + erts_print(to, + arg, + "%scarriers size: %bpu %bpu %bpu\n", + prefix, + curr_size, + cs->max.size, + cs->max_ever.size); +#if HAVE_ERTS_MSEG + erts_print(to, + arg, + "%smseg carriers size: %bpu\n", + prefix, + cs->curr_mseg.size); +#endif + erts_print(to, + arg, + "%ssys_alloc carriers size: %bpu\n", + prefix, + cs->curr_sys_alloc.size); + } + + if (hpp || szp) { + res = NIL; + add_2tup(hpp, szp, &res, + am.sys_alloc_carriers_size, + bld_unstable_uint(hpp, szp, cs->curr_sys_alloc.size)); +#if HAVE_ERTS_MSEG + add_2tup(hpp, szp, &res, + am.mseg_alloc_carriers_size, + bld_unstable_uint(hpp, szp, cs->curr_mseg.size)); +#endif + add_4tup(hpp, szp, &res, + am.carriers_size, + bld_unstable_uint(hpp, szp, curr_size), + bld_unstable_uint(hpp, szp, cs->max.size), + bld_unstable_uint(hpp, szp, cs->max_ever.size)); + add_2tup(hpp, szp, &res, + am.sys_alloc_carriers, + bld_unstable_uint(hpp, szp, cs->curr_sys_alloc.no)); +#if HAVE_ERTS_MSEG + add_2tup(hpp, szp, &res, + am.mseg_alloc_carriers, + bld_unstable_uint(hpp, szp, cs->curr_mseg.no)); +#endif + add_4tup(hpp, szp, &res, + am.carriers, + bld_unstable_uint(hpp, szp, curr_no), + bld_unstable_uint(hpp, szp, cs->max.no), + bld_unstable_uint(hpp, szp, cs->max_ever.no)); + add_4tup(hpp, szp, &res, + am.blocks_size, + bld_unstable_uint(hpp, szp, cs->blocks.curr.size), + bld_unstable_uint(hpp, szp, cs->blocks.max.size), + bld_unstable_uint(hpp, szp, cs->blocks.max_ever.size)); + add_4tup(hpp, szp, &res, + am.blocks, + bld_unstable_uint(hpp, szp, cs->blocks.curr.no), + bld_unstable_uint(hpp, szp, cs->blocks.max.no), + bld_unstable_uint(hpp, szp, cs->blocks.max_ever.no)); + } + + return res; +} + +static void +make_name_atoms(Allctr_t *allctr) +{ + char alloc[] = "alloc"; + char realloc[] = "realloc"; + char free[] = "free"; + char buf[MAX_ATOM_LENGTH]; + size_t prefix_len = strlen(allctr->name_prefix); + + if (prefix_len > MAX_ATOM_LENGTH + sizeof(realloc) - 1) + erl_exit(1,"Too long allocator name: %salloc\n",allctr->name_prefix); + + memcpy((void *) buf, (void *) allctr->name_prefix, prefix_len); + + memcpy((void *) &buf[prefix_len], (void *) alloc, sizeof(alloc) - 1); + allctr->name.alloc = am_atom_put(buf, prefix_len + sizeof(alloc) - 1); + + memcpy((void *) &buf[prefix_len], (void *) realloc, sizeof(realloc) - 1); + allctr->name.realloc = am_atom_put(buf, prefix_len + sizeof(realloc) - 1); + + memcpy((void *) &buf[prefix_len], (void *) free, sizeof(free) - 1); + allctr->name.free = am_atom_put(buf, prefix_len + sizeof(free) - 1); + +} + +static Eterm +info_calls(Allctr_t *allctr, + int *print_to_p, + void *print_to_arg, + Uint **hpp, + Uint *szp) +{ + Eterm res = THE_NON_VALUE; + + + if (print_to_p) { + +#define PRINT_CC_4(TO, TOA, NAME, CC) \ + if ((CC).giga_no == 0) \ + erts_print(TO, TOA, "%s calls: %bpu\n", NAME, CC.no); \ + else \ + erts_print(TO, TOA, "%s calls: %bpu%09lu\n", NAME, CC.giga_no, CC.no) + +#define PRINT_CC_5(TO, TOA, PRFX, NAME, CC) \ + if ((CC).giga_no == 0) \ + erts_print(TO, TOA, "%s%s calls: %bpu\n",PRFX,NAME,CC.no); \ + else \ + erts_print(TO, TOA, "%s%s calls: %bpu%09lu\n",PRFX,NAME,CC.giga_no,CC.no) + + char *prefix = allctr->name_prefix; + int to = *print_to_p; + void *arg = print_to_arg; + + PRINT_CC_5(to, arg, prefix, "alloc", allctr->calls.this_alloc); + PRINT_CC_5(to, arg, prefix, "free", allctr->calls.this_free); + PRINT_CC_5(to, arg, prefix, "realloc", allctr->calls.this_realloc); + +#if HAVE_ERTS_MSEG + PRINT_CC_4(to, arg, "mseg_alloc", allctr->calls.mseg_alloc); + PRINT_CC_4(to, arg, "mseg_dealloc", allctr->calls.mseg_dealloc); + PRINT_CC_4(to, arg, "mseg_realloc", allctr->calls.mseg_realloc); +#endif + + PRINT_CC_4(to, arg, "sys_alloc", allctr->calls.sys_alloc); + PRINT_CC_4(to, arg, "sys_free", allctr->calls.sys_free); + PRINT_CC_4(to, arg, "sys_realloc", allctr->calls.sys_realloc); + +#undef PRINT_CC_4 +#undef PRINT_CC_5 + + } + + + if (hpp || szp) { + + ASSERT(allctr->name.alloc != THE_NON_VALUE); + ASSERT(allctr->name.realloc != THE_NON_VALUE); + ASSERT(allctr->name.free != THE_NON_VALUE); + + res = NIL; + + add_3tup(hpp, szp, &res, + am.sys_realloc, + bld_unstable_uint(hpp, szp, allctr->calls.sys_realloc.giga_no), + bld_unstable_uint(hpp, szp, allctr->calls.sys_realloc.no)); + add_3tup(hpp, szp, &res, + am.sys_free, + bld_unstable_uint(hpp, szp, allctr->calls.sys_free.giga_no), + bld_unstable_uint(hpp, szp, allctr->calls.sys_free.no)); + add_3tup(hpp, szp, &res, + am.sys_alloc, + bld_unstable_uint(hpp, szp, allctr->calls.sys_alloc.giga_no), + bld_unstable_uint(hpp, szp, allctr->calls.sys_alloc.no)); +#if HAVE_ERTS_MSEG + add_3tup(hpp, szp, &res, + am.mseg_realloc, + bld_unstable_uint(hpp, szp, allctr->calls.mseg_realloc.giga_no), + bld_unstable_uint(hpp, szp, allctr->calls.mseg_realloc.no)); + add_3tup(hpp, szp, &res, + am.mseg_dealloc, + bld_unstable_uint(hpp, szp, allctr->calls.mseg_dealloc.giga_no), + bld_unstable_uint(hpp, szp, allctr->calls.mseg_dealloc.no)); + add_3tup(hpp, szp, &res, + am.mseg_alloc, + bld_unstable_uint(hpp, szp, allctr->calls.mseg_alloc.giga_no), + bld_unstable_uint(hpp, szp, allctr->calls.mseg_alloc.no)); +#endif + add_3tup(hpp, szp, &res, + allctr->name.realloc, + bld_unstable_uint(hpp, szp, allctr->calls.this_realloc.giga_no), + bld_unstable_uint(hpp, szp, allctr->calls.this_realloc.no)); + add_3tup(hpp, szp, &res, + allctr->name.free, + bld_unstable_uint(hpp, szp, allctr->calls.this_free.giga_no), + bld_unstable_uint(hpp, szp, allctr->calls.this_free.no)); + add_3tup(hpp, szp, &res, + allctr->name.alloc, + bld_unstable_uint(hpp, szp, allctr->calls.this_alloc.giga_no), + bld_unstable_uint(hpp, szp, allctr->calls.this_alloc.no)); + } + + return res; +} + +static Eterm +info_options(Allctr_t *allctr, + int *print_to_p, + void *print_to_arg, + Uint **hpp, + Uint *szp) +{ + Eterm res = THE_NON_VALUE; + + if (!allctr) { + if (print_to_p) + erts_print(*print_to_p, print_to_arg, "option e: false\n"); + if (hpp || szp) { + res = NIL; + add_2tup(hpp, szp, &res, am.e, am_false); + } + return res; + } + + if (print_to_p) { + char topt[21]; /* Enough for any 64-bit integer */ + if (allctr->t) + erts_snprintf(&topt[0], sizeof(topt), "%d", allctr->t); + else + erts_snprintf(&topt[0], sizeof(topt), "false"); + erts_print(*print_to_p, + print_to_arg, + "option e: true\n" + "option t: %s\n" + "option ramv: %s\n" + "option sbct: %bpu\n" +#if HAVE_ERTS_MSEG + "option asbcst: %bpu\n" + "option rsbcst: %bpu\n" +#endif + "option rsbcmt: %bpu\n" + "option rmbcmt: %bpu\n" + "option mmbcs: %bpu\n" +#if HAVE_ERTS_MSEG + "option mmsbc: %bpu\n" + "option mmmbc: %bpu\n" +#endif + "option lmbcs: %bpu\n" + "option smbcs: %bpu\n" + "option mbcgs: %bpu\n", + topt, + allctr->ramv ? "true" : "false", + allctr->sbc_threshold, +#if HAVE_ERTS_MSEG + allctr->mseg_opt.abs_shrink_th, + allctr->mseg_opt.rel_shrink_th, +#endif + allctr->sbc_move_threshold, + allctr->mbc_move_threshold, + allctr->main_carrier_size, +#if HAVE_ERTS_MSEG + allctr->max_mseg_sbcs, + allctr->max_mseg_mbcs, +#endif + allctr->largest_mbc_size, + allctr->smallest_mbc_size, + allctr->mbc_growth_stages); + } + + res = (*allctr->info_options)(allctr, "option ", print_to_p, print_to_arg, + hpp, szp); + + if (hpp || szp) { + add_2tup(hpp, szp, &res, + am.mbcgs, + bld_uint(hpp, szp, allctr->mbc_growth_stages)); + add_2tup(hpp, szp, &res, + am.smbcs, + bld_uint(hpp, szp, allctr->smallest_mbc_size)); + add_2tup(hpp, szp, &res, + am.lmbcs, + bld_uint(hpp, szp, allctr->largest_mbc_size)); +#if HAVE_ERTS_MSEG + add_2tup(hpp, szp, &res, + am.mmsbc, + bld_uint(hpp, szp, allctr->max_mseg_sbcs)); + add_2tup(hpp, szp, &res, + am.mmmbc, + bld_uint(hpp, szp, allctr->max_mseg_mbcs)); +#endif + add_2tup(hpp, szp, &res, + am.mmbcs, + bld_uint(hpp, szp, allctr->main_carrier_size)); + add_2tup(hpp, szp, &res, + am.rmbcmt, + bld_uint(hpp, szp, allctr->mbc_move_threshold)); + add_2tup(hpp, szp, &res, + am.rsbcmt, + bld_uint(hpp, szp, allctr->sbc_move_threshold)); +#if HAVE_ERTS_MSEG + add_2tup(hpp, szp, &res, + am.rsbcst, + bld_uint(hpp, szp, allctr->mseg_opt.rel_shrink_th)); + add_2tup(hpp, szp, &res, + am.asbcst, + bld_uint(hpp, szp, allctr->mseg_opt.abs_shrink_th)); +#endif + add_2tup(hpp, szp, &res, + am.sbct, + bld_uint(hpp, szp, allctr->sbc_threshold)); + add_2tup(hpp, szp, &res, am.ramv, allctr->ramv ? am_true : am_false); + add_2tup(hpp, szp, &res, am.t, (allctr->t + ? bld_uint(hpp, szp, (Uint) allctr->t) + : am_false)); + add_2tup(hpp, szp, &res, am.e, am_true); + } + + return res; +} + + +static ERTS_INLINE void +update_max_ever_values(CarriersStats_t *cs) +{ + if (cs->max_ever.no < cs->max.no) + cs->max_ever.no = cs->max.no; + if (cs->max_ever.size < cs->max.size) + cs->max_ever.size = cs->max.size; + if (cs->blocks.max_ever.no < cs->blocks.max.no) + cs->blocks.max_ever.no = cs->blocks.max.no; + if (cs->blocks.max_ever.size < cs->blocks.max.size) + cs->blocks.max_ever.size = cs->blocks.max.size; +} + +static ERTS_INLINE void +reset_max_values(CarriersStats_t *cs) +{ + cs->max.no = cs->curr_mseg.no + cs->curr_sys_alloc.no; + cs->max.size = cs->curr_mseg.size + cs->curr_sys_alloc.size; + cs->blocks.max.no = cs->blocks.curr.no; + cs->blocks.max.size = cs->blocks.curr.size; +} + + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *\ + * Exported functions * +\* */ + +Eterm +erts_alcu_au_info_options(int *print_to_p, void *print_to_arg, + Uint **hpp, Uint *szp) +{ + Eterm res = THE_NON_VALUE; + + if (print_to_p) { + + erts_print(*print_to_p, + print_to_arg, +#if HAVE_ERTS_MSEG + "option mmc: %bpu\n" +#endif + "option ycs: %bpu\n", +#if HAVE_ERTS_MSEG + max_mseg_carriers, +#endif + sys_alloc_carrier_size); + } + + if (hpp || szp) { + res = NIL; + ensure_atoms_initialized(NULL); + add_2tup(hpp, szp, &res, + am.ycs, + bld_uint(hpp, szp, sys_alloc_carrier_size)); +#if HAVE_ERTS_MSEG + add_2tup(hpp, szp, &res, + am.mmc, + bld_uint(hpp, szp, max_mseg_carriers)); +#endif + } + + return res; +} + + +Eterm +erts_alcu_info_options(Allctr_t *allctr, + int *print_to_p, + void *print_to_arg, + Uint **hpp, + Uint *szp) +{ + Eterm res; + + +#ifdef USE_THREADS + if (allctr->thread_safe) + erts_mtx_lock(&allctr->mutex); +#endif + if (hpp || szp) + ensure_atoms_initialized(allctr); + res = info_options(allctr, print_to_p, print_to_arg, hpp, szp); +#ifdef USE_THREADS + if (allctr->thread_safe) + erts_mtx_unlock(&allctr->mutex); +#endif + return res; +} + +/* ----------------------------------------------------------------------- */ + +Eterm +erts_alcu_sz_info(Allctr_t *allctr, + int begin_max_period, + int *print_to_p, + void *print_to_arg, + Uint **hpp, + Uint *szp) +{ + Eterm res, mbcs, sbcs; + + res = THE_NON_VALUE; + + if (!allctr) { + if (print_to_p) + erts_print(*print_to_p, print_to_arg, "false\n"); + if (szp) + *szp = 0; + return am_false; + } + +#ifdef USE_THREADS + if (allctr->thread_safe) + erts_mtx_lock(&allctr->mutex); +#endif + + if (hpp || szp) + ensure_atoms_initialized(allctr); + + /* Update sbc values not continously updated */ + allctr->sbcs.blocks.curr.no + = allctr->sbcs.curr_mseg.no + allctr->sbcs.curr_sys_alloc.no; + allctr->sbcs.blocks.max.no = allctr->sbcs.max.no; + + update_max_ever_values(&allctr->mbcs); + update_max_ever_values(&allctr->sbcs); + + mbcs = sz_info_carriers(allctr, &allctr->mbcs, "mbcs ", print_to_p, + print_to_arg, hpp, szp); + sbcs = sz_info_carriers(allctr, &allctr->sbcs, "sbcs ", print_to_p, + print_to_arg, hpp, szp); + + if (hpp || szp) { + res = NIL; + add_2tup(hpp, szp, &res, am.sbcs, sbcs); + add_2tup(hpp, szp, &res, am.mbcs, mbcs); + } + + if (begin_max_period) { + reset_max_values(&allctr->mbcs); + reset_max_values(&allctr->sbcs); + } + + +#ifdef USE_THREADS + if (allctr->thread_safe) + erts_mtx_unlock(&allctr->mutex); +#endif + + return res; +} + +Eterm +erts_alcu_info(Allctr_t *allctr, + int begin_max_period, + int *print_to_p, + void *print_to_arg, + Uint **hpp, + Uint *szp) +{ + Eterm res, sett, mbcs, sbcs, calls; + + res = THE_NON_VALUE; + + if (!allctr) { + if (print_to_p) + erts_print(*print_to_p, print_to_arg, "false\n"); + if (szp) + *szp = 0; + return am_false; + } + +#ifdef USE_THREADS + if (allctr->thread_safe) + erts_mtx_lock(&allctr->mutex); +#endif + + if (hpp || szp) + ensure_atoms_initialized(allctr); + + /* Update sbc values not continously updated */ + allctr->sbcs.blocks.curr.no + = allctr->sbcs.curr_mseg.no + allctr->sbcs.curr_sys_alloc.no; + allctr->sbcs.blocks.max.no = allctr->sbcs.max.no; + + update_max_ever_values(&allctr->mbcs); + update_max_ever_values(&allctr->sbcs); + + if (print_to_p) { + erts_print(*print_to_p, + print_to_arg, + "versions: %s %s\n", + allctr->vsn_str, + ERTS_ALCU_VSN_STR); + } + + sett = info_options(allctr, print_to_p, print_to_arg, hpp, szp); + mbcs = info_carriers(allctr, &allctr->mbcs, "mbcs ", print_to_p, + print_to_arg, hpp, szp); + sbcs = info_carriers(allctr, &allctr->sbcs, "sbcs ", print_to_p, + print_to_arg, hpp, szp); + calls = info_calls(allctr, print_to_p, print_to_arg, hpp, szp); + + if (hpp || szp) { + res = NIL; + + add_2tup(hpp, szp, &res, am.calls, calls); + add_2tup(hpp, szp, &res, am.sbcs, sbcs); + add_2tup(hpp, szp, &res, am.mbcs, mbcs); + add_2tup(hpp, szp, &res, am.options, sett); + add_3tup(hpp, szp, &res, + am.versions, + bld_string(hpp, szp, allctr->vsn_str), + bld_string(hpp, szp, ERTS_ALCU_VSN_STR));; + } + + if (begin_max_period) { + reset_max_values(&allctr->mbcs); + reset_max_values(&allctr->sbcs); + } + + +#ifdef USE_THREADS + if (allctr->thread_safe) + erts_mtx_unlock(&allctr->mutex); +#endif + + return res; +} + + +void +erts_alcu_current_size(Allctr_t *allctr, AllctrSize_t *size) +{ + +#ifdef USE_THREADS + if (allctr->thread_safe) + erts_mtx_lock(&allctr->mutex); +#endif + + size->carriers = allctr->mbcs.curr_mseg.size; + size->carriers += allctr->mbcs.curr_sys_alloc.size; + size->carriers += allctr->sbcs.curr_mseg.size; + size->carriers += allctr->sbcs.curr_sys_alloc.size; + + size->blocks = allctr->mbcs.blocks.curr.size; + size->blocks += allctr->sbcs.blocks.curr.size; + +#ifdef USE_THREADS + if (allctr->thread_safe) + erts_mtx_unlock(&allctr->mutex); +#endif +} + +/* ----------------------------------------------------------------------- */ + +static ERTS_INLINE void * +do_erts_alcu_alloc(ErtsAlcType_t type, void *extra, Uint size) +{ + Allctr_t *allctr = (Allctr_t *) extra; + void *res; + + ASSERT(initialized); + + ASSERT(allctr); + + ERTS_ALCU_DBG_CHK_THR_SPEC(allctr); + +#if ALLOC_ZERO_EQ_NULL + if (!size) + return NULL; +#endif + + INC_CC(allctr->calls.this_alloc); + + if (size >= allctr->sbc_threshold) { + Block_t *blk = create_carrier(allctr, size, CFLG_SBC); + res = blk ? BLK2UMEM(blk) : NULL; + } + else + res = mbc_alloc(allctr, size); + + return res; +} + +void *erts_alcu_alloc(ErtsAlcType_t type, void *extra, Uint size) +{ + void *res; + res = do_erts_alcu_alloc(type, extra, size); + DEBUG_CHECK_ALIGNMENT(res); + return res; +} + + +#ifdef USE_THREADS + +void * +erts_alcu_alloc_ts(ErtsAlcType_t type, void *extra, Uint size) +{ + Allctr_t *allctr = (Allctr_t *) extra; + void *res; + erts_mtx_lock(&allctr->mutex); + res = do_erts_alcu_alloc(type, extra, size); + + DEBUG_CHECK_ALIGNMENT(res); + + erts_mtx_unlock(&allctr->mutex); + return res; +} + +void * +erts_alcu_alloc_thr_spec(ErtsAlcType_t type, void *extra, Uint size) +{ + ErtsAllocatorThrSpec_t *tspec = (ErtsAllocatorThrSpec_t *) extra; + int ix = erts_alc_get_thr_ix(); + Allctr_t *allctr; + int unlock; + void *res; + + ASSERT(ix > 0); + if (ix < tspec->size) { + allctr = tspec->allctr[ix]; + unlock = 0; + } + else { + allctr = tspec->allctr[0]; + unlock = 1; + erts_mtx_lock(&allctr->mutex); + } + + res = do_erts_alcu_alloc(type, allctr, size); + + if (unlock) + erts_mtx_unlock(&allctr->mutex); + + DEBUG_CHECK_ALIGNMENT(res); + + return res; +} + +void * +erts_alcu_alloc_thr_pref(ErtsAlcType_t type, void *extra, Uint size) +{ + ErtsAllocatorThrSpec_t *tspec = (ErtsAllocatorThrSpec_t *) extra; + int ix = erts_alc_get_thr_ix(); + Allctr_t *allctr; + void *res; + + ASSERT(sizeof(Uint) == sizeof(Allctr_t *)); + ASSERT(ix > 0); + if (ix >= tspec->size) + ix = (ix % (tspec->size - 1)) + 1; + allctr = tspec->allctr[ix]; + erts_mtx_lock(&allctr->mutex); + res = do_erts_alcu_alloc(type, allctr, size + sizeof(Uint)); + if (res) { + *((Allctr_t **) res) = allctr; + res = (void *) (((char *) res) + sizeof(Uint)); + } + erts_mtx_unlock(&allctr->mutex); + DEBUG_CHECK_ALIGNMENT(res); + return res; +} + +#endif + +/* ------------------------------------------------------------------------- */ + +static ERTS_INLINE void +do_erts_alcu_free(ErtsAlcType_t type, void *extra, void *p) +{ + Allctr_t *allctr = (Allctr_t *) extra; + ASSERT(initialized); + + ASSERT(allctr); + + ERTS_ALCU_DBG_CHK_THR_SPEC(allctr); + + if (p) { + Block_t *blk; + + INC_CC(allctr->calls.this_free); + + blk = UMEM2BLK(p); + if (IS_SBC_BLK(blk)) + destroy_carrier(allctr, blk); + else + mbc_free(allctr, p); + } +} + +void erts_alcu_free(ErtsAlcType_t type, void *extra, void *p) +{ + do_erts_alcu_free(type, extra, p); +} + +#ifdef USE_THREADS + +void +erts_alcu_free_ts(ErtsAlcType_t type, void *extra, void *p) +{ + Allctr_t *allctr = (Allctr_t *) extra; + erts_mtx_lock(&allctr->mutex); + do_erts_alcu_free(type, extra, p); + erts_mtx_unlock(&allctr->mutex); +} + +void +erts_alcu_free_thr_spec(ErtsAlcType_t type, void *extra, void *p) +{ + ErtsAllocatorThrSpec_t *tspec = (ErtsAllocatorThrSpec_t *) extra; + int ix = erts_alc_get_thr_ix(); + int unlock; + Allctr_t *allctr; + + ASSERT(ix > 0); + if (ix < tspec->size) { + allctr = tspec->allctr[ix]; + unlock = 0; + } + else { + allctr = tspec->allctr[0]; + unlock = 1; + erts_mtx_lock(&allctr->mutex); + } + + do_erts_alcu_free(type, allctr, p); + if (unlock) + erts_mtx_unlock(&allctr->mutex); +} + +void +erts_alcu_free_thr_pref(ErtsAlcType_t type, void *unused, void *p) +{ + if (p) { + void *ptr = (void *) (((char *) p) - sizeof(Uint)); + Allctr_t *allctr = *((Allctr_t **) ptr); + erts_mtx_lock(&allctr->mutex); + do_erts_alcu_free(type, allctr, ptr); + erts_mtx_unlock(&allctr->mutex); + } +} + +#endif + +/* ------------------------------------------------------------------------- */ + +static ERTS_INLINE void * +do_erts_alcu_realloc(ErtsAlcType_t type, + void *extra, + void *p, + Uint size, + Uint flgs) +{ + Allctr_t *allctr = (Allctr_t *) extra; + Block_t *blk; + void *res; + + ASSERT(initialized); + + ASSERT(allctr); + + ERTS_ALCU_DBG_CHK_THR_SPEC(allctr); + + if (!p) { + res = do_erts_alcu_alloc(type, extra, size); + INC_CC(allctr->calls.this_realloc); + DEC_CC(allctr->calls.this_alloc); + return res; + } + +#if ALLOC_ZERO_EQ_NULL + if (!size) { + ASSERT(p); + do_erts_alcu_free(type, extra, p); + INC_CC(allctr->calls.this_realloc); + DEC_CC(allctr->calls.this_free); + return NULL; + } +#endif + + INC_CC(allctr->calls.this_realloc); + + blk = UMEM2BLK(p); + + if (size < allctr->sbc_threshold) { + if (IS_MBC_BLK(blk)) + res = mbc_realloc(allctr, p, size, flgs); + else { + Uint used_sz = allctr->sbc_header_size + ABLK_HDR_SZ + size; + Uint crr_sz; + Uint diff_sz_val; + Uint crr_sz_val; + +#if HAVE_ERTS_MSEG + if (IS_SYS_ALLOC_CARRIER(BLK2SBC(allctr, blk))) +#endif + crr_sz = SYS_ALLOC_CARRIER_CEILING(used_sz); +#if HAVE_ERTS_MSEG + else + crr_sz = MSEG_UNIT_CEILING(used_sz); +#endif + diff_sz_val = crr_sz - used_sz; + if (diff_sz_val < (~((Uint) 0) / 100)) + crr_sz_val = crr_sz; + else { + /* div both by 128 */ + crr_sz_val = crr_sz >> 7; + /* A sys_alloc carrier could potentially be + smaller than 128 bytes (but not likely) */ + if (crr_sz_val == 0) + goto do_carrier_resize; + diff_sz_val >>= 7; + } + + if (100*diff_sz_val < allctr->sbc_move_threshold*crr_sz_val) + /* Data won't be copied into a new carrier... */ + goto do_carrier_resize; + else if (flgs & ERTS_ALCU_FLG_FAIL_REALLOC_MOVE) + return NULL; + + res = mbc_alloc(allctr, size); + if (res) { + sys_memcpy((void*) res, + (void*) p, + MIN(BLK_SZ(blk) - ABLK_HDR_SZ, size)); + destroy_carrier(allctr, blk); + } + } + } + else { + Block_t *new_blk; + if(IS_SBC_BLK(blk)) { + do_carrier_resize: + new_blk = resize_carrier(allctr, blk, size, CFLG_SBC); + res = new_blk ? BLK2UMEM(new_blk) : NULL; + } + else if (flgs & ERTS_ALCU_FLG_FAIL_REALLOC_MOVE) + return NULL; + else { + new_blk = create_carrier(allctr, size, CFLG_SBC); + if (new_blk) { + res = BLK2UMEM(new_blk); + sys_memcpy((void *) res, + (void *) p, + MIN(BLK_SZ(blk) - ABLK_HDR_SZ, size)); + mbc_free(allctr, p); + } + else + res = NULL; + } + } + + return res; +} + +void * +erts_alcu_realloc(ErtsAlcType_t type, void *extra, void *p, Uint size) +{ + void *res; + res = do_erts_alcu_realloc(type, extra, p, size, 0); + DEBUG_CHECK_ALIGNMENT(res); + return res; +} + +void * +erts_alcu_realloc_mv(ErtsAlcType_t type, void *extra, void *p, Uint size) +{ + void *res; + res = do_erts_alcu_alloc(type, extra, size); + if (!res) + res = erts_alcu_realloc(type, extra, p, size); + else { + Block_t *blk; + size_t cpy_size; + + blk = UMEM2BLK(p); + cpy_size = BLK_SZ(blk) - ABLK_HDR_SZ; + if (cpy_size > size) + cpy_size = size; + sys_memcpy(res, p, cpy_size); + do_erts_alcu_free(type, extra, p); + } + DEBUG_CHECK_ALIGNMENT(res); + return res; +} + + +#ifdef USE_THREADS + +void * +erts_alcu_realloc_ts(ErtsAlcType_t type, void *extra, void *ptr, Uint size) +{ + Allctr_t *allctr = (Allctr_t *) extra; + void *res; + erts_mtx_lock(&allctr->mutex); + res = do_erts_alcu_realloc(type, extra, ptr, size, 0); + erts_mtx_unlock(&allctr->mutex); + DEBUG_CHECK_ALIGNMENT(res); + return res; +} + +void * +erts_alcu_realloc_mv_ts(ErtsAlcType_t type, void *extra, void *p, Uint size) +{ + Allctr_t *allctr = (Allctr_t *) extra; + void *res; + erts_mtx_lock(&allctr->mutex); + res = do_erts_alcu_alloc(type, extra, size); + if (!res) + res = erts_alcu_realloc_ts(type, extra, p, size); + else { + Block_t *blk; + size_t cpy_size; + + blk = UMEM2BLK(p); + cpy_size = BLK_SZ(blk) - ABLK_HDR_SZ; + if (cpy_size > size) + cpy_size = size; + sys_memcpy(res, p, cpy_size); + do_erts_alcu_free(type, extra, p); + } + erts_mtx_unlock(&allctr->mutex); + DEBUG_CHECK_ALIGNMENT(res); + return res; +} + +void * +erts_alcu_realloc_thr_spec(ErtsAlcType_t type, void *extra, + void *ptr, Uint size) +{ + ErtsAllocatorThrSpec_t *tspec = (ErtsAllocatorThrSpec_t *) extra; + int ix = erts_alc_get_thr_ix(); + Allctr_t *allctr; + int unlock; + void *res; + + ASSERT(ix > 0); + if (ix < tspec->size) { + allctr = tspec->allctr[ix]; + unlock = 0; + } + else { + allctr = tspec->allctr[0]; + unlock = 1; + erts_mtx_lock(&allctr->mutex); + } + + res = do_erts_alcu_realloc(type, allctr, ptr, size, 0); + + if (unlock) + erts_mtx_unlock(&allctr->mutex); + + DEBUG_CHECK_ALIGNMENT(res); + + return res; +} + +void * +erts_alcu_realloc_mv_thr_spec(ErtsAlcType_t type, void *extra, + void *ptr, Uint size) +{ + ErtsAllocatorThrSpec_t *tspec = (ErtsAllocatorThrSpec_t *) extra; + int ix = erts_alc_get_thr_ix(); + Allctr_t *allctr; + int unlock; + void *res; + + ASSERT(ix > 0); + if (ix < tspec->size) { + allctr = tspec->allctr[ix]; + unlock = 0; + } + else { + allctr = tspec->allctr[0]; + unlock = 1; + erts_mtx_lock(&allctr->mutex); + } + + + res = do_erts_alcu_alloc(type, allctr, size); + if (!res) { + if (unlock) + erts_mtx_unlock(&allctr->mutex); + res = erts_alcu_realloc_thr_spec(type, allctr, ptr, size); + } + else { + Block_t *blk; + size_t cpy_size; + + blk = UMEM2BLK(ptr); + cpy_size = BLK_SZ(blk) - ABLK_HDR_SZ; + if (cpy_size > size) + cpy_size = size; + sys_memcpy(res, ptr, cpy_size); + do_erts_alcu_free(type, allctr, ptr); + if (unlock) + erts_mtx_unlock(&allctr->mutex); + } + + DEBUG_CHECK_ALIGNMENT(res); + + return res; +} + +void * +erts_alcu_realloc_thr_pref(ErtsAlcType_t type, void *extra, void *p, Uint size) +{ + ErtsAllocatorThrSpec_t *tspec = (ErtsAllocatorThrSpec_t *) extra; + int ix; + void *ptr, *res; + Allctr_t *pref_allctr, *used_allctr; + + if (!p) + return erts_alcu_alloc_thr_pref(type, extra, size); + + ptr = (void *) (((char *) p) - sizeof(Uint)); + used_allctr = *((Allctr_t **) ptr); + + ix = erts_alc_get_thr_ix(); + ASSERT(ix > 0); + if (ix >= tspec->size) + ix = (ix % (tspec->size - 1)) + 1; + pref_allctr = tspec->allctr[ix]; + ASSERT(used_allctr && pref_allctr); + + erts_mtx_lock(&used_allctr->mutex); + res = do_erts_alcu_realloc(type, + used_allctr, + ptr, + size + sizeof(Uint), + (pref_allctr != used_allctr + ? ERTS_ALCU_FLG_FAIL_REALLOC_MOVE + : 0)); + erts_mtx_unlock(&used_allctr->mutex); + if (res) { + ASSERT(used_allctr == *((Allctr_t **) res)); + res = (void *) (((char *) res) + sizeof(Uint)); + DEBUG_CHECK_ALIGNMENT(res); + } + else { + erts_mtx_lock(&pref_allctr->mutex); + res = do_erts_alcu_alloc(type, pref_allctr, size + sizeof(Uint)); + erts_mtx_unlock(&pref_allctr->mutex); + if (res) { + Block_t *blk; + size_t cpy_size; + + *((Allctr_t **) res) = pref_allctr; + res = (void *) (((char *) res) + sizeof(Uint)); + + DEBUG_CHECK_ALIGNMENT(res); + + erts_mtx_lock(&used_allctr->mutex); + blk = UMEM2BLK(ptr); + cpy_size = BLK_SZ(blk) - ABLK_HDR_SZ - sizeof(Uint); + if (cpy_size > size) + cpy_size = size; + sys_memcpy(res, p, cpy_size); + do_erts_alcu_free(type, used_allctr, ptr); + erts_mtx_unlock(&used_allctr->mutex); + } + } + + return res; +} + + +void * +erts_alcu_realloc_mv_thr_pref(ErtsAlcType_t type, void *extra, + void *p, Uint size) +{ + ErtsAllocatorThrSpec_t *tspec = (ErtsAllocatorThrSpec_t *) extra; + int ix; + void *ptr, *res; + Allctr_t *pref_allctr, *used_allctr; + + if (!p) + return erts_alcu_alloc_thr_pref(type, extra, size); + + ptr = (void *) (((char *) p) - sizeof(Uint)); + used_allctr = *((Allctr_t **) ptr); + + ix = erts_alc_get_thr_ix(); + ASSERT(ix > 0); + if (ix >= tspec->size) + ix = (ix % (tspec->size - 1)) + 1; + pref_allctr = tspec->allctr[ix]; + ASSERT(used_allctr && pref_allctr); + + erts_mtx_lock(&pref_allctr->mutex); + res = do_erts_alcu_alloc(type, pref_allctr, size + sizeof(Uint)); + if (!res) { + erts_mtx_unlock(&pref_allctr->mutex); + res = erts_alcu_realloc_thr_pref(type, extra, p, size); + } + else { + Block_t *blk; + size_t cpy_size; + Allctr_t *allctr; + + *((Allctr_t **) res) = pref_allctr; + res = (void *) (((char *) res) + sizeof(Uint)); + + DEBUG_CHECK_ALIGNMENT(res); + + if (used_allctr == pref_allctr) + allctr = pref_allctr; + else { + erts_mtx_unlock(&pref_allctr->mutex); + allctr = used_allctr; + erts_mtx_lock(&allctr->mutex); + } + + blk = UMEM2BLK(ptr); + cpy_size = BLK_SZ(blk) - ABLK_HDR_SZ - sizeof(Uint); + if (cpy_size > size) + cpy_size = size; + sys_memcpy(res, p, cpy_size); + do_erts_alcu_free(type, allctr, ptr); + erts_mtx_unlock(&allctr->mutex); + } + + return res; +} + +#endif + +/* ------------------------------------------------------------------------- */ + +int +erts_alcu_start(Allctr_t *allctr, AllctrInit_t *init) +{ + /* erts_alcu_start assumes that allctr has been zeroed */ + + if (!initialized) + goto error; + +#if HAVE_ERTS_MSEG + { + ErtsMsegOpt_t mseg_opt = ERTS_MSEG_DEFAULT_OPT_INITIALIZER; + + sys_memcpy((void *) &allctr->mseg_opt, + (void *) &mseg_opt, + sizeof(ErtsMsegOpt_t)); + } +#endif + + allctr->name_prefix = init->name_prefix; + if (!allctr->name_prefix) + goto error; + + allctr->alloc_no = init->alloc_no; + if (allctr->alloc_no < ERTS_ALC_A_MIN + || ERTS_ALC_A_MAX < allctr->alloc_no) + allctr->alloc_no = ERTS_ALC_A_INVALID; + + if (!allctr->vsn_str) + goto error; + + allctr->name.alloc = THE_NON_VALUE; + allctr->name.realloc = THE_NON_VALUE; + allctr->name.free = THE_NON_VALUE; + + if (init->tspec) + allctr->t = init->tspec; + else if (init->tpref) + allctr->t = init->tpref; + else + allctr->t = 0; + + allctr->ramv = init->ramv; + allctr->main_carrier_size = init->mmbcs; + allctr->sbc_threshold = init->sbct; +#if HAVE_ERTS_MSEG + allctr->mseg_opt.abs_shrink_th = init->asbcst; + allctr->mseg_opt.rel_shrink_th = init->rsbcst; +#endif + allctr->sbc_move_threshold = init->rsbcmt; + allctr->mbc_move_threshold = init->rmbcmt; +#if HAVE_ERTS_MSEG + allctr->max_mseg_sbcs = init->mmsbc; + allctr->max_mseg_mbcs = init->mmmbc; +#endif + + allctr->largest_mbc_size = MAX(init->lmbcs, init->smbcs); + allctr->smallest_mbc_size = init->smbcs; + allctr->mbc_growth_stages = MAX(1, init->mbcgs); + + if (allctr->min_block_size < ABLK_HDR_SZ) + goto error; + allctr->min_block_size = UNIT_CEILING(allctr->min_block_size + + sizeof(Uint)); + +#if HAVE_ERTS_MSEG + if (allctr->mseg_opt.abs_shrink_th > ~((Uint) 0) / 100) + allctr->mseg_opt.abs_shrink_th = ~((Uint) 0) / 100; +#endif + +#ifdef USE_THREADS + if (init->ts) { + allctr->thread_safe = 1; + +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_mtx_init_x_opt(&allctr->mutex, + "alcu_allocator", + make_small(allctr->alloc_no), + ERTS_LCNT_LT_ALLOC); +#else + erts_mtx_init_x(&allctr->mutex, + "alcu_allocator", + make_small(allctr->alloc_no)); +#endif /*ERTS_ENABLE_LOCK_COUNT*/ + +#ifdef DEBUG + allctr->debug.saved_tid = 0; +#endif + } +#endif + + if(!allctr->get_free_block + || !allctr->link_free_block + || !allctr->unlink_free_block + || !allctr->info_options) + goto error; + + if (!allctr->get_next_mbc_size) + allctr->get_next_mbc_size = get_next_mbc_size; + + if (allctr->mbc_header_size < sizeof(Carrier_t)) + goto error; +#ifdef USE_THREADS + if (init->tpref) { + allctr->mbc_header_size = (UNIT_CEILING(allctr->mbc_header_size + + FBLK_FTR_SZ + + ABLK_HDR_SZ + + sizeof(Uint)) + - ABLK_HDR_SZ + - sizeof(Uint)); + allctr->sbc_header_size = (UNIT_CEILING(sizeof(Carrier_t) + + FBLK_FTR_SZ + + ABLK_HDR_SZ + + sizeof(Uint)) + - ABLK_HDR_SZ + - sizeof(Uint)); + } + else +#endif + { + allctr->mbc_header_size = (UNIT_CEILING(allctr->mbc_header_size + + FBLK_FTR_SZ + + ABLK_HDR_SZ) + - ABLK_HDR_SZ); + allctr->sbc_header_size = (UNIT_CEILING(sizeof(Carrier_t) + + FBLK_FTR_SZ + + ABLK_HDR_SZ) + - ABLK_HDR_SZ); + } + + if (allctr->main_carrier_size) { + Block_t *blk; + + blk = create_carrier(allctr, + allctr->main_carrier_size, + CFLG_MBC + | CFLG_FORCE_SIZE + | CFLG_FORCE_SYS_ALLOC + | CFLG_MAIN_CARRIER); + if (!blk) + goto error; + + (*allctr->link_free_block)(allctr, blk); + + HARD_CHECK_BLK_CARRIER(allctr, blk); + + } + + return 1; + + error: + +#ifdef USE_THREADS + if (allctr->thread_safe) + erts_mtx_destroy(&allctr->mutex); +#endif + + return 0; + +} + +/* ------------------------------------------------------------------------- */ + +void +erts_alcu_stop(Allctr_t *allctr) +{ + allctr->stopped = 1; + + while (allctr->sbc_list.first) + destroy_carrier(allctr, SBC2BLK(allctr, allctr->sbc_list.first)); + while (allctr->mbc_list.first) + destroy_carrier(allctr, MBC2FBLK(allctr, allctr->mbc_list.first)); + +#ifdef USE_THREADS + if (allctr->thread_safe) + erts_mtx_destroy(&allctr->mutex); +#endif + +} + +/* ------------------------------------------------------------------------- */ + +void +erts_alcu_init(AlcUInit_t *init) +{ + +#if HAVE_ERTS_MSEG + mseg_unit_size = erts_mseg_unit_size(); + + if (mseg_unit_size % sizeof(Unit_t)) /* A little paranoid... */ + erl_exit(-1, + "Mseg unit size (%d) not evenly divideble by " + "internal unit size of alloc_util (%d)\n", + mseg_unit_size, + sizeof(Unit_t)); + + max_mseg_carriers = init->mmc; + sys_alloc_carrier_size = MSEG_UNIT_CEILING(init->ycs); +#else /* #if HAVE_ERTS_MSEG */ + sys_alloc_carrier_size = ((init->ycs + 4095) / 4096) * 4096; +#endif + +#ifdef DEBUG + carrier_alignment = sizeof(Unit_t); +#endif + + erts_mtx_init(&init_atoms_mtx, "alcu_init_atoms"); + + atoms_initialized = 0; + initialized = 1; +} + + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *\ + * NOTE: erts_alcu_test() is only supposed to be used for testing. * + * * + * Keep alloc_SUITE_data/allocator_test.h updated if changes are made * + * to erts_alcu_test() * +\* */ + +unsigned long +erts_alcu_test(unsigned long op, unsigned long a1, unsigned long a2) +{ + switch (op) { + case 0x000: return (unsigned long) BLK_SZ((Block_t *) a1); + case 0x001: return (unsigned long) BLK_UMEM_SZ((Block_t *) a1); + case 0x002: return (unsigned long) IS_PREV_BLK_FREE((Block_t *) a1); + case 0x003: return (unsigned long) IS_FREE_BLK((Block_t *) a1); + case 0x004: return (unsigned long) IS_LAST_BLK((Block_t *) a1); + case 0x005: return (unsigned long) UMEM2BLK((void *) a1); + case 0x006: return (unsigned long) BLK2UMEM((Block_t *) a1); + case 0x007: return (unsigned long) IS_SB_CARRIER((Carrier_t *) a1); + case 0x008: return (unsigned long) IS_SBC_BLK((Block_t *) a1); + case 0x009: return (unsigned long) IS_MB_CARRIER((Carrier_t *) a1); + case 0x00a: return (unsigned long) IS_MSEG_CARRIER((Carrier_t *) a1); + case 0x00b: return (unsigned long) CARRIER_SZ((Carrier_t *) a1); + case 0x00c: return (unsigned long) SBC2BLK((Allctr_t *) a1, + (Carrier_t *) a2); + case 0x00d: return (unsigned long) BLK2SBC((Allctr_t *) a1, + (Block_t *) a2); + case 0x00e: return (unsigned long) MBC2FBLK((Allctr_t *) a1, + (Carrier_t *) a2); + case 0x00f: return (unsigned long) FBLK2MBC((Allctr_t *) a1, + (Block_t *) a2); + case 0x010: return (unsigned long) ((Allctr_t *) a1)->mbc_list.first; + case 0x011: return (unsigned long) ((Allctr_t *) a1)->mbc_list.last; + case 0x012: return (unsigned long) ((Allctr_t *) a1)->sbc_list.first; + case 0x013: return (unsigned long) ((Allctr_t *) a1)->sbc_list.last; + case 0x014: return (unsigned long) ((Carrier_t *) a1)->next; + case 0x015: return (unsigned long) ((Carrier_t *) a1)->prev; + case 0x016: return (unsigned long) ABLK_HDR_SZ; + case 0x017: return (unsigned long) ((Allctr_t *) a1)->min_block_size; + case 0x018: return (unsigned long) NXT_BLK((Block_t *) a1); + case 0x019: return (unsigned long) PREV_BLK((Block_t *) a1); + case 0x01a: return (unsigned long) IS_FIRST_BLK((Block_t *) a1); + case 0x01b: return (unsigned long) sizeof(Unit_t); + default: ASSERT(0); return ~((unsigned long) 0); + } +} + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *\ + * Debug functions * +\* */ + +#ifdef ERTS_ALLOC_UTIL_HARD_DEBUG + +static void +check_blk_carrier(Allctr_t *allctr, Block_t *iblk) +{ + Carrier_t *crr; + CarrierList_t *cl; + + if (IS_SBC_BLK(iblk)) { + Carrier_t *sbc = BLK2SBC(allctr, iblk); + + ASSERT(SBC2BLK(allctr, sbc) == iblk); + ASSERT(IS_ALLOCED_BLK(iblk)); + ASSERT(IS_FIRST_BLK(iblk)); + ASSERT(IS_LAST_BLK(iblk)); + ASSERT(CARRIER_SZ(sbc) - allctr->sbc_header_size >= BLK_SZ(iblk)); +#if HAVE_ERTS_MSEG + if (IS_MSEG_CARRIER(sbc)) { + ASSERT(CARRIER_SZ(sbc) % mseg_unit_size == 0); + } +#endif + crr = sbc; + cl = &allctr->sbc_list; + } + else { + Carrier_t *mbc = NULL; + Block_t *prev_blk = NULL; + Block_t *blk; + char *carrier_end; + Uint is_free_blk; + Uint tot_blk_sz; + Uint blk_sz; + + blk = iblk; + tot_blk_sz = 0; + + while (1) { + + if (prev_blk) { + ASSERT(NXT_BLK(prev_blk) == blk); + if (IS_FREE_BLK(prev_blk)) { + ASSERT(IS_PREV_BLK_FREE(blk)); + ASSERT(prev_blk == PREV_BLK(blk)); + } + else { + ASSERT(IS_PREV_BLK_ALLOCED(blk)); + } + } + + if (mbc) { + if (blk == iblk) + break; + ASSERT(((Block_t *) mbc) < blk && blk < iblk); + } + else + ASSERT(blk >= iblk); + + + ASSERT(IS_MBC_BLK(blk)); + + blk_sz = BLK_SZ(blk); + + ASSERT(blk_sz % sizeof(Unit_t) == 0); + ASSERT(blk_sz >= allctr->min_block_size); + + tot_blk_sz += blk_sz; + + is_free_blk = (int) IS_FREE_BLK(blk); + if(is_free_blk) { + if (IS_NOT_LAST_BLK(blk)) + ASSERT(*((Uint *) (((char *) blk)+blk_sz-sizeof(Uint))) + == blk_sz); + } + + if (allctr->check_block) + (*allctr->check_block)(allctr, blk, (int) is_free_blk); + + if (IS_LAST_BLK(blk)) { + carrier_end = ((char *) NXT_BLK(blk)) + sizeof(Uint); + mbc = *((Carrier_t **) NXT_BLK(blk)); + prev_blk = NULL; + blk = MBC2FBLK(allctr, mbc); + ASSERT(IS_FIRST_BLK(blk)); + } + else { + prev_blk = blk; + blk = NXT_BLK(blk); + } + } + + ASSERT(IS_MB_CARRIER(mbc)); + ASSERT((((char *) mbc) + + allctr->mbc_header_size + + tot_blk_sz + + sizeof(Uint)) == carrier_end); + ASSERT(((char *) mbc) + CARRIER_SZ(mbc) == carrier_end); + + if (allctr->check_mbc) + (*allctr->check_mbc)(allctr, mbc); + +#if HAVE_ERTS_MSEG + if (IS_MSEG_CARRIER(mbc)) { + ASSERT(CARRIER_SZ(mbc) % mseg_unit_size == 0); + } +#endif + crr = mbc; + cl = &allctr->mbc_list; + } + + if (cl->first == crr) { + ASSERT(!crr->prev); + } + else { + ASSERT(crr->prev); + ASSERT(crr->prev->next == crr); + } + if (cl->last == crr) { + ASSERT(!crr->next); + } + else { + ASSERT(crr->next); + ASSERT(crr->next->prev == crr); + } +} + +#endif diff --git a/erts/emulator/beam/erl_alloc_util.h b/erts/emulator/beam/erl_alloc_util.h new file mode 100644 index 0000000000..10b11661e6 --- /dev/null +++ b/erts/emulator/beam/erl_alloc_util.h @@ -0,0 +1,342 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2002-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifndef ERL_ALLOC_UTIL__ +#define ERL_ALLOC_UTIL__ + +#define ERTS_ALCU_VSN_STR "2.2" + +#include "erl_alloc_types.h" + +typedef struct Allctr_t_ Allctr_t; + +typedef struct { + Uint ycs; + Uint mmc; +} AlcUInit_t; + +typedef struct { + char *name_prefix; + ErtsAlcType_t alloc_no; + int ts; + int tspec; + int tpref; + int ramv; + Uint sbct; + Uint asbcst; + Uint rsbcst; + Uint rsbcmt; + Uint rmbcmt; + Uint mmbcs; + Uint mmsbc; + Uint mmmbc; + Uint lmbcs; + Uint smbcs; + Uint mbcgs; +} AllctrInit_t; + +typedef struct { + Uint blocks; + Uint carriers; +} AllctrSize_t; + +#ifndef SMALL_MEMORY + +#define ERTS_DEFAULT_ALCU_INIT { \ + 1024*1024, /* (bytes) ycs: sys_alloc carrier size */\ + 1024 /* (amount) mmc: max mseg carriers */\ +} + +#define ERTS_DEFAULT_ALLCTR_INIT { \ + NULL, \ + ERTS_ALC_A_INVALID, /* (number) alloc_no: allocator number */\ + 1, /* (bool) ts: thread safe */\ + 0, /* (bool) tspec: thread specific */\ + 0, /* (bool) tpref: thread preferred */\ + 0, /* (bool) ramv: realloc always moves */\ + 512*1024, /* (bytes) sbct: sbc threshold */\ + 2*1024*2024, /* (amount) asbcst: abs sbc shrink threshold */\ + 20, /* (%) rsbcst: rel sbc shrink threshold */\ + 80, /* (%) rsbcmt: rel sbc move threshold */\ + 50, /* (%) rmbcmt: rel mbc move threshold */\ + 1024*1024, /* (bytes) mmbcs: main multiblock carrier size */\ + 256, /* (amount) mmsbc: max mseg sbcs */\ + 10, /* (amount) mmmbc: max mseg mbcs */\ + 10*1024*1024, /* (bytes) lmbcs: largest mbc size */\ + 1024*1024, /* (bytes) smbcs: smallest mbc size */\ + 10 /* (amount) mbcgs: mbc growth stages */\ +} + +#else /* if SMALL_MEMORY */ + +#define ERTS_DEFAULT_ALCU_INIT { \ + 128*1024, /* (bytes) ycs: sys_alloc carrier size */\ + 1024 /* (amount) mmc: max mseg carriers */\ +} + +#define ERTS_DEFAULT_ALLCTR_INIT { \ + NULL, \ + ERTS_ALC_A_INVALID, /* (number) alloc_no: allocator number */\ + 1, /* (bool) ts: thread safe */\ + 0, /* (bool) tspec: thread specific */\ + 0, /* (bool) tpref: thread preferred */\ + 0, /* (bool) ramv: realloc always moves */\ + 64*1024, /* (bytes) sbct: sbc threshold */\ + 2*1024*2024, /* (amount) asbcst: abs sbc shrink threshold */\ + 20, /* (%) rsbcst: rel sbc shrink threshold */\ + 80, /* (%) rsbcmt: rel sbc move threshold */\ + 128*1024, /* (bytes) mmbcs: main multiblock carrier size */\ + 256, /* (amount) mmsbc: max mseg sbcs */\ + 10, /* (amount) mmmbc: max mseg mbcs */\ + 1024*1024, /* (bytes) lmbcs: largest mbc size */\ + 128*1024, /* (bytes) smbcs: smallest mbc size */\ + 10 /* (amount) mbcgs: mbc growth stages */\ +} + +#endif + +void * erts_alcu_alloc(ErtsAlcType_t, void *, Uint); +void * erts_alcu_realloc(ErtsAlcType_t, void *, void *, Uint); +void * erts_alcu_realloc_mv(ErtsAlcType_t, void *, void *, Uint); +void erts_alcu_free(ErtsAlcType_t, void *, void *); +#ifdef USE_THREADS +void * erts_alcu_alloc_ts(ErtsAlcType_t, void *, Uint); +void * erts_alcu_realloc_ts(ErtsAlcType_t, void *, void *, Uint); +void * erts_alcu_realloc_mv_ts(ErtsAlcType_t, void *, void *, Uint); +void erts_alcu_free_ts(ErtsAlcType_t, void *, void *); +void * erts_alcu_alloc_thr_spec(ErtsAlcType_t, void *, Uint); +void * erts_alcu_realloc_thr_spec(ErtsAlcType_t, void *, void *, Uint); +void * erts_alcu_realloc_mv_thr_spec(ErtsAlcType_t, void *, void *, Uint); +void erts_alcu_free_thr_spec(ErtsAlcType_t, void *, void *); +void * erts_alcu_alloc_thr_pref(ErtsAlcType_t, void *, Uint); +void * erts_alcu_realloc_thr_pref(ErtsAlcType_t, void *, void *, Uint); +void * erts_alcu_realloc_mv_thr_pref(ErtsAlcType_t, void *, void *, Uint); +void erts_alcu_free_thr_pref(ErtsAlcType_t, void *, void *); +#endif +Eterm erts_alcu_au_info_options(int *, void *, Uint **, Uint *); +Eterm erts_alcu_info_options(Allctr_t *, int *, void *, Uint **, Uint *); +Eterm erts_alcu_sz_info(Allctr_t *, int, int *, void *, Uint **, Uint *); +Eterm erts_alcu_info(Allctr_t *, int, int *, void *, Uint **, Uint *); +void erts_alcu_init(AlcUInit_t *); +void erts_alcu_current_size(Allctr_t *, AllctrSize_t *); + +#endif + +#if defined(GET_ERL_ALLOC_UTIL_IMPL) && !defined(ERL_ALLOC_UTIL_IMPL__) +#define ERL_ALLOC_UTIL_IMPL__ + +#ifdef USE_THREADS +#define ERL_THREADS_EMU_INTERNAL__ +#include "erl_threads.h" +#endif + +#include "erl_mseg.h" + +#undef ERTS_ALLOC_UTIL_HARD_DEBUG +#ifdef DEBUG +# if 0 +# define ERTS_ALLOC_UTIL_HARD_DEBUG +# endif +#endif + +#undef MIN +#undef MAX +#define MIN(X, Y) ((X) < (Y) ? (X) : (Y)) +#define MAX(X, Y) ((X) > (Y) ? (X) : (Y)) +#define FLOOR(X, I) (((X)/(I))*(I)) +#define CEILING(X, I) ((((X) - 1)/(I) + 1)*(I)) + +#undef WORD_MASK +#define INV_WORD_MASK ((Uint) (sizeof(Uint) - 1)) +#define WORD_MASK (~INV_WORD_MASK) +#define WORD_FLOOR(X) ((X) & WORD_MASK) +#define WORD_CEILING(X) WORD_FLOOR((X) + INV_WORD_MASK) + +#undef UNIT_MASK +#define INV_UNIT_MASK ((Uint) (sizeof(Unit_t) - 1)) +#define UNIT_MASK (~INV_UNIT_MASK) +#define UNIT_FLOOR(X) ((X) & UNIT_MASK) +#define UNIT_CEILING(X) UNIT_FLOOR((X) + INV_UNIT_MASK) + + +#define SZ_MASK (~((Uint) 0) << 3) +#define FLG_MASK (~(SZ_MASK)) + + +#define BLK_SZ(B) \ + (*((Block_t *) (B)) & SZ_MASK) + +#define CARRIER_SZ(C) \ + ((C)->chdr & SZ_MASK) + +typedef union {char c[8]; long l; double d;} Unit_t; + +typedef struct Carrier_t_ Carrier_t; +struct Carrier_t_ { + Uint chdr; + Carrier_t *next; + Carrier_t *prev; +}; + +typedef struct { + Carrier_t *first; + Carrier_t *last; +} CarrierList_t; + +typedef Uint Block_t; +typedef Uint FreeBlkFtr_t; + +typedef struct { + Uint giga_no; + Uint no; +} CallCounter_t; + +typedef struct { + Uint no; + Uint size; +} StatValues_t; + +typedef struct { + StatValues_t curr_mseg; + StatValues_t curr_sys_alloc; + StatValues_t max; + StatValues_t max_ever; + struct { + StatValues_t curr; + StatValues_t max; + StatValues_t max_ever; + } blocks; +} CarriersStats_t; + +struct Allctr_t_ { + + /* Allocator name prefix */ + char * name_prefix; + + /* Allocator number */ + ErtsAlcType_t alloc_no; + + /* Alloc, realloc and free names as atoms */ + struct { + Eterm alloc; + Eterm realloc; + Eterm free; + } name; + + /* Version string */ + char * vsn_str; + + /* Options */ + int t; + int ramv; + Uint sbc_threshold; + Uint sbc_move_threshold; + Uint mbc_move_threshold; + Uint main_carrier_size; + Uint max_mseg_sbcs; + Uint max_mseg_mbcs; + Uint largest_mbc_size; + Uint smallest_mbc_size; + Uint mbc_growth_stages; +#if HAVE_ERTS_MSEG + ErtsMsegOpt_t mseg_opt; +#endif + + /* */ + Uint mbc_header_size; + Uint sbc_header_size; + Uint min_mbc_size; + Uint min_mbc_first_free_size; + Uint min_block_size; + + /* Carriers */ + CarrierList_t mbc_list; + CarrierList_t sbc_list; + + /* Main carrier (if there is one) */ + Carrier_t * main_carrier; + + /* Callback functions (first 4 are mandatory) */ + Block_t * (*get_free_block) (Allctr_t *, Uint, + Block_t *, Uint); + void (*link_free_block) (Allctr_t *, Block_t *); + void (*unlink_free_block) (Allctr_t *, Block_t *); + Eterm (*info_options) (Allctr_t *, char *, int *, + void *, Uint **, Uint *); + + Uint (*get_next_mbc_size) (Allctr_t *); + void (*creating_mbc) (Allctr_t *, Carrier_t *); + void (*destroying_mbc) (Allctr_t *, Carrier_t *); + void (*init_atoms) (void); + +#ifdef ERTS_ALLOC_UTIL_HARD_DEBUG + void (*check_block) (Allctr_t *, Block_t *, int); + void (*check_mbc) (Allctr_t *, Carrier_t *); +#endif + +#ifdef USE_THREADS + /* Mutex for this allocator */ + erts_mtx_t mutex; + int thread_safe; + struct { + Allctr_t *prev; + Allctr_t *next; + } ts_list; +#endif + + int atoms_initialized; + + int stopped; + + /* Some statistics ... */ + struct { + CallCounter_t this_alloc; + CallCounter_t this_free; + CallCounter_t this_realloc; + CallCounter_t mseg_alloc; + CallCounter_t mseg_dealloc; + CallCounter_t mseg_realloc; + CallCounter_t sys_alloc; + CallCounter_t sys_free; + CallCounter_t sys_realloc; + } calls; + + CarriersStats_t sbcs; + CarriersStats_t mbcs; + +#ifdef DEBUG +#ifdef USE_THREADS + struct { + int saved_tid; + erts_tid_t tid; + } debug; +#endif +#endif +}; + +int erts_alcu_start(Allctr_t *, AllctrInit_t *); +void erts_alcu_stop(Allctr_t *); + +unsigned long erts_alcu_test(unsigned long, unsigned long, unsigned long); + + + +#endif /* #if defined(GET_ERL_ALLOC_UTIL_IMPL) + && !defined(ERL_ALLOC_UTIL_IMPL__) */ + diff --git a/erts/emulator/beam/erl_arith.c b/erts/emulator/beam/erl_arith.c new file mode 100644 index 0000000000..b692832677 --- /dev/null +++ b/erts/emulator/beam/erl_arith.c @@ -0,0 +1,2040 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1999-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* + * Arithmetic functions formerly found in beam_emu.c + * now available as bifs as erl_db_util and db_match_compile needs + * them. + */ + + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "erl_process.h" +#include "error.h" +#include "bif.h" +#include "big.h" +#include "atom.h" + +#ifndef MAX +# define MAX(x, y) (((x) > (y)) ? (x) : (y)) +#endif + +static Eterm shift(Process* p, Eterm arg1, Eterm arg2, int right); + +static ERTS_INLINE void maybe_shrink(Process* p, Eterm* hp, Eterm res, Uint alloc) +{ + Uint actual; + + if (is_immed(res)) { + if (p->heap <= hp && hp < p->htop) { + p->htop = hp; +#if defined(CHECK_FOR_HOLES) + } else { + erts_arith_shrink(p, hp); +#endif + } + } else if ((actual = bignum_header_arity(*hp)+1) < alloc) { + if (p->heap <= hp && hp < p->htop) { + p->htop = hp+actual; +#if defined(CHECK_FOR_HOLES) + } else { + erts_arith_shrink(p, hp+actual); +#endif + } + } +} + +/* + * BIF interfaces. They will only be from match specs and + * when a BIF is applied. + */ + +BIF_RETTYPE splus_1(BIF_ALIST_1) +{ + if (is_number(BIF_ARG_1)) { + BIF_RET(BIF_ARG_1); + } else { + BIF_ERROR(BIF_P, BADARITH); + } +} + +BIF_RETTYPE splus_2(BIF_ALIST_2) +{ + BIF_RET(erts_mixed_plus(BIF_P, BIF_ARG_1, BIF_ARG_2)); +} + +BIF_RETTYPE sminus_1(BIF_ALIST_1) +{ + BIF_RET(erts_mixed_minus(BIF_P, make_small(0), BIF_ARG_1)); +} + +BIF_RETTYPE sminus_2(BIF_ALIST_2) +{ + BIF_RET(erts_mixed_minus(BIF_P, BIF_ARG_1, BIF_ARG_2)); +} + +BIF_RETTYPE stimes_2(BIF_ALIST_2) +{ + BIF_RET(erts_mixed_times(BIF_P, BIF_ARG_1, BIF_ARG_2)); +} + +BIF_RETTYPE div_2(BIF_ALIST_2) +{ + BIF_RET(erts_mixed_div(BIF_P, BIF_ARG_1, BIF_ARG_2)); +} + +BIF_RETTYPE intdiv_2(BIF_ALIST_2) +{ + if (BIF_ARG_2 == SMALL_ZERO) { + BIF_ERROR(BIF_P, BADARITH); + } + if (is_both_small(BIF_ARG_1,BIF_ARG_2)){ + Sint ires = signed_val(BIF_ARG_1) / signed_val(BIF_ARG_2); + if (MY_IS_SSMALL(ires)) + BIF_RET(make_small(ires)); + } + BIF_RET(erts_int_div(BIF_P, BIF_ARG_1, BIF_ARG_2)); +} + +BIF_RETTYPE rem_2(BIF_ALIST_2) +{ + if (BIF_ARG_2 == SMALL_ZERO) { + BIF_ERROR(BIF_P, BADARITH); + } + if (is_both_small(BIF_ARG_1,BIF_ARG_2)){ + /* Is this really correct? Isn't there a difference between + remainder and modulo that is not defined in C? Well, I don't + remember, this is the way it's done in beam_emu anyway... */ + BIF_RET(make_small(signed_val(BIF_ARG_1) % signed_val(BIF_ARG_2))); + } + BIF_RET(erts_int_rem(BIF_P, BIF_ARG_1, BIF_ARG_2)); +} + +BIF_RETTYPE band_2(BIF_ALIST_2) +{ + if (is_both_small(BIF_ARG_1,BIF_ARG_2)){ + BIF_RET(BIF_ARG_1 & BIF_ARG_2); + } + BIF_RET(erts_band(BIF_P, BIF_ARG_1, BIF_ARG_2)); +} + +BIF_RETTYPE bor_2(BIF_ALIST_2) +{ + if (is_both_small(BIF_ARG_1,BIF_ARG_2)){ + BIF_RET(BIF_ARG_1 | BIF_ARG_2); + } + BIF_RET(erts_bor(BIF_P, BIF_ARG_1, BIF_ARG_2)); +} + +BIF_RETTYPE bxor_2(BIF_ALIST_2) +{ + if (is_both_small(BIF_ARG_1,BIF_ARG_2)){ + BIF_RET(make_small(signed_val(BIF_ARG_1) ^ signed_val(BIF_ARG_2))); + } + BIF_RET(erts_bxor(BIF_P, BIF_ARG_1, BIF_ARG_2)); +} + +BIF_RETTYPE bsl_2(Process* p, Eterm arg1, Eterm arg2) +{ + BIF_RET(shift(p, arg1, arg2, 0)); +} + +BIF_RETTYPE bsr_2(Process* p, Eterm arg1, Eterm arg2) +{ + BIF_RET(shift(p, arg1, arg2, 1)); +} + +static Eterm +shift(Process* p, Eterm arg1, Eterm arg2, int right) +{ + Sint i; + Sint ires; + Eterm tmp_big1[2]; + Eterm* bigp; + Uint need; + + if (right) { + if (is_small(arg2)) { + i = -signed_val(arg2); + if (is_small(arg1)) { + goto small_shift; + } else if (is_big(arg1)) { + if (i == 0) { + BIF_RET(arg1); + } + goto big_shift; + } + } else if (is_big(arg2)) { + /* + * N bsr NegativeBigNum == N bsl MAX_SMALL + * N bsr PositiveBigNum == N bsl MIN_SMALL + */ + arg2 = make_small(bignum_header_is_neg(*big_val(arg2)) ? + MAX_SMALL : MIN_SMALL); + goto do_bsl; + } + } else { + do_bsl: + if (is_small(arg2)) { + i = signed_val(arg2); + + if (is_small(arg1)) { + small_shift: + ires = signed_val(arg1); + + if (i == 0 || ires == 0) { + BIF_RET(arg1); + } else if (i < 0) { /* Right shift */ + i = -i; + if (i >= SMALL_BITS-1) { + arg1 = (ires < 0) ? SMALL_MINUS_ONE : SMALL_ZERO; + } else { + arg1 = make_small(ires >> i); + } + BIF_RET(arg1); + } else if (i < SMALL_BITS-1) { /* Left shift */ + if ((ires > 0 && ((~(Uint)0 << ((SMALL_BITS-1)-i)) & ires) == 0) || + ((~(Uint)0 << ((SMALL_BITS-1)-i)) & ~ires) == 0) { + arg1 = make_small(ires << i); + BIF_RET(arg1); + } + } + arg1 = small_to_big(ires, tmp_big1); + + big_shift: + if (i > 0) { /* Left shift. */ + ires = big_size(arg1) + (i / D_EXP); + } else { /* Right shift. */ + ires = big_size(arg1); + if (ires <= (-i / D_EXP)) + ires = 3; + else + ires -= (-i / D_EXP); + } + + /* + * Slightly conservative check the size to avoid + * allocating huge amounts of memory for bignums that + * clearly would overflow the arity in the header + * word. + */ + if (ires-8 > BIG_ARITY_MAX) { + BIF_ERROR(p, SYSTEM_LIMIT); + } + need = BIG_NEED_SIZE(ires+1); + bigp = HAlloc(p, need); + arg1 = big_lshift(arg1, i, bigp); + maybe_shrink(p, bigp, arg1, need); + if (is_nil(arg1)) { + /* + * This result must have been only slight larger + * than allowed since it wasn't caught by the + * previous test. + */ + BIF_ERROR(p, SYSTEM_LIMIT); + } + BIF_RET(arg1); + } else if (is_big(arg1)) { + if (i == 0) { + BIF_RET(arg1); + } + goto big_shift; + } + } else if (is_big(arg2)) { + if (bignum_header_is_neg(*big_val(arg2))) { + /* + * N bsl NegativeBigNum is either 0 or -1, depending on + * the sign of N. Since we don't believe this case + * is common, do the calculation with the minimum + * amount of code. + */ + arg2 = make_small(MIN_SMALL); + goto do_bsl; + } else if (is_small(arg1) || is_big(arg1)) { + /* + * N bsl PositiveBigNum is too large to represent. + */ + BIF_ERROR(p, SYSTEM_LIMIT); + } + /* Fall through if the left argument is not an integer. */ + } + } + BIF_ERROR(p, BADARITH); +} + +BIF_RETTYPE bnot_1(BIF_ALIST_1) +{ + Eterm ret; + + if (is_small(BIF_ARG_1)) { + ret = make_small(~signed_val(BIF_ARG_1)); + } else if (is_big(BIF_ARG_1)) { + Uint need = BIG_NEED_SIZE(big_size(BIF_ARG_1)+1); + Eterm* bigp = HAlloc(BIF_P, need); + + ret = big_bnot(BIF_ARG_1, bigp); + maybe_shrink(BIF_P, bigp, ret, need); + if (is_nil(ret)) { + BIF_ERROR(BIF_P, SYSTEM_LIMIT); + } + } else { + BIF_ERROR(BIF_P, BADARITH); + } + BIF_RET(ret); +} + +/* + * Implementation and interfaces for the rest of the runtime system. + * The functions that follow are only used in match specs and when + * arithmetic functions are applied. + */ + +Eterm +erts_mixed_plus(Process* p, Eterm arg1, Eterm arg2) +{ + Eterm tmp_big1[2]; + Eterm tmp_big2[2]; + Eterm res; + Eterm hdr; + FloatDef f1, f2; + dsize_t sz1, sz2, sz; + int need_heap; + Eterm* hp; + Sint ires; + + ERTS_FP_CHECK_INIT(p); + switch (arg1 & _TAG_PRIMARY_MASK) { + case TAG_PRIMARY_IMMED1: + switch ((arg1 & _TAG_IMMED1_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + switch (arg2 & _TAG_PRIMARY_MASK) { + case TAG_PRIMARY_IMMED1: + switch ((arg2 & _TAG_IMMED1_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + ires = signed_val(arg1) + signed_val(arg2); + ASSERT(MY_IS_SSMALL(ires) == IS_SSMALL(ires)); + if (MY_IS_SSMALL(ires)) { + return make_small(ires); + } else { + hp = HAlloc(p, 2); + res = small_to_big(ires, hp); + return res; + } + default: + badarith: + p->freason = BADARITH; + return THE_NON_VALUE; + } + case TAG_PRIMARY_BOXED: + hdr = *boxed_val(arg2); + switch ((hdr & _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_HEADER_POS_BIG >> _TAG_PRIMARY_SIZE): + case (_TAG_HEADER_NEG_BIG >> _TAG_PRIMARY_SIZE): + if (arg1 == SMALL_ZERO) { + return arg2; + } + arg1 = small_to_big(signed_val(arg1), tmp_big1); + goto do_big; + case (_TAG_HEADER_FLOAT >> _TAG_PRIMARY_SIZE): + f1.fd = signed_val(arg1); + GET_DOUBLE(arg2, f2); + goto do_float; + default: + goto badarith; + } + } + default: + goto badarith; + } + case TAG_PRIMARY_BOXED: + hdr = *boxed_val(arg1); + switch ((hdr & _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_HEADER_POS_BIG >> _TAG_PRIMARY_SIZE): + case (_TAG_HEADER_NEG_BIG >> _TAG_PRIMARY_SIZE): + switch (arg2 & _TAG_PRIMARY_MASK) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + switch ((arg2 & _TAG_IMMED1_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + if (arg2 == SMALL_ZERO) { + return arg1; + } + arg2 = small_to_big(signed_val(arg2), tmp_big2); + goto do_big; + default: + goto badarith; + } + case TAG_PRIMARY_BOXED: + hdr = *boxed_val(arg2); + switch ((hdr & _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_HEADER_POS_BIG >> _TAG_PRIMARY_SIZE): + case (_TAG_HEADER_NEG_BIG >> _TAG_PRIMARY_SIZE): + do_big: + sz1 = big_size(arg1); + sz2 = big_size(arg2); + sz = MAX(sz1, sz2)+1; + need_heap = BIG_NEED_SIZE(sz); + hp = HAlloc(p, need_heap); + res = big_plus(arg1, arg2, hp); + if (is_nil(res)) { + erts_arith_shrink(p, hp); + p->freason = SYSTEM_LIMIT; + return THE_NON_VALUE; + } + maybe_shrink(p, hp, res, need_heap); + return res; + case (_TAG_HEADER_FLOAT >> _TAG_PRIMARY_SIZE): + if (big_to_double(arg1, &f1.fd) < 0) { + goto badarith; + } + GET_DOUBLE(arg2, f2); + goto do_float; + default: + goto badarith; + } + } + case (_TAG_HEADER_FLOAT >> _TAG_PRIMARY_SIZE): + switch (arg2 & _TAG_PRIMARY_MASK) { + case TAG_PRIMARY_IMMED1: + switch ((arg2 & _TAG_IMMED1_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + GET_DOUBLE(arg1, f1); + f2.fd = signed_val(arg2); + goto do_float; + default: + goto badarith; + } + case TAG_PRIMARY_BOXED: + hdr = *boxed_val(arg2); + switch ((hdr & _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_HEADER_POS_BIG >> _TAG_PRIMARY_SIZE): + case (_TAG_HEADER_NEG_BIG >> _TAG_PRIMARY_SIZE): + GET_DOUBLE(arg1, f1); + if (big_to_double(arg2, &f2.fd) < 0) { + goto badarith; + } + goto do_float; + case (_TAG_HEADER_FLOAT >> _TAG_PRIMARY_SIZE): + GET_DOUBLE(arg1, f1); + GET_DOUBLE(arg2, f2); + + do_float: + f1.fd = f1.fd + f2.fd; + ERTS_FP_ERROR(p, f1.fd, goto badarith); + hp = HAlloc(p, FLOAT_SIZE_OBJECT); + res = make_float(hp); + PUT_DOUBLE(f1, hp); + return res; + default: + goto badarith; + } + default: + goto badarith; + } + } + default: + goto badarith; + } +} + +Eterm +erts_mixed_minus(Process* p, Eterm arg1, Eterm arg2) +{ + Eterm tmp_big1[2]; + Eterm tmp_big2[2]; + Eterm hdr; + Eterm res; + FloatDef f1, f2; + dsize_t sz1, sz2, sz; + int need_heap; + Eterm* hp; + Sint ires; + + ERTS_FP_CHECK_INIT(p); + switch (arg1 & _TAG_PRIMARY_MASK) { + case TAG_PRIMARY_IMMED1: + switch ((arg1 & _TAG_IMMED1_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + switch (arg2 & _TAG_PRIMARY_MASK) { + case TAG_PRIMARY_IMMED1: + switch ((arg2 & _TAG_IMMED1_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + ires = signed_val(arg1) - signed_val(arg2); + ASSERT(MY_IS_SSMALL(ires) == IS_SSMALL(ires)); + if (MY_IS_SSMALL(ires)) { + return make_small(ires); + } else { + hp = HAlloc(p, 2); + res = small_to_big(ires, hp); + return res; + } + default: + badarith: + p->freason = BADARITH; + return THE_NON_VALUE; + } + case TAG_PRIMARY_BOXED: + hdr = *boxed_val(arg2); + switch ((hdr & _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_HEADER_POS_BIG >> _TAG_PRIMARY_SIZE): + case (_TAG_HEADER_NEG_BIG >> _TAG_PRIMARY_SIZE): + arg1 = small_to_big(signed_val(arg1), tmp_big1); + goto do_big; + case (_TAG_HEADER_FLOAT >> _TAG_PRIMARY_SIZE): + f1.fd = signed_val(arg1); + GET_DOUBLE(arg2, f2); + goto do_float; + default: + goto badarith; + } + } + default: + goto badarith; + } + case TAG_PRIMARY_BOXED: + hdr = *boxed_val(arg1); + switch ((hdr & _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_HEADER_POS_BIG >> _TAG_PRIMARY_SIZE): + case (_TAG_HEADER_NEG_BIG >> _TAG_PRIMARY_SIZE): + switch (arg2 & _TAG_PRIMARY_MASK) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + switch ((arg2 & _TAG_IMMED1_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + if (arg2 == SMALL_ZERO) { + return arg1; + } + arg2 = small_to_big(signed_val(arg2), tmp_big2); + + do_big: + sz1 = big_size(arg1); + sz2 = big_size(arg2); + sz = MAX(sz1, sz2)+1; + need_heap = BIG_NEED_SIZE(sz); + hp = HAlloc(p, need_heap); + res = big_minus(arg1, arg2, hp); + if (is_nil(res)) { + erts_arith_shrink(p, hp); + p->freason = SYSTEM_LIMIT; + return THE_NON_VALUE; + } + maybe_shrink(p, hp, res, need_heap); + return res; + default: + goto badarith; + } + case TAG_PRIMARY_BOXED: + hdr = *boxed_val(arg2); + switch ((hdr & _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_HEADER_POS_BIG >> _TAG_PRIMARY_SIZE): + case (_TAG_HEADER_NEG_BIG >> _TAG_PRIMARY_SIZE): + goto do_big; + case (_TAG_HEADER_FLOAT >> _TAG_PRIMARY_SIZE): + if (big_to_double(arg1, &f1.fd) < 0) { + goto badarith; + } + GET_DOUBLE(arg2, f2); + goto do_float; + default: + goto badarith; + } + } + case (_TAG_HEADER_FLOAT >> _TAG_PRIMARY_SIZE): + switch (arg2 & _TAG_PRIMARY_MASK) { + case TAG_PRIMARY_IMMED1: + switch ((arg2 & _TAG_IMMED1_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + GET_DOUBLE(arg1, f1); + f2.fd = signed_val(arg2); + goto do_float; + default: + goto badarith; + } + case TAG_PRIMARY_BOXED: + hdr = *boxed_val(arg2); + switch ((hdr & _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_HEADER_POS_BIG >> _TAG_PRIMARY_SIZE): + case (_TAG_HEADER_NEG_BIG >> _TAG_PRIMARY_SIZE): + GET_DOUBLE(arg1, f1); + if (big_to_double(arg2, &f2.fd) < 0) { + goto badarith; + } + goto do_float; + case (_TAG_HEADER_FLOAT >> _TAG_PRIMARY_SIZE): + GET_DOUBLE(arg1, f1); + GET_DOUBLE(arg2, f2); + + do_float: + f1.fd = f1.fd - f2.fd; + ERTS_FP_ERROR(p, f1.fd, goto badarith); + hp = HAlloc(p, FLOAT_SIZE_OBJECT); + res = make_float(hp); + PUT_DOUBLE(f1, hp); + return res; + default: + goto badarith; + } + default: + goto badarith; + } + } + default: + goto badarith; + } +} + +Eterm +erts_mixed_times(Process* p, Eterm arg1, Eterm arg2) +{ + Eterm tmp_big1[2]; + Eterm tmp_big2[2]; + Eterm hdr; + Eterm res; + FloatDef f1, f2; + dsize_t sz1, sz2, sz; + int need_heap; + Eterm* hp; + + ERTS_FP_CHECK_INIT(p); + switch (arg1 & _TAG_PRIMARY_MASK) { + case TAG_PRIMARY_IMMED1: + switch ((arg1 & _TAG_IMMED1_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + switch (arg2 & _TAG_PRIMARY_MASK) { + case TAG_PRIMARY_IMMED1: + switch ((arg2 & _TAG_IMMED1_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + if ((arg1 == SMALL_ZERO) || (arg2 == SMALL_ZERO)) { + return(SMALL_ZERO); + } else if (arg1 == SMALL_ONE) { + return(arg2); + } else if (arg2 == SMALL_ONE) { + return(arg1); + } else { + Eterm big_res[3]; + + /* + * The following code is optimized for the case that + * result is small (which should be the most common case + * in practice). + */ + res = small_times(signed_val(arg1), signed_val(arg2), big_res); + if (is_small(res)) { + return res; + } else { + /* + * The result is a a big number. + * Allocate a heap fragment and copy the result. + * Be careful to allocate exactly what we need + * to not leave any holes. + */ + Uint arity; + + ASSERT(is_big(res)); + hdr = big_res[0]; + arity = bignum_header_arity(hdr); + ASSERT(arity == 1 || arity == 2); + hp = HAlloc(p, arity+1); + res = make_big(hp); + *hp++ = hdr; + *hp++ = big_res[1]; + if (arity > 1) { + *hp = big_res[2]; + } + return res; + } + } + default: + badarith: + p->freason = BADARITH; + return THE_NON_VALUE; + } + case TAG_PRIMARY_BOXED: + hdr = *boxed_val(arg2); + switch ((hdr & _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_HEADER_POS_BIG >> _TAG_PRIMARY_SIZE): + case (_TAG_HEADER_NEG_BIG >> _TAG_PRIMARY_SIZE): + if (arg1 == SMALL_ZERO) + return(SMALL_ZERO); + if (arg1 == SMALL_ONE) + return(arg2); + arg1 = small_to_big(signed_val(arg1), tmp_big1); + sz = 2 + big_size(arg2); + goto do_big; + case (_TAG_HEADER_FLOAT >> _TAG_PRIMARY_SIZE): + f1.fd = signed_val(arg1); + GET_DOUBLE(arg2, f2); + goto do_float; + default: + goto badarith; + } + } + default: + goto badarith; + } + case TAG_PRIMARY_BOXED: + hdr = *boxed_val(arg1); + switch ((hdr & _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_HEADER_POS_BIG >> _TAG_PRIMARY_SIZE): + case (_TAG_HEADER_NEG_BIG >> _TAG_PRIMARY_SIZE): + switch (arg2 & _TAG_PRIMARY_MASK) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + switch ((arg2 & _TAG_IMMED1_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + if (arg2 == SMALL_ZERO) + return(SMALL_ZERO); + if (arg2 == SMALL_ONE) + return(arg1); + arg2 = small_to_big(signed_val(arg2), tmp_big2); + sz = 2 + big_size(arg1); + goto do_big; + default: + goto badarith; + } + case TAG_PRIMARY_BOXED: + hdr = *boxed_val(arg2); + switch ((hdr & _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_HEADER_POS_BIG >> _TAG_PRIMARY_SIZE): + case (_TAG_HEADER_NEG_BIG >> _TAG_PRIMARY_SIZE): + sz1 = big_size(arg1); + sz2 = big_size(arg2); + sz = sz1 + sz2; + + do_big: + need_heap = BIG_NEED_SIZE(sz); + hp = HAlloc(p, need_heap); + res = big_times(arg1, arg2, hp); + + /* + * Note that the result must be big in this case, since + * at least one operand was big to begin with, and + * the absolute value of the other is > 1. + */ + + if (is_nil(res)) { + erts_arith_shrink(p, hp); + p->freason = SYSTEM_LIMIT; + return THE_NON_VALUE; + } + maybe_shrink(p, hp, res, need_heap); + return res; + case (_TAG_HEADER_FLOAT >> _TAG_PRIMARY_SIZE): + if (big_to_double(arg1, &f1.fd) < 0) { + goto badarith; + } + GET_DOUBLE(arg2, f2); + goto do_float; + default: + goto badarith; + } + } + case (_TAG_HEADER_FLOAT >> _TAG_PRIMARY_SIZE): + switch (arg2 & _TAG_PRIMARY_MASK) { + case TAG_PRIMARY_IMMED1: + switch ((arg2 & _TAG_IMMED1_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + GET_DOUBLE(arg1, f1); + f2.fd = signed_val(arg2); + goto do_float; + default: + goto badarith; + } + case TAG_PRIMARY_BOXED: + hdr = *boxed_val(arg2); + switch ((hdr & _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_HEADER_POS_BIG >> _TAG_PRIMARY_SIZE): + case (_TAG_HEADER_NEG_BIG >> _TAG_PRIMARY_SIZE): + GET_DOUBLE(arg1, f1); + if (big_to_double(arg2, &f2.fd) < 0) { + goto badarith; + } + goto do_float; + case (_TAG_HEADER_FLOAT >> _TAG_PRIMARY_SIZE): + GET_DOUBLE(arg1, f1); + GET_DOUBLE(arg2, f2); + + do_float: + f1.fd = f1.fd * f2.fd; + ERTS_FP_ERROR(p, f1.fd, goto badarith); + hp = HAlloc(p, FLOAT_SIZE_OBJECT); + res = make_float(hp); + PUT_DOUBLE(f1, hp); + return res; + default: + goto badarith; + } + default: + goto badarith; + } + } + default: + goto badarith; + } +} + +Eterm +erts_mixed_div(Process* p, Eterm arg1, Eterm arg2) +{ + FloatDef f1, f2; + Eterm* hp; + Eterm hdr; + + ERTS_FP_CHECK_INIT(p); + switch (arg1 & _TAG_PRIMARY_MASK) { + case TAG_PRIMARY_IMMED1: + switch ((arg1 & _TAG_IMMED1_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + switch (arg2 & _TAG_PRIMARY_MASK) { + case TAG_PRIMARY_IMMED1: + switch ((arg2 & _TAG_IMMED1_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + f1.fd = signed_val(arg1); + f2.fd = signed_val(arg2); + goto do_float; + default: + badarith: + p->freason = BADARITH; + return THE_NON_VALUE; + } + case TAG_PRIMARY_BOXED: + hdr = *boxed_val(arg2); + switch ((hdr & _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_HEADER_POS_BIG >> _TAG_PRIMARY_SIZE): + case (_TAG_HEADER_NEG_BIG >> _TAG_PRIMARY_SIZE): + f1.fd = signed_val(arg1); + if (big_to_double(arg2, &f2.fd) < 0) { + goto badarith; + } + goto do_float; + case (_TAG_HEADER_FLOAT >> _TAG_PRIMARY_SIZE): + f1.fd = signed_val(arg1); + GET_DOUBLE(arg2, f2); + goto do_float; + default: + goto badarith; + } + } + default: + goto badarith; + } + case TAG_PRIMARY_BOXED: + hdr = *boxed_val(arg1); + switch ((hdr & _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_HEADER_POS_BIG >> _TAG_PRIMARY_SIZE): + case (_TAG_HEADER_NEG_BIG >> _TAG_PRIMARY_SIZE): + switch (arg2 & _TAG_PRIMARY_MASK) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + switch ((arg2 & _TAG_IMMED1_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + if (big_to_double(arg1, &f1.fd) < 0) { + goto badarith; + } + f2.fd = signed_val(arg2); + goto do_float; + default: + goto badarith; + } + case TAG_PRIMARY_BOXED: + hdr = *boxed_val(arg2); + switch ((hdr & _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_HEADER_POS_BIG >> _TAG_PRIMARY_SIZE): + case (_TAG_HEADER_NEG_BIG >> _TAG_PRIMARY_SIZE): + if (big_to_double(arg1, &f1.fd) < 0 || + big_to_double(arg2, &f2.fd) < 0) { + goto badarith; + } + goto do_float; + case (_TAG_HEADER_FLOAT >> _TAG_PRIMARY_SIZE): + if (big_to_double(arg1, &f1.fd) < 0) { + goto badarith; + } + GET_DOUBLE(arg2, f2); + goto do_float; + default: + goto badarith; + } + } + case (_TAG_HEADER_FLOAT >> _TAG_PRIMARY_SIZE): + switch (arg2 & _TAG_PRIMARY_MASK) { + case TAG_PRIMARY_IMMED1: + switch ((arg2 & _TAG_IMMED1_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + GET_DOUBLE(arg1, f1); + f2.fd = signed_val(arg2); + goto do_float; + default: + goto badarith; + } + case TAG_PRIMARY_BOXED: + hdr = *boxed_val(arg2); + switch ((hdr & _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_HEADER_POS_BIG >> _TAG_PRIMARY_SIZE): + case (_TAG_HEADER_NEG_BIG >> _TAG_PRIMARY_SIZE): + GET_DOUBLE(arg1, f1); + if (big_to_double(arg2, &f2.fd) < 0) { + goto badarith; + } + goto do_float; + case (_TAG_HEADER_FLOAT >> _TAG_PRIMARY_SIZE): + GET_DOUBLE(arg1, f1); + GET_DOUBLE(arg2, f2); + + do_float: + f1.fd = f1.fd / f2.fd; + ERTS_FP_ERROR(p, f1.fd, goto badarith); + hp = HAlloc(p, FLOAT_SIZE_OBJECT); + PUT_DOUBLE(f1, hp); + return make_float(hp); + default: + goto badarith; + } + default: + goto badarith; + } + } + default: + goto badarith; + } +} + +Eterm +erts_int_div(Process* p, Eterm arg1, Eterm arg2) +{ + Eterm tmp_big1[2]; + Eterm tmp_big2[2]; + int ires; + + switch (NUMBER_CODE(arg1, arg2)) { + case SMALL_SMALL: + /* This case occurs if the most negative fixnum is divided by -1. */ + ASSERT(arg2 == make_small(-1)); + arg1 = small_to_big(signed_val(arg1), tmp_big1); + /*FALLTHROUGH*/ + case BIG_SMALL: + arg2 = small_to_big(signed_val(arg2), tmp_big2); + goto L_big_div; + case SMALL_BIG: + if (arg1 != make_small(MIN_SMALL)) { + return SMALL_ZERO; + } + arg1 = small_to_big(signed_val(arg1), tmp_big1); + /*FALLTHROUGH*/ + case BIG_BIG: + L_big_div: + ires = big_ucomp(arg1, arg2); + if (ires < 0) { + arg1 = SMALL_ZERO; + } else if (ires == 0) { + arg1 = (big_sign(arg1) == big_sign(arg2)) ? + SMALL_ONE : SMALL_MINUS_ONE; + } else { + Eterm* hp; + int i = big_size(arg1); + Uint need; + + ires = big_size(arg2); + need = BIG_NEED_SIZE(i-ires+1) + BIG_NEED_SIZE(i); + hp = HAlloc(p, need); + arg1 = big_div(arg1, arg2, hp); + if (is_nil(arg1)) { + erts_arith_shrink(p, hp); + p->freason = SYSTEM_LIMIT; + return THE_NON_VALUE; + } + maybe_shrink(p, hp, arg1, need); + } + return arg1; + default: + p->freason = BADARITH; + return THE_NON_VALUE; + } +} + +Eterm +erts_int_rem(Process* p, Eterm arg1, Eterm arg2) +{ + Eterm tmp_big1[2]; + Eterm tmp_big2[2]; + int ires; + + switch (NUMBER_CODE(arg1, arg2)) { + case BIG_SMALL: + arg2 = small_to_big(signed_val(arg2), tmp_big2); + goto L_big_rem; + case SMALL_BIG: + if (arg1 != make_small(MIN_SMALL)) { + return arg1; + } else { + Eterm tmp = small_to_big(signed_val(arg1), tmp_big1); + if ((ires = big_ucomp(tmp, arg2)) == 0) { + return SMALL_ZERO; + } else { + ASSERT(ires < 0); + return arg1; + } + } + /* All paths returned */ + case BIG_BIG: + L_big_rem: + ires = big_ucomp(arg1, arg2); + if (ires == 0) { + arg1 = SMALL_ZERO; + } else if (ires > 0) { + Uint need = BIG_NEED_SIZE(big_size(arg1)); + Eterm* hp = HAlloc(p, need); + + arg1 = big_rem(arg1, arg2, hp); + if (is_nil(arg1)) { + erts_arith_shrink(p, hp); + p->freason = SYSTEM_LIMIT; + return THE_NON_VALUE; + } + maybe_shrink(p, hp, arg1, need); + } + return arg1; + default: + p->freason = BADARITH; + return THE_NON_VALUE; + } +} + +Eterm erts_band(Process* p, Eterm arg1, Eterm arg2) +{ + Eterm tmp_big1[2]; + Eterm tmp_big2[2]; + Eterm* hp; + int need; + + switch (NUMBER_CODE(arg1, arg2)) { + case SMALL_BIG: + arg1 = small_to_big(signed_val(arg1), tmp_big1); + break; + case BIG_SMALL: + arg2 = small_to_big(signed_val(arg2), tmp_big2); + break; + case BIG_BIG: + break; + default: + p->freason = BADARITH; + return THE_NON_VALUE; + } + need = BIG_NEED_SIZE(MAX(big_size(arg1), big_size(arg2)) + 1); + hp = HAlloc(p, need); + arg1 = big_band(arg1, arg2, hp); + ASSERT(is_not_nil(arg1)); + maybe_shrink(p, hp, arg1, need); + return arg1; +} + +Eterm erts_bor(Process* p, Eterm arg1, Eterm arg2) +{ + Eterm tmp_big1[2]; + Eterm tmp_big2[2]; + Eterm* hp; + int need; + + switch (NUMBER_CODE(arg1, arg2)) { + case SMALL_BIG: + arg1 = small_to_big(signed_val(arg1), tmp_big1); + break; + case BIG_SMALL: + arg2 = small_to_big(signed_val(arg2), tmp_big2); + break; + case BIG_BIG: + break; + default: + p->freason = BADARITH; + return THE_NON_VALUE; + } + need = BIG_NEED_SIZE(MAX(big_size(arg1), big_size(arg2)) + 1); + hp = HAlloc(p, need); + arg1 = big_bor(arg1, arg2, hp); + ASSERT(is_not_nil(arg1)); + maybe_shrink(p, hp, arg1, need); + return arg1; +} + +Eterm erts_bxor(Process* p, Eterm arg1, Eterm arg2) +{ + Eterm tmp_big1[2]; + Eterm tmp_big2[2]; + Eterm* hp; + int need; + + switch (NUMBER_CODE(arg1, arg2)) { + case SMALL_BIG: + arg1 = small_to_big(signed_val(arg1), tmp_big1); + break; + case BIG_SMALL: + arg2 = small_to_big(signed_val(arg2), tmp_big2); + break; + case BIG_BIG: + break; + default: + p->freason = BADARITH; + return THE_NON_VALUE; + } + need = BIG_NEED_SIZE(MAX(big_size(arg1), big_size(arg2)) + 1); + hp = HAlloc(p, need); + arg1 = big_bxor(arg1, arg2, hp); + ASSERT(is_not_nil(arg1)); + maybe_shrink(p, hp, arg1, need); + return arg1; +} + +Eterm erts_bnot(Process* p, Eterm arg) +{ + Eterm ret; + + if (is_big(arg)) { + Uint need = BIG_NEED_SIZE(big_size(arg)+1); + Eterm* bigp = HAlloc(p, need); + + ret = big_bnot(arg, bigp); + maybe_shrink(p, bigp, ret, need); + if (is_nil(ret)) { + p->freason = SYSTEM_LIMIT; + return NIL; + } + } else { + p->freason = BADARITH; + return NIL; + } + return ret; +} + +#define ERTS_NEED_GC(p, need) ((HEAP_LIMIT((p)) - HEAP_TOP((p))) <= (need)) + +static ERTS_INLINE void +trim_heap(Process* p, Eterm* hp, Eterm res) +{ + if (is_immed(res)) { + ASSERT(p->heap <= hp && hp <= p->htop); + p->htop = hp; + } else { + Eterm* new_htop; + ASSERT(is_big(res)); + new_htop = hp + bignum_header_arity(*hp) + 1; + ASSERT(p->heap <= new_htop && new_htop <= p->htop); + p->htop = new_htop; + } + ASSERT(p->heap <= p->htop && p->htop <= p->stop); +} + +/* + * The functions that follow are called from the emulator loop. + * They are not allowed to allocate heap fragments, but must do + * a garbage collection if there is insufficient heap space. + */ + +#define erts_arith_shrink horrible error +#define maybe_shrink horrible error + +Eterm +erts_gc_mixed_plus(Process* p, Eterm* reg, Uint live) +{ + Eterm arg1; + Eterm arg2; + Eterm tmp_big1[2]; + Eterm tmp_big2[2]; + Eterm res; + Eterm hdr; + FloatDef f1, f2; + dsize_t sz1, sz2, sz; + int need_heap; + Eterm* hp; + Sint ires; + + arg1 = reg[live]; + arg2 = reg[live+1]; + ERTS_FP_CHECK_INIT(p); + switch (arg1 & _TAG_PRIMARY_MASK) { + case TAG_PRIMARY_IMMED1: + switch ((arg1 & _TAG_IMMED1_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + switch (arg2 & _TAG_PRIMARY_MASK) { + case TAG_PRIMARY_IMMED1: + switch ((arg2 & _TAG_IMMED1_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + ires = signed_val(arg1) + signed_val(arg2); + ASSERT(MY_IS_SSMALL(ires) == IS_SSMALL(ires)); + if (MY_IS_SSMALL(ires)) { + return make_small(ires); + } else { + if (ERTS_NEED_GC(p, 2)) { + erts_garbage_collect(p, 2, reg, live); + } + hp = p->htop; + p->htop += 2; + res = small_to_big(ires, hp); + return res; + } + default: + badarith: + p->freason = BADARITH; + return THE_NON_VALUE; + } + case TAG_PRIMARY_BOXED: + hdr = *boxed_val(arg2); + switch ((hdr & _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_HEADER_POS_BIG >> _TAG_PRIMARY_SIZE): + case (_TAG_HEADER_NEG_BIG >> _TAG_PRIMARY_SIZE): + if (arg1 == SMALL_ZERO) { + return arg2; + } + arg1 = small_to_big(signed_val(arg1), tmp_big1); + goto do_big; + case (_TAG_HEADER_FLOAT >> _TAG_PRIMARY_SIZE): + f1.fd = signed_val(arg1); + GET_DOUBLE(arg2, f2); + goto do_float; + default: + goto badarith; + } + } + default: + goto badarith; + } + case TAG_PRIMARY_BOXED: + hdr = *boxed_val(arg1); + switch ((hdr & _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_HEADER_POS_BIG >> _TAG_PRIMARY_SIZE): + case (_TAG_HEADER_NEG_BIG >> _TAG_PRIMARY_SIZE): + switch (arg2 & _TAG_PRIMARY_MASK) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + switch ((arg2 & _TAG_IMMED1_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + if (arg2 == SMALL_ZERO) { + return arg1; + } + arg2 = small_to_big(signed_val(arg2), tmp_big2); + goto do_big; + default: + goto badarith; + } + case TAG_PRIMARY_BOXED: + hdr = *boxed_val(arg2); + switch ((hdr & _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_HEADER_POS_BIG >> _TAG_PRIMARY_SIZE): + case (_TAG_HEADER_NEG_BIG >> _TAG_PRIMARY_SIZE): + do_big: + sz1 = big_size(arg1); + sz2 = big_size(arg2); + sz = MAX(sz1, sz2)+1; + need_heap = BIG_NEED_SIZE(sz); + if (ERTS_NEED_GC(p, need_heap)) { + erts_garbage_collect(p, need_heap, reg, live+2); + if (arg1 != make_big(tmp_big1)) { + arg1 = reg[live]; + } + if (arg2 != make_big(tmp_big2)) { + arg2 = reg[live+1]; + } + } + hp = p->htop; + p->htop += need_heap; + res = big_plus(arg1, arg2, hp); + trim_heap(p, hp, res); + if (is_nil(res)) { + p->freason = SYSTEM_LIMIT; + return THE_NON_VALUE; + } + return res; + case (_TAG_HEADER_FLOAT >> _TAG_PRIMARY_SIZE): + if (big_to_double(arg1, &f1.fd) < 0) { + goto badarith; + } + GET_DOUBLE(arg2, f2); + goto do_float; + default: + goto badarith; + } + } + case (_TAG_HEADER_FLOAT >> _TAG_PRIMARY_SIZE): + switch (arg2 & _TAG_PRIMARY_MASK) { + case TAG_PRIMARY_IMMED1: + switch ((arg2 & _TAG_IMMED1_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + GET_DOUBLE(arg1, f1); + f2.fd = signed_val(arg2); + goto do_float; + default: + goto badarith; + } + case TAG_PRIMARY_BOXED: + hdr = *boxed_val(arg2); + switch ((hdr & _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_HEADER_POS_BIG >> _TAG_PRIMARY_SIZE): + case (_TAG_HEADER_NEG_BIG >> _TAG_PRIMARY_SIZE): + GET_DOUBLE(arg1, f1); + if (big_to_double(arg2, &f2.fd) < 0) { + goto badarith; + } + goto do_float; + case (_TAG_HEADER_FLOAT >> _TAG_PRIMARY_SIZE): + GET_DOUBLE(arg1, f1); + GET_DOUBLE(arg2, f2); + + do_float: + f1.fd = f1.fd + f2.fd; + ERTS_FP_ERROR(p, f1.fd, goto badarith); + if (ERTS_NEED_GC(p, FLOAT_SIZE_OBJECT)) { + erts_garbage_collect(p, FLOAT_SIZE_OBJECT, reg, live); + } + hp = p->htop; + p->htop += FLOAT_SIZE_OBJECT; + res = make_float(hp); + PUT_DOUBLE(f1, hp); + return res; + default: + goto badarith; + } + default: + goto badarith; + } + } + default: + goto badarith; + } +} + +Eterm +erts_gc_mixed_minus(Process* p, Eterm* reg, Uint live) +{ + Eterm arg1; + Eterm arg2; + Eterm tmp_big1[2]; + Eterm tmp_big2[2]; + Eterm hdr; + Eterm res; + FloatDef f1, f2; + dsize_t sz1, sz2, sz; + int need_heap; + Eterm* hp; + Sint ires; + + arg1 = reg[live]; + arg2 = reg[live+1]; + ERTS_FP_CHECK_INIT(p); + switch (arg1 & _TAG_PRIMARY_MASK) { + case TAG_PRIMARY_IMMED1: + switch ((arg1 & _TAG_IMMED1_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + switch (arg2 & _TAG_PRIMARY_MASK) { + case TAG_PRIMARY_IMMED1: + switch ((arg2 & _TAG_IMMED1_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + ires = signed_val(arg1) - signed_val(arg2); + ASSERT(MY_IS_SSMALL(ires) == IS_SSMALL(ires)); + if (MY_IS_SSMALL(ires)) { + return make_small(ires); + } else { + if (ERTS_NEED_GC(p, 2)) { + erts_garbage_collect(p, 2, reg, live); + } + hp = p->htop; + p->htop += 2; + res = small_to_big(ires, hp); + return res; + } + default: + badarith: + p->freason = BADARITH; + return THE_NON_VALUE; + } + case TAG_PRIMARY_BOXED: + hdr = *boxed_val(arg2); + switch ((hdr & _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_HEADER_POS_BIG >> _TAG_PRIMARY_SIZE): + case (_TAG_HEADER_NEG_BIG >> _TAG_PRIMARY_SIZE): + arg1 = small_to_big(signed_val(arg1), tmp_big1); + goto do_big; + case (_TAG_HEADER_FLOAT >> _TAG_PRIMARY_SIZE): + f1.fd = signed_val(arg1); + GET_DOUBLE(arg2, f2); + goto do_float; + default: + goto badarith; + } + } + default: + goto badarith; + } + case TAG_PRIMARY_BOXED: + hdr = *boxed_val(arg1); + switch ((hdr & _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_HEADER_POS_BIG >> _TAG_PRIMARY_SIZE): + case (_TAG_HEADER_NEG_BIG >> _TAG_PRIMARY_SIZE): + switch (arg2 & _TAG_PRIMARY_MASK) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + switch ((arg2 & _TAG_IMMED1_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + if (arg2 == SMALL_ZERO) { + return arg1; + } + arg2 = small_to_big(signed_val(arg2), tmp_big2); + + do_big: + sz1 = big_size(arg1); + sz2 = big_size(arg2); + sz = MAX(sz1, sz2)+1; + need_heap = BIG_NEED_SIZE(sz); + if (ERTS_NEED_GC(p, need_heap)) { + erts_garbage_collect(p, need_heap, reg, live+2); + if (arg1 != make_big(tmp_big1)) { + arg1 = reg[live]; + } + if (arg2 != make_big(tmp_big2)) { + arg2 = reg[live+1]; + } + } + hp = p->htop; + p->htop += need_heap; + res = big_minus(arg1, arg2, hp); + trim_heap(p, hp, res); + if (is_nil(res)) { + p->freason = SYSTEM_LIMIT; + return THE_NON_VALUE; + } + return res; + default: + goto badarith; + } + case TAG_PRIMARY_BOXED: + hdr = *boxed_val(arg2); + switch ((hdr & _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_HEADER_POS_BIG >> _TAG_PRIMARY_SIZE): + case (_TAG_HEADER_NEG_BIG >> _TAG_PRIMARY_SIZE): + goto do_big; + case (_TAG_HEADER_FLOAT >> _TAG_PRIMARY_SIZE): + if (big_to_double(arg1, &f1.fd) < 0) { + goto badarith; + } + GET_DOUBLE(arg2, f2); + goto do_float; + default: + goto badarith; + } + } + case (_TAG_HEADER_FLOAT >> _TAG_PRIMARY_SIZE): + switch (arg2 & _TAG_PRIMARY_MASK) { + case TAG_PRIMARY_IMMED1: + switch ((arg2 & _TAG_IMMED1_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + GET_DOUBLE(arg1, f1); + f2.fd = signed_val(arg2); + goto do_float; + default: + goto badarith; + } + case TAG_PRIMARY_BOXED: + hdr = *boxed_val(arg2); + switch ((hdr & _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_HEADER_POS_BIG >> _TAG_PRIMARY_SIZE): + case (_TAG_HEADER_NEG_BIG >> _TAG_PRIMARY_SIZE): + GET_DOUBLE(arg1, f1); + if (big_to_double(arg2, &f2.fd) < 0) { + goto badarith; + } + goto do_float; + case (_TAG_HEADER_FLOAT >> _TAG_PRIMARY_SIZE): + GET_DOUBLE(arg1, f1); + GET_DOUBLE(arg2, f2); + + do_float: + f1.fd = f1.fd - f2.fd; + ERTS_FP_ERROR(p, f1.fd, goto badarith); + if (ERTS_NEED_GC(p, FLOAT_SIZE_OBJECT)) { + erts_garbage_collect(p, FLOAT_SIZE_OBJECT, reg, live); + } + hp = p->htop; + p->htop += FLOAT_SIZE_OBJECT; + res = make_float(hp); + PUT_DOUBLE(f1, hp); + return res; + default: + goto badarith; + } + default: + goto badarith; + } + } + default: + goto badarith; + } +} + +Eterm +erts_gc_mixed_times(Process* p, Eterm* reg, Uint live) +{ + Eterm arg1; + Eterm arg2; + Eterm tmp_big1[2]; + Eterm tmp_big2[2]; + Eterm hdr; + Eterm res; + FloatDef f1, f2; + dsize_t sz1, sz2, sz; + int need_heap; + Eterm* hp; + + arg1 = reg[live]; + arg2 = reg[live+1]; + ERTS_FP_CHECK_INIT(p); + switch (arg1 & _TAG_PRIMARY_MASK) { + case TAG_PRIMARY_IMMED1: + switch ((arg1 & _TAG_IMMED1_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + switch (arg2 & _TAG_PRIMARY_MASK) { + case TAG_PRIMARY_IMMED1: + switch ((arg2 & _TAG_IMMED1_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + if ((arg1 == SMALL_ZERO) || (arg2 == SMALL_ZERO)) { + return(SMALL_ZERO); + } else if (arg1 == SMALL_ONE) { + return(arg2); + } else if (arg2 == SMALL_ONE) { + return(arg1); + } else { + Eterm big_res[3]; + + /* + * The following code is optimized for the case that + * result is small (which should be the most common case + * in practice). + */ + res = small_times(signed_val(arg1), signed_val(arg2), + big_res); + if (is_small(res)) { + return res; + } else { + /* + * The result is a a big number. + * Allocate a heap fragment and copy the result. + * Be careful to allocate exactly what we need + * to not leave any holes. + */ + Uint arity; + Uint need; + + ASSERT(is_big(res)); + hdr = big_res[0]; + arity = bignum_header_arity(hdr); + ASSERT(arity == 1 || arity == 2); + need = arity + 1; + if (ERTS_NEED_GC(p, need)) { + erts_garbage_collect(p, need, reg, live); + } + hp = p->htop; + p->htop += need; + res = make_big(hp); + *hp++ = hdr; + *hp++ = big_res[1]; + if (arity > 1) { + *hp = big_res[2]; + } + return res; + } + } + default: + badarith: + p->freason = BADARITH; + return THE_NON_VALUE; + } + case TAG_PRIMARY_BOXED: + hdr = *boxed_val(arg2); + switch ((hdr & _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_HEADER_POS_BIG >> _TAG_PRIMARY_SIZE): + case (_TAG_HEADER_NEG_BIG >> _TAG_PRIMARY_SIZE): + if (arg1 == SMALL_ZERO) + return(SMALL_ZERO); + if (arg1 == SMALL_ONE) + return(arg2); + arg1 = small_to_big(signed_val(arg1), tmp_big1); + sz = 2 + big_size(arg2); + goto do_big; + case (_TAG_HEADER_FLOAT >> _TAG_PRIMARY_SIZE): + f1.fd = signed_val(arg1); + GET_DOUBLE(arg2, f2); + goto do_float; + default: + goto badarith; + } + } + default: + goto badarith; + } + case TAG_PRIMARY_BOXED: + hdr = *boxed_val(arg1); + switch ((hdr & _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_HEADER_POS_BIG >> _TAG_PRIMARY_SIZE): + case (_TAG_HEADER_NEG_BIG >> _TAG_PRIMARY_SIZE): + switch (arg2 & _TAG_PRIMARY_MASK) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + switch ((arg2 & _TAG_IMMED1_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + if (arg2 == SMALL_ZERO) + return(SMALL_ZERO); + if (arg2 == SMALL_ONE) + return(arg1); + arg2 = small_to_big(signed_val(arg2), tmp_big2); + sz = 2 + big_size(arg1); + goto do_big; + default: + goto badarith; + } + case TAG_PRIMARY_BOXED: + hdr = *boxed_val(arg2); + switch ((hdr & _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_HEADER_POS_BIG >> _TAG_PRIMARY_SIZE): + case (_TAG_HEADER_NEG_BIG >> _TAG_PRIMARY_SIZE): + sz1 = big_size(arg1); + sz2 = big_size(arg2); + sz = sz1 + sz2; + + do_big: + need_heap = BIG_NEED_SIZE(sz); + if (ERTS_NEED_GC(p, need_heap)) { + erts_garbage_collect(p, need_heap, reg, live+2); + if (arg1 != make_big(tmp_big1)) { + arg1 = reg[live]; + } + if (arg2 != make_big(tmp_big2)) { + arg2 = reg[live+1]; + } + } + hp = p->htop; + p->htop += need_heap; + res = big_times(arg1, arg2, hp); + trim_heap(p, hp, res); + + /* + * Note that the result must be big in this case, since + * at least one operand was big to begin with, and + * the absolute value of the other is > 1. + */ + + if (is_nil(res)) { + p->freason = SYSTEM_LIMIT; + return THE_NON_VALUE; + } + return res; + case (_TAG_HEADER_FLOAT >> _TAG_PRIMARY_SIZE): + if (big_to_double(arg1, &f1.fd) < 0) { + goto badarith; + } + GET_DOUBLE(arg2, f2); + goto do_float; + default: + goto badarith; + } + } + case (_TAG_HEADER_FLOAT >> _TAG_PRIMARY_SIZE): + switch (arg2 & _TAG_PRIMARY_MASK) { + case TAG_PRIMARY_IMMED1: + switch ((arg2 & _TAG_IMMED1_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + GET_DOUBLE(arg1, f1); + f2.fd = signed_val(arg2); + goto do_float; + default: + goto badarith; + } + case TAG_PRIMARY_BOXED: + hdr = *boxed_val(arg2); + switch ((hdr & _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_HEADER_POS_BIG >> _TAG_PRIMARY_SIZE): + case (_TAG_HEADER_NEG_BIG >> _TAG_PRIMARY_SIZE): + GET_DOUBLE(arg1, f1); + if (big_to_double(arg2, &f2.fd) < 0) { + goto badarith; + } + goto do_float; + case (_TAG_HEADER_FLOAT >> _TAG_PRIMARY_SIZE): + GET_DOUBLE(arg1, f1); + GET_DOUBLE(arg2, f2); + + do_float: + f1.fd = f1.fd * f2.fd; + ERTS_FP_ERROR(p, f1.fd, goto badarith); + if (ERTS_NEED_GC(p, FLOAT_SIZE_OBJECT)) { + erts_garbage_collect(p, FLOAT_SIZE_OBJECT, reg, live); + } + hp = p->htop; + p->htop += FLOAT_SIZE_OBJECT; + res = make_float(hp); + PUT_DOUBLE(f1, hp); + return res; + default: + goto badarith; + } + default: + goto badarith; + } + } + default: + goto badarith; + } +} + +Eterm +erts_gc_mixed_div(Process* p, Eterm* reg, Uint live) +{ + Eterm arg1; + Eterm arg2; + FloatDef f1, f2; + Eterm* hp; + Eterm hdr; + + arg1 = reg[live]; + arg2 = reg[live+1]; + ERTS_FP_CHECK_INIT(p); + switch (arg1 & _TAG_PRIMARY_MASK) { + case TAG_PRIMARY_IMMED1: + switch ((arg1 & _TAG_IMMED1_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + switch (arg2 & _TAG_PRIMARY_MASK) { + case TAG_PRIMARY_IMMED1: + switch ((arg2 & _TAG_IMMED1_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + f1.fd = signed_val(arg1); + f2.fd = signed_val(arg2); + goto do_float; + default: + badarith: + p->freason = BADARITH; + return THE_NON_VALUE; + } + case TAG_PRIMARY_BOXED: + hdr = *boxed_val(arg2); + switch ((hdr & _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_HEADER_POS_BIG >> _TAG_PRIMARY_SIZE): + case (_TAG_HEADER_NEG_BIG >> _TAG_PRIMARY_SIZE): + f1.fd = signed_val(arg1); + if (big_to_double(arg2, &f2.fd) < 0) { + goto badarith; + } + goto do_float; + case (_TAG_HEADER_FLOAT >> _TAG_PRIMARY_SIZE): + f1.fd = signed_val(arg1); + GET_DOUBLE(arg2, f2); + goto do_float; + default: + goto badarith; + } + } + default: + goto badarith; + } + case TAG_PRIMARY_BOXED: + hdr = *boxed_val(arg1); + switch ((hdr & _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_HEADER_POS_BIG >> _TAG_PRIMARY_SIZE): + case (_TAG_HEADER_NEG_BIG >> _TAG_PRIMARY_SIZE): + switch (arg2 & _TAG_PRIMARY_MASK) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + switch ((arg2 & _TAG_IMMED1_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + if (big_to_double(arg1, &f1.fd) < 0) { + goto badarith; + } + f2.fd = signed_val(arg2); + goto do_float; + default: + goto badarith; + } + case TAG_PRIMARY_BOXED: + hdr = *boxed_val(arg2); + switch ((hdr & _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_HEADER_POS_BIG >> _TAG_PRIMARY_SIZE): + case (_TAG_HEADER_NEG_BIG >> _TAG_PRIMARY_SIZE): + if (big_to_double(arg1, &f1.fd) < 0 || + big_to_double(arg2, &f2.fd) < 0) { + goto badarith; + } + goto do_float; + case (_TAG_HEADER_FLOAT >> _TAG_PRIMARY_SIZE): + if (big_to_double(arg1, &f1.fd) < 0) { + goto badarith; + } + GET_DOUBLE(arg2, f2); + goto do_float; + default: + goto badarith; + } + } + case (_TAG_HEADER_FLOAT >> _TAG_PRIMARY_SIZE): + switch (arg2 & _TAG_PRIMARY_MASK) { + case TAG_PRIMARY_IMMED1: + switch ((arg2 & _TAG_IMMED1_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + GET_DOUBLE(arg1, f1); + f2.fd = signed_val(arg2); + goto do_float; + default: + goto badarith; + } + case TAG_PRIMARY_BOXED: + hdr = *boxed_val(arg2); + switch ((hdr & _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_HEADER_POS_BIG >> _TAG_PRIMARY_SIZE): + case (_TAG_HEADER_NEG_BIG >> _TAG_PRIMARY_SIZE): + GET_DOUBLE(arg1, f1); + if (big_to_double(arg2, &f2.fd) < 0) { + goto badarith; + } + goto do_float; + case (_TAG_HEADER_FLOAT >> _TAG_PRIMARY_SIZE): + GET_DOUBLE(arg1, f1); + GET_DOUBLE(arg2, f2); + + do_float: + f1.fd = f1.fd / f2.fd; + ERTS_FP_ERROR(p, f1.fd, goto badarith); + if (ERTS_NEED_GC(p, FLOAT_SIZE_OBJECT)) { + erts_garbage_collect(p, FLOAT_SIZE_OBJECT, reg, live); + } + hp = p->htop; + p->htop += FLOAT_SIZE_OBJECT; + PUT_DOUBLE(f1, hp); + return make_float(hp); + default: + goto badarith; + } + default: + goto badarith; + } + } + default: + goto badarith; + } +} + +Eterm +erts_gc_int_div(Process* p, Eterm* reg, Uint live) +{ + Eterm arg1; + Eterm arg2; + Eterm tmp_big1[2]; + Eterm tmp_big2[2]; + int ires; + + arg1 = reg[live]; + arg2 = reg[live+1]; + switch (NUMBER_CODE(arg1, arg2)) { + case SMALL_SMALL: + /* This case occurs if the most negative fixnum is divided by -1. */ + ASSERT(arg2 == make_small(-1)); + arg1 = small_to_big(signed_val(arg1), tmp_big1); + /*FALLTHROUGH*/ + case BIG_SMALL: + arg2 = small_to_big(signed_val(arg2), tmp_big2); + goto L_big_div; + case SMALL_BIG: + if (arg1 != make_small(MIN_SMALL)) { + return SMALL_ZERO; + } + arg1 = small_to_big(signed_val(arg1), tmp_big1); + /*FALLTHROUGH*/ + case BIG_BIG: + L_big_div: + ires = big_ucomp(arg1, arg2); + if (ires < 0) { + arg1 = SMALL_ZERO; + } else if (ires == 0) { + arg1 = (big_sign(arg1) == big_sign(arg2)) ? + SMALL_ONE : SMALL_MINUS_ONE; + } else { + Eterm* hp; + int i = big_size(arg1); + Uint need; + + ires = big_size(arg2); + need = BIG_NEED_SIZE(i-ires+1) + BIG_NEED_SIZE(i); + if (ERTS_NEED_GC(p, need)) { + erts_garbage_collect(p, need, reg, live+2); + if (arg1 != make_big(tmp_big1)) { + arg1 = reg[live]; + } + if (arg2 != make_big(tmp_big2)) { + arg2 = reg[live+1]; + } + } + hp = p->htop; + p->htop += need; + arg1 = big_div(arg1, arg2, hp); + trim_heap(p, hp, arg1); + if (is_nil(arg1)) { + p->freason = SYSTEM_LIMIT; + return THE_NON_VALUE; + } + } + return arg1; + default: + p->freason = BADARITH; + return THE_NON_VALUE; + } +} + +Eterm +erts_gc_int_rem(Process* p, Eterm* reg, Uint live) +{ + Eterm arg1; + Eterm arg2; + Eterm tmp_big1[2]; + Eterm tmp_big2[2]; + int ires; + + arg1 = reg[live]; + arg2 = reg[live+1]; + switch (NUMBER_CODE(arg1, arg2)) { + case BIG_SMALL: + arg2 = small_to_big(signed_val(arg2), tmp_big2); + goto L_big_rem; + case SMALL_BIG: + if (arg1 != make_small(MIN_SMALL)) { + return arg1; + } else { + Eterm tmp = small_to_big(signed_val(arg1), tmp_big1); + if ((ires = big_ucomp(tmp, arg2)) == 0) { + return SMALL_ZERO; + } else { + ASSERT(ires < 0); + return arg1; + } + } + /* All paths returned */ + case BIG_BIG: + L_big_rem: + ires = big_ucomp(arg1, arg2); + if (ires == 0) { + arg1 = SMALL_ZERO; + } else if (ires > 0) { + Eterm* hp; + Uint need = BIG_NEED_SIZE(big_size(arg1)); + + if (ERTS_NEED_GC(p, need)) { + erts_garbage_collect(p, need, reg, live+2); + if (arg1 != make_big(tmp_big1)) { + arg1 = reg[live]; + } + if (arg2 != make_big(tmp_big2)) { + arg2 = reg[live+1]; + } + } + hp = p->htop; + p->htop += need; + arg1 = big_rem(arg1, arg2, hp); + trim_heap(p, hp, arg1); + if (is_nil(arg1)) { + p->freason = SYSTEM_LIMIT; + return THE_NON_VALUE; + } + } + return arg1; + default: + p->freason = BADARITH; + return THE_NON_VALUE; + } +} + +#define DEFINE_GC_LOGIC_FUNC(func) \ +Eterm erts_gc_##func(Process* p, Eterm* reg, Uint live) \ +{ \ + Eterm arg1; \ + Eterm arg2; \ + Eterm tmp_big1[2]; \ + Eterm tmp_big2[2]; \ + Eterm* hp; \ + int need; \ + \ + arg1 = reg[live]; \ + arg2 = reg[live+1]; \ + switch (NUMBER_CODE(arg1, arg2)) { \ + case SMALL_BIG: \ + arg1 = small_to_big(signed_val(arg1), tmp_big1); \ + need = BIG_NEED_SIZE(big_size(arg2) + 1); \ + if (ERTS_NEED_GC(p, need)) { \ + erts_garbage_collect(p, need, reg, live+2); \ + arg2 = reg[live+1]; \ + } \ + break; \ + case BIG_SMALL: \ + arg2 = small_to_big(signed_val(arg2), tmp_big2); \ + need = BIG_NEED_SIZE(big_size(arg1) + 1); \ + if (ERTS_NEED_GC(p, need)) { \ + erts_garbage_collect(p, need, reg, live+2); \ + arg1 = reg[live]; \ + } \ + break; \ + case BIG_BIG: \ + need = BIG_NEED_SIZE(MAX(big_size(arg1), big_size(arg2)) + 1); \ + if (ERTS_NEED_GC(p, need)) { \ + erts_garbage_collect(p, need, reg, live+2); \ + arg1 = reg[live]; \ + arg2 = reg[live+1]; \ + } \ + break; \ + default: \ + p->freason = BADARITH; \ + return THE_NON_VALUE; \ + } \ + hp = p->htop; \ + p->htop += need; \ + arg1 = big_##func(arg1, arg2, hp); \ + trim_heap(p, hp, arg1); \ + return arg1; \ +} + +DEFINE_GC_LOGIC_FUNC(band) +DEFINE_GC_LOGIC_FUNC(bor) +DEFINE_GC_LOGIC_FUNC(bxor) + +Eterm erts_gc_bnot(Process* p, Eterm* reg, Uint live) +{ + Eterm result; + Eterm arg; + Uint need; + Eterm* bigp; + + arg = reg[live]; + if (is_not_big(arg)) { + p->freason = BADARITH; + return NIL; + } else { + need = BIG_NEED_SIZE(big_size(arg)+1); + if (ERTS_NEED_GC(p, need)) { + erts_garbage_collect(p, need, reg, live+1); + arg = reg[live]; + } + bigp = p->htop; + p->htop += need; + result = big_bnot(arg, bigp); + trim_heap(p, bigp, result); + if (is_nil(result)) { + p->freason = SYSTEM_LIMIT; + return NIL; + } + } + return result; +} diff --git a/erts/emulator/beam/erl_async.c b/erts/emulator/beam/erl_async.c new file mode 100644 index 0000000000..b090564649 --- /dev/null +++ b/erts/emulator/beam/erl_async.c @@ -0,0 +1,469 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2000-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_sys_driver.h" +#include "global.h" +#include "erl_threads.h" + +typedef struct _erl_async { + struct _erl_async* next; + struct _erl_async* prev; + DE_Handle* hndl; /* The DE_Handle is needed when port is gone */ + Eterm port; + long async_id; + void* async_data; + ErlDrvPDL pdl; + void (*async_invoke)(void*); + void (*async_free)(void*); +} ErlAsync; + +typedef struct { + erts_mtx_t mtx; + erts_cnd_t cv; + erts_tid_t thr; + int len; +#ifndef ERTS_SMP + int hndl; +#endif + ErlAsync* head; + ErlAsync* tail; +#ifdef ERTS_ENABLE_LOCK_CHECK + int no; +#endif +} AsyncQueue; + +static erts_smp_spinlock_t async_id_lock; +static long async_id = 0; + + +#ifndef ERTS_SMP + +erts_mtx_t async_ready_mtx; +static ErlAsync* async_ready_list = NULL; + +#endif + +/* +** Initialize worker threads (if supported) +*/ + +/* Detach from driver */ +static void async_detach(DE_Handle* dh) +{ + /* XXX:PaN what should happen here? we want to unload the driver or??? */ + return; +} + + +#ifdef USE_THREADS + +static AsyncQueue* async_q; + +static void* async_main(void*); +static void async_add(ErlAsync*, AsyncQueue*); + +#ifndef ERTS_SMP +typedef struct ErtsAsyncReadyCallback_ ErtsAsyncReadyCallback; +struct ErtsAsyncReadyCallback_ { + struct ErtsAsyncReadyCallback_ *next; + void (*callback)(void); +}; + +static ErtsAsyncReadyCallback *callbacks; +static int async_handle; + +int erts_register_async_ready_callback(void (*funcp)(void)) +{ + ErtsAsyncReadyCallback *cb = erts_alloc(ERTS_ALC_T_ARCALLBACK, + sizeof(ErtsAsyncReadyCallback)); + cb->next = callbacks; + cb->callback = funcp; + erts_mtx_lock(&async_ready_mtx); + callbacks = cb; + erts_mtx_unlock(&async_ready_mtx); + return async_handle; +} +#endif + +int init_async(int hndl) +{ + erts_thr_opts_t thr_opts = ERTS_THR_OPTS_DEFAULT_INITER; + AsyncQueue* q; + int i; + + thr_opts.detached = 0; + thr_opts.suggested_stack_size = erts_async_thread_suggested_stack_size; + +#ifndef ERTS_SMP + callbacks = NULL; + async_handle = hndl; + erts_mtx_init(&async_ready_mtx, "async_ready"); + async_ready_list = NULL; +#endif + + async_id = 0; + erts_smp_spinlock_init(&async_id_lock, "async_id"); + + async_q = q = (AsyncQueue*) + (erts_async_max_threads + ? erts_alloc(ERTS_ALC_T_ASYNC_Q, + erts_async_max_threads * sizeof(AsyncQueue)) + : NULL); + for (i = 0; i < erts_async_max_threads; i++) { + q->head = NULL; + q->tail = NULL; + q->len = 0; +#ifndef ERTS_SMP + q->hndl = hndl; +#endif +#ifdef ERTS_ENABLE_LOCK_CHECK + q->no = i; +#endif + erts_mtx_init(&q->mtx, "asyncq"); + erts_cnd_init(&q->cv); + erts_thr_create(&q->thr, async_main, (void*)q, &thr_opts); + q++; + } + return 0; +} + + +int exit_async() +{ + int i; + + /* terminate threads */ + for (i = 0; i < erts_async_max_threads; i++) { + ErlAsync* a = (ErlAsync*) erts_alloc(ERTS_ALC_T_ASYNC, + sizeof(ErlAsync)); + a->port = NIL; + async_add(a, &async_q[i]); + } + + for (i = 0; i < erts_async_max_threads; i++) { + erts_thr_join(async_q[i].thr, NULL); + erts_mtx_destroy(&async_q[i].mtx); + erts_cnd_destroy(&async_q[i].cv); + } +#ifndef ERTS_SMP + erts_mtx_destroy(&async_ready_mtx); +#endif + if (async_q) + erts_free(ERTS_ALC_T_ASYNC_Q, (void *) async_q); + return 0; +} + + +static void async_add(ErlAsync* a, AsyncQueue* q) +{ + /* XXX:PaN Is this still necessary when ports lock drivers? */ + if (is_internal_port(a->port)) { + ERTS_LC_ASSERT(erts_drvportid2port(a->port)); + /* make sure the driver will stay around */ + driver_lock_driver(internal_port_index(a->port)); + } + + erts_mtx_lock(&q->mtx); + + if (q->len == 0) { + q->head = a; + q->tail = a; + q->len = 1; + erts_cnd_signal(&q->cv); + } + else { /* no need to signal (since the worker is working) */ + a->next = q->head; + q->head->prev = a; + q->head = a; + q->len++; + } + erts_mtx_unlock(&q->mtx); +} + +static ErlAsync* async_get(AsyncQueue* q) +{ + ErlAsync* a; + + erts_mtx_lock(&q->mtx); + while((a = q->tail) == NULL) { + erts_cnd_wait(&q->cv, &q->mtx); + } +#ifdef ERTS_SMP + ASSERT(a && q->tail == a); +#endif + if (q->head == q->tail) { + q->head = q->tail = NULL; + q->len = 0; + } + else { + q->tail->prev->next = NULL; + q->tail = q->tail->prev; + q->len--; + } + erts_mtx_unlock(&q->mtx); + return a; +} + + +static int async_del(long id) +{ + int i; + /* scan all queue for an entry with async_id == 'id' */ + + for (i = 0; i < erts_async_max_threads; i++) { + ErlAsync* a; + erts_mtx_lock(&async_q[i].mtx); + + a = async_q[i].head; + while(a != NULL) { + if (a->async_id == id) { + if (a->prev != NULL) + a->prev->next = a->next; + else + async_q[i].head = a->next; + if (a->next != NULL) + a->next->prev = a->prev; + else + async_q[i].tail = a->prev; + async_q[i].len--; + erts_mtx_unlock(&async_q[i].mtx); + if (a->async_free != NULL) + a->async_free(a->async_data); + async_detach(a->hndl); + erts_free(ERTS_ALC_T_ASYNC, a); + return 1; + } + } + erts_mtx_unlock(&async_q[i].mtx); + } + return 0; +} + +static void* async_main(void* arg) +{ + AsyncQueue* q = (AsyncQueue*) arg; + +#ifdef ERTS_ENABLE_LOCK_CHECK + { + char buf[27]; + erts_snprintf(&buf[0], 27, "async %d", q->no); + erts_lc_set_thread_name(&buf[0]); + } +#endif + + while(1) { + ErlAsync* a = async_get(q); + + if (a->port == NIL) { /* TIME TO DIE SIGNAL */ + erts_free(ERTS_ALC_T_ASYNC, (void *) a); + break; + } + else { + (*a->async_invoke)(a->async_data); + /* Major problem if the code for async_invoke + or async_free is removed during a blocking operation */ +#ifdef ERTS_SMP + { + Port *p; + p = erts_id2port_sflgs(a->port, + NULL, + 0, + ERTS_PORT_SFLGS_INVALID_DRIVER_LOOKUP); + if (!p) { + if (a->async_free) + (*a->async_free)(a->async_data); + } + else { + if (async_ready(p, a->async_data)) { + if (a->async_free) + (*a->async_free)(a->async_data); + } + async_detach(a->hndl); + erts_port_release(p); + } + if (a->pdl) { + driver_pdl_dec_refc(a->pdl); + } + erts_free(ERTS_ALC_T_ASYNC, (void *) a); + } +#else + if (a->pdl) { + driver_pdl_dec_refc(a->pdl); + } + erts_mtx_lock(&async_ready_mtx); + a->next = async_ready_list; + async_ready_list = a; + erts_mtx_unlock(&async_ready_mtx); + sys_async_ready(q->hndl); +#endif + } + } + + return NULL; +} + + +#endif + +#ifndef ERTS_SMP + +int check_async_ready(void) +{ +#ifdef USE_THREADS + ErtsAsyncReadyCallback *cbs; +#endif + ErlAsync* a; + int count = 0; + + erts_mtx_lock(&async_ready_mtx); + a = async_ready_list; + async_ready_list = NULL; +#ifdef USE_THREADS + cbs = callbacks; +#endif + erts_mtx_unlock(&async_ready_mtx); + + while(a != NULL) { + ErlAsync* a_next = a->next; + /* Every port not dead */ + Port *p = erts_id2port_sflgs(a->port, + NULL, + 0, + ERTS_PORT_SFLGS_INVALID_DRIVER_LOOKUP); + if (!p) { + if (a->async_free) + (*a->async_free)(a->async_data); + } + else { + count++; + if (async_ready(p, a->async_data)) { + if (a->async_free != NULL) + (*a->async_free)(a->async_data); + } + async_detach(a->hndl); + erts_port_release(p); + } + erts_free(ERTS_ALC_T_ASYNC, (void *) a); + a = a_next; + } +#ifdef USE_THREADS + for (; cbs; cbs = cbs->next) + (*cbs->callback)(); +#endif + return count; +} + +#endif + + +/* +** Schedule async_invoke on a worker thread +** NOTE will be syncrounous when threads are unsupported +** return values: +** 0 completed +** -1 error +** N handle value (used with async_cancel) +** arguments: +** ix driver index +** key pointer to secedule queue (NULL means round robin) +** async_invoke function to run in thread +** async_data data to pass to invoke function +** async_free function for relase async_data in case of failure +*/ +long driver_async(ErlDrvPort ix, unsigned int* key, + void (*async_invoke)(void*), void* async_data, + void (*async_free)(void*)) +{ + ErlAsync* a = (ErlAsync*) erts_alloc(ERTS_ALC_T_ASYNC, sizeof(ErlAsync)); + Port* prt = erts_drvport2port(ix); + long id; + unsigned int qix; + + + if (!prt) + return -1; + + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(prt)); + + a->next = NULL; + a->prev = NULL; + a->hndl = (DE_Handle*)prt->drv_ptr->handle; + a->port = prt->id; + a->pdl = NULL; + a->async_data = async_data; + a->async_invoke = async_invoke; + a->async_free = async_free; + + erts_smp_spin_lock(&async_id_lock); + async_id = (async_id + 1) & 0x7fffffff; + if (async_id == 0) + async_id++; + id = async_id; + erts_smp_spin_unlock(&async_id_lock); + + a->async_id = id; + + if (key == NULL) { + qix = (erts_async_max_threads > 0) + ? (id % erts_async_max_threads) : 0; + } + else { + qix = (erts_async_max_threads > 0) ? + (*key % erts_async_max_threads) : 0; + *key = qix; + } +#ifdef USE_THREADS + if (erts_async_max_threads > 0) { + if (prt->port_data_lock) { + driver_pdl_inc_refc(prt->port_data_lock); + a->pdl = prt->port_data_lock; + } + async_add(a, &async_q[qix]); + return id; + } +#endif + + (*a->async_invoke)(a->async_data); + + if (async_ready(prt, a->async_data)) { + if (a->async_free != NULL) + (*a->async_free)(a->async_data); + } + erts_free(ERTS_ALC_T_ASYNC, (void *) a); + + return id; +} + +int driver_async_cancel(unsigned int id) +{ +#ifdef USE_THREADS + if (erts_async_max_threads > 0) + return async_del(id); +#endif + return 0; +} + + + + + diff --git a/erts/emulator/beam/erl_bestfit_alloc.c b/erts/emulator/beam/erl_bestfit_alloc.c new file mode 100644 index 0000000000..3035e5df16 --- /dev/null +++ b/erts/emulator/beam/erl_bestfit_alloc.c @@ -0,0 +1,1161 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2003-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + + +/* + * Description: A combined "address order best fit"/"best fit" allocator + * based on a Red-Black (binary search) Tree. The search, + * insert, and delete operations are all O(log n) operations + * on a Red-Black Tree. In the "address order best fit" case + * n equals number of free blocks, and in the "best fit" case + * n equals number of distinct sizes of free blocks. Red-Black + * Trees are described in "Introduction to Algorithms", by + * Thomas H. Cormen, Charles E. Leiserson, and + * Ronald L. Riverest. + * + * This module is a callback-module for erl_alloc_util.c + * + * Author: Rickard Green + */ + + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif +#include "global.h" +#define GET_ERL_BF_ALLOC_IMPL +#include "erl_bestfit_alloc.h" + +#ifdef DEBUG +#if 0 +#define HARD_DEBUG +#endif +#else +#undef HARD_DEBUG +#endif + +#define MIN_MBC_SZ (16*1024) +#define MIN_MBC_FIRST_FREE_SZ (4*1024) + +#define TREE_NODE_FLG (((Uint) 1) << 0) +#define RED_FLG (((Uint) 1) << 1) +#ifdef HARD_DEBUG +# define LEFT_VISITED_FLG (((Uint) 1) << 2) +# define RIGHT_VISITED_FLG (((Uint) 1) << 3) +#endif + +#define IS_TREE_NODE(N) (((RBTree_t *) (N))->flags & TREE_NODE_FLG) +#define IS_LIST_ELEM(N) (!IS_TREE_NODE(((RBTree_t *) (N)))) + +#define SET_TREE_NODE(N) (((RBTree_t *) (N))->flags |= TREE_NODE_FLG) +#define SET_LIST_ELEM(N) (((RBTree_t *) (N))->flags &= ~TREE_NODE_FLG) + +#define IS_RED(N) (((RBTree_t *) (N)) \ + && ((RBTree_t *) (N))->flags & RED_FLG) +#define IS_BLACK(N) (!IS_RED(((RBTree_t *) (N)))) + +#define SET_RED(N) (((RBTree_t *) (N))->flags |= RED_FLG) +#define SET_BLACK(N) (((RBTree_t *) (N))->flags &= ~RED_FLG) + +#undef ASSERT +#define ASSERT ASSERT_EXPR + +#if 1 +#define RBT_ASSERT ASSERT +#else +#define RBT_ASSERT(x) +#endif + + +#ifdef HARD_DEBUG +static RBTree_t * check_tree(BFAllctr_t *, Uint); +#endif + +static void tree_delete(Allctr_t *allctr, Block_t *del); + +/* Prototypes of callback functions */ + +/* "address order best fit" specific callback functions */ +static Block_t * aobf_get_free_block (Allctr_t *, Uint, + Block_t *, Uint); +static void aobf_link_free_block (Allctr_t *, Block_t *); +#define aobf_unlink_free_block tree_delete + +/* "best fit" specific callback functions */ +static Block_t * bf_get_free_block (Allctr_t *, Uint, + Block_t *, Uint); +static void bf_link_free_block (Allctr_t *, Block_t *); +static ERTS_INLINE void bf_unlink_free_block (Allctr_t *, Block_t *); + + +static Eterm info_options (Allctr_t *, char *, int *, + void *, Uint **, Uint *); +static void init_atoms (void); + +/* Types... */ +struct RBTree_t_ { + Block_t hdr; + Uint flags; + RBTree_t *parent; + RBTree_t *left; + RBTree_t *right; +}; + +typedef struct { + RBTree_t t; + RBTree_t *next; +} RBTreeList_t; + +#define LIST_NEXT(N) (((RBTreeList_t *) (N))->next) +#define LIST_PREV(N) (((RBTreeList_t *) (N))->t.parent) + + +#ifdef DEBUG + +/* Destroy all tree fields */ +#define DESTROY_TREE_NODE(N) \ + sys_memset((void *) (((Block_t *) (N)) + 1), \ + 0xff, \ + (sizeof(RBTree_t) - sizeof(Block_t))) + +/* Destroy all tree and list fields */ +#define DESTROY_LIST_ELEM(N) \ + sys_memset((void *) (((Block_t *) (N)) + 1), \ + 0xff, \ + (sizeof(RBTreeList_t) - sizeof(Block_t))) + +#else + +#define DESTROY_TREE_NODE(N) +#define DESTROY_LIST_ELEM(N) + +#endif + + +static int atoms_initialized = 0; + +void +erts_bfalc_init(void) +{ + atoms_initialized = 0; +} + +Allctr_t * +erts_bfalc_start(BFAllctr_t *bfallctr, + BFAllctrInit_t *bfinit, + AllctrInit_t *init) +{ + BFAllctr_t nulled_state = {{0}}; + /* {{0}} is used instead of {0}, in order to avoid (an incorrect) gcc + warning. gcc warns if {0} is used as initializer of a struct when + the first member is a struct (not if, for example, the third member + is a struct). */ + Allctr_t *allctr = (Allctr_t *) bfallctr; + + sys_memcpy((void *) bfallctr, (void *) &nulled_state, sizeof(BFAllctr_t)); + + bfallctr->address_order = bfinit->ao; + + + allctr->mbc_header_size = sizeof(Carrier_t); + allctr->min_mbc_size = MIN_MBC_SZ; + allctr->min_mbc_first_free_size = MIN_MBC_FIRST_FREE_SZ; + allctr->min_block_size = (bfinit->ao + ? sizeof(RBTree_t) + : sizeof(RBTreeList_t)); + + allctr->vsn_str = (bfinit->ao + ? ERTS_ALC_AOBF_ALLOC_VSN_STR + : ERTS_ALC_BF_ALLOC_VSN_STR); + + + /* Callback functions */ + + if (bfinit->ao) { + allctr->get_free_block = aobf_get_free_block; + allctr->link_free_block = aobf_link_free_block; + allctr->unlink_free_block = aobf_unlink_free_block; + } + else { + allctr->get_free_block = bf_get_free_block; + allctr->link_free_block = bf_link_free_block; + allctr->unlink_free_block = bf_unlink_free_block; + } + allctr->info_options = info_options; + + allctr->get_next_mbc_size = NULL; + allctr->creating_mbc = NULL; + allctr->destroying_mbc = NULL; + allctr->init_atoms = init_atoms; + +#ifdef ERTS_ALLOC_UTIL_HARD_DEBUG + allctr->check_block = NULL; + allctr->check_mbc = NULL; +#endif + + allctr->atoms_initialized = 0; + + if (!erts_alcu_start(allctr, init)) + return NULL; + + return allctr; +} + +/* + * Red-Black Tree operations needed + */ + +static ERTS_INLINE void +left_rotate(RBTree_t **root, RBTree_t *x) +{ + RBTree_t *y = x->right; + x->right = y->left; + if (y->left) + y->left->parent = x; + y->parent = x->parent; + if (!y->parent) { + RBT_ASSERT(*root == x); + *root = y; + } + else if (x == x->parent->left) + x->parent->left = y; + else { + RBT_ASSERT(x == x->parent->right); + x->parent->right = y; + } + y->left = x; + x->parent = y; +} + +static ERTS_INLINE void +right_rotate(RBTree_t **root, RBTree_t *x) +{ + RBTree_t *y = x->left; + x->left = y->right; + if (y->right) + y->right->parent = x; + y->parent = x->parent; + if (!y->parent) { + RBT_ASSERT(*root == x); + *root = y; + } + else if (x == x->parent->right) + x->parent->right = y; + else { + RBT_ASSERT(x == x->parent->left); + x->parent->left = y; + } + y->right = x; + x->parent = y; +} + + +/* + * Replace node x with node y + * NOTE: block header of y is not changed + */ +static ERTS_INLINE void +replace(RBTree_t **root, RBTree_t *x, RBTree_t *y) +{ + + if (!x->parent) { + RBT_ASSERT(*root == x); + *root = y; + } + else if (x == x->parent->left) + x->parent->left = y; + else { + RBT_ASSERT(x == x->parent->right); + x->parent->right = y; + } + if (x->left) { + RBT_ASSERT(x->left->parent == x); + x->left->parent = y; + } + if (x->right) { + RBT_ASSERT(x->right->parent == x); + x->right->parent = y; + } + + y->flags = x->flags; + y->parent = x->parent; + y->right = x->right; + y->left = x->left; + + DESTROY_TREE_NODE(x); + +} + +static void +tree_insert_fixup(BFAllctr_t *bfallctr, RBTree_t *blk) +{ + RBTree_t *x = blk, *y; + + /* + * Rearrange the tree so that it satisfies the Red-Black Tree properties + */ + + RBT_ASSERT(x != bfallctr->root && IS_RED(x->parent)); + do { + + /* + * x and its parent are both red. Move the red pair up the tree + * until we get to the root or until we can separate them. + */ + + RBT_ASSERT(IS_RED(x)); + RBT_ASSERT(IS_BLACK(x->parent->parent)); + RBT_ASSERT(x->parent->parent); + + if (x->parent == x->parent->parent->left) { + y = x->parent->parent->right; + if (IS_RED(y)) { + SET_BLACK(y); + x = x->parent; + SET_BLACK(x); + x = x->parent; + SET_RED(x); + } + else { + + if (x == x->parent->right) { + x = x->parent; + left_rotate(&bfallctr->root, x); + } + + RBT_ASSERT(x == x->parent->parent->left->left); + RBT_ASSERT(IS_RED(x)); + RBT_ASSERT(IS_RED(x->parent)); + RBT_ASSERT(IS_BLACK(x->parent->parent)); + RBT_ASSERT(IS_BLACK(y)); + + SET_BLACK(x->parent); + SET_RED(x->parent->parent); + right_rotate(&bfallctr->root, x->parent->parent); + + RBT_ASSERT(x == x->parent->left); + RBT_ASSERT(IS_RED(x)); + RBT_ASSERT(IS_RED(x->parent->right)); + RBT_ASSERT(IS_BLACK(x->parent)); + break; + } + } + else { + RBT_ASSERT(x->parent == x->parent->parent->right); + y = x->parent->parent->left; + if (IS_RED(y)) { + SET_BLACK(y); + x = x->parent; + SET_BLACK(x); + x = x->parent; + SET_RED(x); + } + else { + + if (x == x->parent->left) { + x = x->parent; + right_rotate(&bfallctr->root, x); + } + + RBT_ASSERT(x == x->parent->parent->right->right); + RBT_ASSERT(IS_RED(x)); + RBT_ASSERT(IS_RED(x->parent)); + RBT_ASSERT(IS_BLACK(x->parent->parent)); + RBT_ASSERT(IS_BLACK(y)); + + SET_BLACK(x->parent); + SET_RED(x->parent->parent); + left_rotate(&bfallctr->root, x->parent->parent); + + RBT_ASSERT(x == x->parent->right); + RBT_ASSERT(IS_RED(x)); + RBT_ASSERT(IS_RED(x->parent->left)); + RBT_ASSERT(IS_BLACK(x->parent)); + break; + } + } + } while (x != bfallctr->root && IS_RED(x->parent)); + + SET_BLACK(bfallctr->root); + +} + +/* + * The argument types of "Allctr_t *" and "Block_t *" have been + * chosen since we then can use tree_delete() as unlink_free_block + * callback function in the address order case. + */ +static void +tree_delete(Allctr_t *allctr, Block_t *del) +{ + BFAllctr_t *bfallctr = (BFAllctr_t *) allctr; + Uint spliced_is_black; + RBTree_t *x, *y, *z = (RBTree_t *) del; + RBTree_t null_x; /* null_x is used to get the fixup started when we + splice out a node without children. */ + + null_x.parent = NULL; + +#ifdef HARD_DEBUG + check_tree(bfallctr, 0); +#endif + + /* Remove node from tree... */ + + /* Find node to splice out */ + if (!z->left || !z->right) + y = z; + else + /* Set y to z:s successor */ + for(y = z->right; y->left; y = y->left); + /* splice out y */ + x = y->left ? y->left : y->right; + spliced_is_black = IS_BLACK(y); + if (x) { + x->parent = y->parent; + } + else if (!x && spliced_is_black) { + x = &null_x; + x->flags = 0; + SET_BLACK(x); + x->right = x->left = NULL; + x->parent = y->parent; + y->left = x; + } + + if (!y->parent) { + RBT_ASSERT(bfallctr->root == y); + bfallctr->root = x; + } + else if (y == y->parent->left) + y->parent->left = x; + else { + RBT_ASSERT(y == y->parent->right); + y->parent->right = x; + } + if (y != z) { + /* We spliced out the successor of z; replace z by the successor */ + replace(&bfallctr->root, z, y); + } + + if (spliced_is_black) { + /* We removed a black node which makes the resulting tree + violate the Red-Black Tree properties. Fixup tree... */ + + while (IS_BLACK(x) && x->parent) { + + /* + * x has an "extra black" which we move up the tree + * until we reach the root or until we can get rid of it. + * + * y is the sibbling of x + */ + + if (x == x->parent->left) { + y = x->parent->right; + RBT_ASSERT(y); + if (IS_RED(y)) { + RBT_ASSERT(y->right); + RBT_ASSERT(y->left); + SET_BLACK(y); + RBT_ASSERT(IS_BLACK(x->parent)); + SET_RED(x->parent); + left_rotate(&bfallctr->root, x->parent); + y = x->parent->right; + } + RBT_ASSERT(y); + RBT_ASSERT(IS_BLACK(y)); + if (IS_BLACK(y->left) && IS_BLACK(y->right)) { + SET_RED(y); + x = x->parent; + } + else { + if (IS_BLACK(y->right)) { + SET_BLACK(y->left); + SET_RED(y); + right_rotate(&bfallctr->root, y); + y = x->parent->right; + } + RBT_ASSERT(y); + if (IS_RED(x->parent)) { + + SET_BLACK(x->parent); + SET_RED(y); + } + RBT_ASSERT(y->right); + SET_BLACK(y->right); + left_rotate(&bfallctr->root, x->parent); + x = bfallctr->root; + break; + } + } + else { + RBT_ASSERT(x == x->parent->right); + y = x->parent->left; + RBT_ASSERT(y); + if (IS_RED(y)) { + RBT_ASSERT(y->right); + RBT_ASSERT(y->left); + SET_BLACK(y); + RBT_ASSERT(IS_BLACK(x->parent)); + SET_RED(x->parent); + right_rotate(&bfallctr->root, x->parent); + y = x->parent->left; + } + RBT_ASSERT(y); + RBT_ASSERT(IS_BLACK(y)); + if (IS_BLACK(y->right) && IS_BLACK(y->left)) { + SET_RED(y); + x = x->parent; + } + else { + if (IS_BLACK(y->left)) { + SET_BLACK(y->right); + SET_RED(y); + left_rotate(&bfallctr->root, y); + y = x->parent->left; + } + RBT_ASSERT(y); + if (IS_RED(x->parent)) { + SET_BLACK(x->parent); + SET_RED(y); + } + RBT_ASSERT(y->left); + SET_BLACK(y->left); + right_rotate(&bfallctr->root, x->parent); + x = bfallctr->root; + break; + } + } + } + SET_BLACK(x); + + if (null_x.parent) { + if (null_x.parent->left == &null_x) + null_x.parent->left = NULL; + else { + RBT_ASSERT(null_x.parent->right == &null_x); + null_x.parent->right = NULL; + } + RBT_ASSERT(!null_x.left); + RBT_ASSERT(!null_x.right); + } + else if (bfallctr->root == &null_x) { + bfallctr->root = NULL; + RBT_ASSERT(!null_x.left); + RBT_ASSERT(!null_x.right); + } + } + + + DESTROY_TREE_NODE(del); + +#ifdef HARD_DEBUG + check_tree(bfallctr, 0); +#endif + +} + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *\ + * "Address order best fit" specific callbacks. * +\* */ + +static void +aobf_link_free_block(Allctr_t *allctr, Block_t *block) +{ + BFAllctr_t *bfallctr = (BFAllctr_t *) allctr; + RBTree_t *blk = (RBTree_t *) block; + Uint blk_sz = BLK_SZ(blk); + + blk->flags = 0; + blk->left = NULL; + blk->right = NULL; + + if (!bfallctr->root) { + blk->parent = NULL; + SET_BLACK(blk); + bfallctr->root = blk; + } + else { + RBTree_t *x = bfallctr->root; + while (1) { + Uint size; + + size = BLK_SZ(x); + + if (blk_sz < size || (blk_sz == size && blk < x)) { + if (!x->left) { + blk->parent = x; + x->left = blk; + break; + } + x = x->left; + } + else { + if (!x->right) { + blk->parent = x; + x->right = blk; + break; + } + x = x->right; + } + + } + + /* Insert block into size tree */ + RBT_ASSERT(blk->parent); + + SET_RED(blk); + if (IS_RED(blk->parent)) + tree_insert_fixup(bfallctr, blk); + } + +#ifdef HARD_DEBUG + check_tree(bfallctr, 0); +#endif +} + +#if 0 /* tree_delete() is directly used instead */ +static void +aobf_unlink_free_block(Allctr_t *allctr, Block_t *block) +{ + tree_delete(allctr, block); +} +#endif + +static Block_t * +aobf_get_free_block(Allctr_t *allctr, Uint size, + Block_t *cand_blk, Uint cand_size) +{ + BFAllctr_t *bfallctr = (BFAllctr_t *) allctr; + RBTree_t *x = bfallctr->root; + RBTree_t *blk = NULL; + Uint blk_sz; + + ASSERT(!cand_blk || cand_size >= size); + + while (x) { + blk_sz = BLK_SZ(x); + if (blk_sz < size) { + x = x->right; + } + else { + blk = x; + x = x->left; + } + } + + if (!blk) + return NULL; + +#ifdef HARD_DEBUG + ASSERT(blk == check_tree(bfallctr, size)); +#endif + + if (cand_blk) { + blk_sz = BLK_SZ(blk); + if (cand_size < blk_sz) + return NULL; /* cand_blk was better */ + if (cand_size == blk_sz && ((void *) cand_blk) < ((void *) blk)) + return NULL; /* cand_blk was better */ + } + + aobf_unlink_free_block(allctr, (Block_t *) blk); + + return (Block_t *) blk; +} + + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *\ + * "Best fit" specific callbacks. * +\* */ + +static void +bf_link_free_block(Allctr_t *allctr, Block_t *block) +{ + BFAllctr_t *bfallctr = (BFAllctr_t *) allctr; + RBTree_t *blk = (RBTree_t *) block; + Uint blk_sz = BLK_SZ(blk); + + SET_TREE_NODE(blk); + + + blk->flags = 0; + blk->left = NULL; + blk->right = NULL; + + if (!bfallctr->root) { + blk->parent = NULL; + SET_BLACK(blk); + bfallctr->root = blk; + } + else { + RBTree_t *x = bfallctr->root; + while (1) { + Uint size; + + size = BLK_SZ(x); + + if (blk_sz == size) { + + SET_LIST_ELEM(blk); + LIST_NEXT(blk) = LIST_NEXT(x); + LIST_PREV(blk) = x; + if (LIST_NEXT(x)) + LIST_PREV(LIST_NEXT(x)) = blk; + LIST_NEXT(x) = blk; + + return; /* Finnished */ + } + else if (blk_sz < size) { + if (!x->left) { + blk->parent = x; + x->left = blk; + break; + } + x = x->left; + } + else { + if (!x->right) { + blk->parent = x; + x->right = blk; + break; + } + x = x->right; + } + } + + RBT_ASSERT(blk->parent); + + SET_RED(blk); + if (IS_RED(blk->parent)) + tree_insert_fixup(bfallctr, blk); + + } + + SET_TREE_NODE(blk); + LIST_NEXT(blk) = NULL; + +#ifdef HARD_DEBUG + check_tree(bfallctr, 0); +#endif +} + +static ERTS_INLINE void +bf_unlink_free_block(Allctr_t *allctr, Block_t *block) +{ + BFAllctr_t *bfallctr = (BFAllctr_t *) allctr; + RBTree_t *x = (RBTree_t *) block; + + if (IS_LIST_ELEM(x)) { + /* Remove from list */ + ASSERT(LIST_PREV(x)); + LIST_NEXT(LIST_PREV(x)) = LIST_NEXT(x); + if (LIST_NEXT(x)) + LIST_PREV(LIST_NEXT(x)) = LIST_PREV(x); + } + else if (LIST_NEXT(x)) { + /* Replace tree node by next element in list... */ + + ASSERT(BLK_SZ(LIST_NEXT(x)) == BLK_SZ(x)); + ASSERT(IS_TREE_NODE(x)); + ASSERT(IS_LIST_ELEM(LIST_NEXT(x))); + +#ifdef HARD_DEBUG + check_tree(bfallctr, 0); +#endif + replace(&bfallctr->root, x, LIST_NEXT(x)); + +#ifdef HARD_DEBUG + check_tree(bfallctr, 0); +#endif + } + else { + /* Remove from tree */ + tree_delete(allctr, block); + } + + DESTROY_LIST_ELEM(x); +} + + +static Block_t * +bf_get_free_block(Allctr_t *allctr, Uint size, + Block_t *cand_blk, Uint cand_size) +{ + BFAllctr_t *bfallctr = (BFAllctr_t *) allctr; + RBTree_t *x = bfallctr->root; + RBTree_t *blk = NULL; + Uint blk_sz; + + ASSERT(!cand_blk || cand_size >= size); + + while (x) { + blk_sz = BLK_SZ(x); + if (blk_sz < size) { + x = x->right; + } + else { + blk = x; + if (blk_sz == size) + break; + x = x->left; + } + } + + if (!blk) + return NULL; + + ASSERT(IS_TREE_NODE(blk)); + + +#ifdef HARD_DEBUG + { + RBTree_t *ct_blk = check_tree(bfallctr, size); + ASSERT(BLK_SZ(ct_blk) == BLK_SZ(blk)); + } +#endif + + if (cand_blk && cand_size <= BLK_SZ(blk)) + return NULL; /* cand_blk was better */ + + /* Use next block if it exist in order to avoid replacing + the tree node */ + blk = LIST_NEXT(blk) ? LIST_NEXT(blk) : blk; + + bf_unlink_free_block(allctr, (Block_t *) blk); + return (Block_t *) blk; +} + + +/* + * info_options() + */ + +static struct { + Eterm as; + Eterm aobf; + Eterm bf; +#ifdef DEBUG + Eterm end_of_atoms; +#endif +} am; + +static void ERTS_INLINE atom_init(Eterm *atom, char *name) +{ + *atom = am_atom_put(name, strlen(name)); +} +#define AM_INIT(AM) atom_init(&am.AM, #AM) + +static void +init_atoms(void) +{ +#ifdef DEBUG + Eterm *atom; +#endif + + if (atoms_initialized) + return; + +#ifdef DEBUG + for (atom = (Eterm *) &am; atom <= &am.end_of_atoms; atom++) { + *atom = THE_NON_VALUE; + } +#endif + AM_INIT(as); + AM_INIT(aobf); + AM_INIT(bf); + +#ifdef DEBUG + for (atom = (Eterm *) &am; atom < &am.end_of_atoms; atom++) { + ASSERT(*atom != THE_NON_VALUE); + } +#endif + + atoms_initialized = 1; +} + + +#define bld_uint erts_bld_uint +#define bld_cons erts_bld_cons +#define bld_tuple erts_bld_tuple + +static ERTS_INLINE void +add_2tup(Uint **hpp, Uint *szp, Eterm *lp, Eterm el1, Eterm el2) +{ + *lp = bld_cons(hpp, szp, bld_tuple(hpp, szp, 2, el1, el2), *lp); +} + +static Eterm +info_options(Allctr_t *allctr, + char *prefix, + int *print_to_p, + void *print_to_arg, + Uint **hpp, + Uint *szp) +{ + BFAllctr_t *bfallctr = (BFAllctr_t *) allctr; + Eterm res = THE_NON_VALUE; + + if (print_to_p) { + erts_print(*print_to_p, + print_to_arg, + "%sas: %s\n", + prefix, + bfallctr->address_order ? "aobf" : "bf"); + } + + if (hpp || szp) { + + if (!atoms_initialized) + erl_exit(1, "%s:%d: Internal error: Atoms not initialized", + __FILE__, __LINE__);; + + res = NIL; + add_2tup(hpp, szp, &res, + am.as, + bfallctr->address_order ? am.aobf : am.bf); + } + + return res; +} + + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *\ + * NOTE: erts_bfalc_test() is only supposed to be used for testing. * + * * + * Keep alloc_SUITE_data/allocator_test.h updated if changes are made * + * to erts_bfalc_test() * +\* */ + +unsigned long +erts_bfalc_test(unsigned long op, unsigned long a1, unsigned long a2) +{ + switch (op) { + case 0x200: return (unsigned long) ((BFAllctr_t *) a1)->address_order; + case 0x201: return (unsigned long) ((BFAllctr_t *) a1)->root; + case 0x202: return (unsigned long) ((RBTree_t *) a1)->parent; + case 0x203: return (unsigned long) ((RBTree_t *) a1)->left; + case 0x204: return (unsigned long) ((RBTree_t *) a1)->right; + case 0x205: return (unsigned long) ((RBTreeList_t *) a1)->next; + case 0x206: return (unsigned long) IS_BLACK((RBTree_t *) a1); + case 0x207: return (unsigned long) IS_TREE_NODE((RBTree_t *) a1); + default: ASSERT(0); return ~((unsigned long) 0); + } +} + + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *\ + * Debug functions * +\* */ + + +#ifdef HARD_DEBUG + +#define IS_LEFT_VISITED(FB) ((FB)->flags & LEFT_VISITED_FLG) +#define IS_RIGHT_VISITED(FB) ((FB)->flags & RIGHT_VISITED_FLG) + +#define SET_LEFT_VISITED(FB) ((FB)->flags |= LEFT_VISITED_FLG) +#define SET_RIGHT_VISITED(FB) ((FB)->flags |= RIGHT_VISITED_FLG) + +#define UNSET_LEFT_VISITED(FB) ((FB)->flags &= ~LEFT_VISITED_FLG) +#define UNSET_RIGHT_VISITED(FB) ((FB)->flags &= ~RIGHT_VISITED_FLG) + + +#if 0 +# define PRINT_TREE +#else +# undef PRINT_TREE +#endif + +#ifdef PRINT_TREE +static void print_tree(BFAllctr_t *); +#endif + +/* + * Checks that the order between parent and children are correct, + * and that the Red-Black Tree properies are satisfied. if size > 0, + * check_tree() returns a node that satisfies "best fit" resp. + * "address order best fit". + * + * The Red-Black Tree properies are: + * 1. Every node is either red or black. + * 2. Every leaf (NIL) is black. + * 3. If a node is red, then both its children are black. + * 4. Every simple path from a node to a descendant leaf + * contains the same number of black nodes. + */ + +static RBTree_t * +check_tree(BFAllctr_t *bfallctr, Uint size) +{ + RBTree_t *res = NULL; + Sint blacks; + Sint curr_blacks; + RBTree_t *x; + +#ifdef PRINT_TREE + print_tree(bfallctr); +#endif + + if (!bfallctr->root) + return res; + + x = bfallctr->root; + ASSERT(IS_BLACK(x)); + ASSERT(!x->parent); + curr_blacks = 1; + blacks = -1; + + while (x) { + if (!IS_LEFT_VISITED(x)) { + SET_LEFT_VISITED(x); + if (x->left) { + x = x->left; + if (IS_BLACK(x)) + curr_blacks++; + continue; + } + else { + if (blacks < 0) + blacks = curr_blacks; + ASSERT(blacks == curr_blacks); + } + } + + if (!IS_RIGHT_VISITED(x)) { + SET_RIGHT_VISITED(x); + if (x->right) { + x = x->right; + if (IS_BLACK(x)) + curr_blacks++; + continue; + } + else { + if (blacks < 0) + blacks = curr_blacks; + ASSERT(blacks == curr_blacks); + } + } + + + if (IS_RED(x)) { + ASSERT(IS_BLACK(x->right)); + ASSERT(IS_BLACK(x->left)); + } + + ASSERT(x->parent || x == bfallctr->root); + + if (x->left) { + ASSERT(x->left->parent == x); + if (bfallctr->address_order) { + ASSERT(BLK_SZ(x->left) < BLK_SZ(x) + || (BLK_SZ(x->left) == BLK_SZ(x) && x->left < x)); + } + else { + ASSERT(IS_TREE_NODE(x->left)); + ASSERT(BLK_SZ(x->left) < BLK_SZ(x)); + } + } + + if (x->right) { + ASSERT(x->right->parent == x); + if (bfallctr->address_order) { + ASSERT(BLK_SZ(x->right) > BLK_SZ(x) + || (BLK_SZ(x->right) == BLK_SZ(x) && x->right > x)); + } + else { + ASSERT(IS_TREE_NODE(x->right)); + ASSERT(BLK_SZ(x->right) > BLK_SZ(x)); + } + } + + if (size && BLK_SZ(x) >= size) { + if (bfallctr->address_order) { + if (!res + || BLK_SZ(x) < BLK_SZ(res) + || (BLK_SZ(x) == BLK_SZ(res) && x < res)) + res = x; + } + else { + if (!res || BLK_SZ(x) < BLK_SZ(res)) + res = x; + } + } + + UNSET_LEFT_VISITED(x); + UNSET_RIGHT_VISITED(x); + if (IS_BLACK(x)) + curr_blacks--; + x = x->parent; + + } + + ASSERT(curr_blacks == 0); + + UNSET_LEFT_VISITED(bfallctr->root); + UNSET_RIGHT_VISITED(bfallctr->root); + + return res; + +} + + +#ifdef PRINT_TREE +#define INDENT_STEP 2 + +#include + +static void +print_tree_aux(RBTree_t *x, int indent) +{ + int i; + + if (!x) { + for (i = 0; i < indent; i++) { + putc(' ', stderr); + } + fprintf(stderr, "BLACK: nil\r\n"); + } + else { + print_tree_aux(x->right, indent + INDENT_STEP); + for (i = 0; i < indent; i++) { + putc(' ', stderr); + } + fprintf(stderr, "%s: sz=%lu addr=0x%lx\r\n", + IS_BLACK(x) ? "BLACK" : "RED", + BLK_SZ(x), + (Uint) x); + print_tree_aux(x->left, indent + INDENT_STEP); + } +} + + +static void +print_tree(BFAllctr_t *bfallctr) +{ + char *type = bfallctr->address_order ? "Size-Adress" : "Size"; + fprintf(stderr, " --- %s tree begin ---\r\n", type); + print_tree_aux(bfallctr->root, 0); + fprintf(stderr, " --- %s tree end ---\r\n", type); +} + +#endif + +#endif diff --git a/erts/emulator/beam/erl_bestfit_alloc.h b/erts/emulator/beam/erl_bestfit_alloc.h new file mode 100644 index 0000000000..cb35e21e57 --- /dev/null +++ b/erts/emulator/beam/erl_bestfit_alloc.h @@ -0,0 +1,64 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2003-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + + +#ifndef ERL_BESTFIT_ALLOC__ +#define ERL_BESTFIT_ALLOC__ + +#include "erl_alloc_util.h" + +#define ERTS_ALC_BF_ALLOC_VSN_STR "0.9" +#define ERTS_ALC_AOBF_ALLOC_VSN_STR "0.9" + +typedef struct BFAllctr_t_ BFAllctr_t; + +typedef struct { + int ao; +} BFAllctrInit_t; + +#define ERTS_DEFAULT_BF_ALLCTR_INIT { \ + 0 /* (bool) ao: address order */\ +} + +void erts_bfalc_init(void); +Allctr_t *erts_bfalc_start(BFAllctr_t *, BFAllctrInit_t *, AllctrInit_t *); + +#endif /* #ifndef ERL_BESTFIT_ALLOC__ */ + + + +#if defined(GET_ERL_BF_ALLOC_IMPL) && !defined(ERL_BF_ALLOC_IMPL__) +#define ERL_BF_ALLOC_IMPL__ + +#define GET_ERL_ALLOC_UTIL_IMPL +#include "erl_alloc_util.h" + +typedef struct RBTree_t_ RBTree_t; + +struct BFAllctr_t_ { + Allctr_t allctr; /* Has to be first! */ + + RBTree_t * root; + int address_order; +}; + +unsigned long erts_bfalc_test(unsigned long, unsigned long, unsigned long); + +#endif /* #if defined(GET_ERL_BF_ALLOC_IMPL) + && !defined(ERL_BF_ALLOC_IMPL__) */ diff --git a/erts/emulator/beam/erl_bif_chksum.c b/erts/emulator/beam/erl_bif_chksum.c new file mode 100644 index 0000000000..445ba00ca7 --- /dev/null +++ b/erts/emulator/beam/erl_bif_chksum.c @@ -0,0 +1,612 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2008-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "erl_process.h" +#include "error.h" +#include "bif.h" +#include "erl_binary.h" +#include "big.h" +#include "zlib.h" + + +typedef void (*ChksumFun)(void *sum_in_out, unsigned char *buf, + unsigned buflen); + +/* Hidden trap target */ +static BIF_RETTYPE md5_2(BIF_ALIST_2); + +static Export chksum_md5_2_exp; + +void erts_init_bif_chksum(void) +{ + /* Non visual BIF to trap to. */ + memset(&chksum_md5_2_exp, 0, sizeof(Export)); + chksum_md5_2_exp.address = + &chksum_md5_2_exp.code[3]; + chksum_md5_2_exp.code[0] = am_erlang; + chksum_md5_2_exp.code[1] = am_atom_put("md5_trap",8); + chksum_md5_2_exp.code[2] = 2; + chksum_md5_2_exp.code[3] = + (Eterm) em_apply_bif; + chksum_md5_2_exp.code[4] = + (Eterm) &md5_2; +} + + +static Eterm do_chksum(ChksumFun sumfun, Process *p, Eterm ioterm, int left, + void *sum, int *res, int *err) +{ + Eterm *objp; + Eterm obj; + int c; + DECLARE_ESTACK(stack); + unsigned char *bytes = NULL; + int numbytes = 0; + + *err = 0; + if (left <= 0 || is_nil(ioterm)) { + DESTROY_ESTACK(stack); + *res = 0; + return ioterm; + } + if(is_binary(ioterm)) { + Uint bitoffs; + Uint bitsize; + Uint size; + Eterm res_term = NIL; + unsigned char *bytes; + byte *temp_alloc = NULL; + + ERTS_GET_BINARY_BYTES(ioterm, bytes, bitoffs, bitsize); + if (bitsize != 0) { + *res = 0; + *err = 1; + DESTROY_ESTACK(stack); + return NIL; + } + if (bitoffs != 0) { + bytes = erts_get_aligned_binary_bytes(ioterm, &temp_alloc); + /* The call to erts_get_aligned_binary_bytes cannot fail as + we'we already checked bitsize and that this is a binary */ + } + + size = binary_size(ioterm); + + + if (size > left) { + Eterm *hp; + ErlSubBin *sb; + Eterm orig; + Uint offset; + /* Split the binary in two parts, of which we + only process the first */ + hp = HAlloc(p, ERL_SUB_BIN_SIZE); + sb = (ErlSubBin *) hp; + ERTS_GET_REAL_BIN(ioterm, orig, offset, bitoffs, bitsize); + sb->thing_word = HEADER_SUB_BIN; + sb->size = size - left; + sb->offs = offset + left; + sb->orig = orig; + sb->bitoffs = bitoffs; + sb->bitsize = bitsize; + sb->is_writable = 0; + res_term = make_binary(sb); + size = left; + } + (*sumfun)(sum, bytes, size); + *res = size; + DESTROY_ESTACK(stack); + erts_free_aligned_binary_bytes(temp_alloc); + return res_term; + } + + if (!is_list(ioterm)) { + *res = 0; + *err = 1; + DESTROY_ESTACK(stack); + return NIL; + } + + /* OK a list, needs to be processed in order, handling each flat list-level + as they occur, just like io_list_to_binary would */ + *res = 0; + ESTACK_PUSH(stack,ioterm); + while (!ESTACK_ISEMPTY(stack) && left) { + ioterm = ESTACK_POP(stack); + if (is_nil(ioterm)) { + /* ignore empty lists */ + continue; + } + if(is_list(ioterm)) { +L_Again: /* Restart with sublist, old listend was pushed on stack */ + objp = list_val(ioterm); + obj = CAR(objp); + for(;;) { /* loop over one flat list of bytes and binaries + until sublist or list end is encountered */ + if (is_byte(obj)) { + int bsize = 0; + for(;;) { + if (bsize >= numbytes) { + if (!bytes) { + bytes = erts_alloc(ERTS_ALC_T_TMP, + numbytes = 500); + } else { + if (numbytes > left) { + numbytes += left; + } else { + numbytes *= 2; + } + bytes = erts_realloc(ERTS_ALC_T_TMP, bytes, + numbytes); + } + } + bytes[bsize++] = (unsigned char) unsigned_val(obj); + --left; + ioterm = CDR(objp); + if (!is_list(ioterm)) { + break; + } + objp = list_val(ioterm); + obj = CAR(objp); + if (!is_byte(obj)) + break; + if (!left) { + break; + } + } + (*sumfun)(sum, bytes, bsize); + *res += bsize; + } else if (is_nil(obj)) { + ioterm = CDR(objp); + if (!is_list(ioterm)) { + break; + } + objp = list_val(ioterm); + obj = CAR(objp); + } else if (is_list(obj)) { + /* push rest of list for later processing, start + again with sublist */ + ESTACK_PUSH(stack,CDR(objp)); + ioterm = obj; + goto L_Again; + } else if (is_binary(obj)) { + int sres, serr; + Eterm rest_term; + rest_term = do_chksum(sumfun, p, obj, left, sum, &sres, + &serr); + *res += sres; + if (serr != 0) { + *err = 1; + DESTROY_ESTACK(stack); + if (bytes != NULL) + erts_free(ERTS_ALC_T_TMP, bytes); + return NIL; + } + left -= sres; + if (rest_term != NIL) { + Eterm *hp; + hp = HAlloc(p, 2); + obj = CDR(objp); + ioterm = CONS(hp, rest_term, obj); + left = 0; + break; + } + ioterm = CDR(objp); + if (is_list(ioterm)) { + /* objp and obj need to be updated if + loop is to continue */ + objp = list_val(ioterm); + obj = CAR(objp); + } + } else { + *err = 1; + DESTROY_ESTACK(stack); + if (bytes != NULL) + erts_free(ERTS_ALC_T_TMP, bytes); + return NIL; + } + if (!left || is_nil(ioterm) || !is_list(ioterm)) { + break; + } + } /* for(;;) */ + } /* is_list(ioterm) */ + + if (!left) { +#ifdef ALLOW_BYTE_TAIL + if (is_byte(ioterm)) { + /* inproper list with byte tail*/ + Eterm *hp; + hp = HAlloc(p, 2); + ioterm = CONS(hp, ioterm, NIL); + } +#else + ; +#endif + } else if (!is_list(ioterm) && !is_nil(ioterm)) { + /* inproper list end */ +#ifdef ALLOW_BYTE_TAIL + if (is_byte(ioterm)) { + unsigned char b[1]; + b[0] = (unsigned char) unsigned_val(ioterm); + (*sumfun)(sum, b, 1); + ++(*res); + --left; + ioterm = NIL; + } else +#endif + if is_binary(ioterm) { + int sres, serr; + ioterm = do_chksum(sumfun, p, ioterm, left, sum, &sres, &serr); + *res +=sres; + if (serr != 0) { + *err = 1; + DESTROY_ESTACK(stack); + if (bytes != NULL) + erts_free(ERTS_ALC_T_TMP, bytes); + return NIL; + } + left -= sres; + } else { + *err = 1; + DESTROY_ESTACK(stack); + if (bytes != NULL) + erts_free(ERTS_ALC_T_TMP, bytes); + return NIL; + } + } + } /* while left and not estack empty */ + c = ESTACK_COUNT(stack); + if (c > 0) { + Eterm *hp = HAlloc(p,2*c); + while(!ESTACK_ISEMPTY(stack)) { + Eterm st = ESTACK_POP(stack); + ioterm = CONS(hp, ioterm, st); + hp += 2; + } + } + DESTROY_ESTACK(stack); + if (bytes != NULL) + erts_free(ERTS_ALC_T_TMP, bytes); + return ioterm; +} + +static void adler32_wrap(void *vsum, unsigned char *buf, unsigned buflen) +{ + unsigned long sum = *((unsigned long *) vsum); + sum = adler32(sum,buf,buflen); + *((unsigned long *) vsum) = sum; +} + +static void crc32_wrap(void *vsum, unsigned char *buf, unsigned buflen) +{ + unsigned long sum = *((unsigned long *) vsum); + sum = crc32(sum,buf,buflen); + *((unsigned long *) vsum) = sum; +} + +static void md5_wrap(void *vsum, unsigned char *buf, unsigned buflen) +{ + MD5_CTX *ctx = ((MD5_CTX *) vsum); + MD5Update(ctx,buf,buflen); +} + +#define BYTES_PER_REDUCTION 10 +#define CHUNK_PER_SCHEDULE (BYTES_PER_REDUCTION * CONTEXT_REDS) + +BIF_RETTYPE +crc32_1(BIF_ALIST_1) +{ + unsigned long chksum; + int res, err; + Eterm rest,res_sum; + chksum = crc32(0,NULL,0); + + rest = do_chksum(&crc32_wrap,BIF_P,BIF_ARG_1,CHUNK_PER_SCHEDULE, + (void *) &chksum,&res, + &err); + BUMP_REDS(BIF_P,res / BYTES_PER_REDUCTION); + if (err != 0) { + BIF_ERROR(BIF_P, BADARG); + } + res_sum = erts_make_integer(chksum,BIF_P); + if (rest != NIL) { + BUMP_ALL_REDS(BIF_P); + BIF_TRAP2(bif_export[BIF_crc32_2], BIF_P, res_sum, rest); + } + BIF_RET(res_sum); +} + +BIF_RETTYPE +crc32_2(BIF_ALIST_2) +{ + unsigned long chksum; + int res, err; + Eterm rest,res_sum; + Uint u; + if (!term_to_Uint(BIF_ARG_1, &u) || ((u >> 16) >> 16) != 0) { + BIF_ERROR(BIF_P, BADARG); + } + chksum = (unsigned long) u; + + rest = do_chksum(&crc32_wrap,BIF_P,BIF_ARG_2,CHUNK_PER_SCHEDULE, + (void *) &chksum,&res, + &err); + BUMP_REDS(BIF_P,res / BYTES_PER_REDUCTION); + if (err != 0) { + BIF_ERROR(BIF_P, BADARG); + } + res_sum = erts_make_integer(chksum,BIF_P); + if (rest != NIL) { + BUMP_ALL_REDS(BIF_P); + BIF_TRAP2(bif_export[BIF_crc32_2], BIF_P, res_sum, rest); + } + BIF_RET(res_sum); +} + +BIF_RETTYPE +crc32_combine_3(BIF_ALIST_3) +{ + unsigned long chksum1,chksum2; + z_off_t length; + Uint32 res; + Eterm res_sum; + Uint u; + + if (!term_to_Uint(BIF_ARG_1, &u) || ((u >> 16) >> 16) != 0) { + BIF_ERROR(BIF_P, BADARG); + } + chksum1 = (unsigned long) u; + + if (!term_to_Uint(BIF_ARG_2, &u) || ((u >> 16) >> 16) != 0) { + BIF_ERROR(BIF_P, BADARG); + } + chksum2 = (unsigned long) u; + + if (!term_to_Uint(BIF_ARG_3, &u) || ((u >> 16) >> 16) != 0) { + BIF_ERROR(BIF_P, BADARG); + } + length = (z_off_t) u; + + res = (Uint32) crc32_combine(chksum1,chksum2,length); + + res_sum = erts_make_integer(res,BIF_P); + BIF_RET(res_sum); +} + +BIF_RETTYPE +adler32_1(BIF_ALIST_1) +{ + unsigned long chksum; + int res, err; + Eterm rest,res_sum; + chksum = adler32(0,NULL,0); + + rest = do_chksum(&adler32_wrap,BIF_P,BIF_ARG_1,CHUNK_PER_SCHEDULE, + (void *) &chksum,&res, + &err); + BUMP_REDS(BIF_P,res / BYTES_PER_REDUCTION); + if (err != 0) { + BIF_ERROR(BIF_P, BADARG); + } + res_sum = erts_make_integer(chksum,BIF_P); + if (rest != NIL) { + BUMP_ALL_REDS(BIF_P); + BIF_TRAP2(bif_export[BIF_adler32_2], BIF_P, res_sum, rest); + } + BIF_RET(res_sum); +} + +BIF_RETTYPE +adler32_2(BIF_ALIST_2) +{ + unsigned long chksum; + int res, err; + Eterm rest,res_sum; + Uint u; + if (!term_to_Uint(BIF_ARG_1, &u) || ((u >> 16) >> 16) != 0) { + BIF_ERROR(BIF_P, BADARG); + } + chksum = (unsigned long) u; + + rest = do_chksum(&adler32_wrap,BIF_P,BIF_ARG_2,CHUNK_PER_SCHEDULE, + (void *) &chksum,&res, + &err); + BUMP_REDS(BIF_P,res / BYTES_PER_REDUCTION); + if (err != 0) { + BIF_ERROR(BIF_P, BADARG); + } + res_sum = erts_make_integer(chksum,BIF_P); + if (rest != NIL) { + BUMP_ALL_REDS(BIF_P); + BIF_TRAP2(bif_export[BIF_adler32_2], BIF_P, res_sum, rest); + } + BIF_RET(res_sum); +} + +BIF_RETTYPE +adler32_combine_3(BIF_ALIST_3) +{ + unsigned long chksum1,chksum2; + z_off_t length; + Uint32 res; + Eterm res_sum; + Uint u; + + if (!term_to_Uint(BIF_ARG_1, &u) || ((u >> 16) >> 16) != 0) { + BIF_ERROR(BIF_P, BADARG); + } + chksum1 = (unsigned long) u; + + if (!term_to_Uint(BIF_ARG_2, &u) || ((u >> 16) >> 16) != 0) { + BIF_ERROR(BIF_P, BADARG); + } + chksum2 = (unsigned long) u; + + if (!term_to_Uint(BIF_ARG_3, &u) || ((u >> 16) >> 16) != 0) { + BIF_ERROR(BIF_P, BADARG); + } + length = (z_off_t) u; + + if (length == 0) { /* Workaround for unexpected behaviour in zlib. */ + res = (Uint32) chksum1; + } else { + res = (Uint32) adler32_combine(chksum1,chksum2,length); + } + + res_sum = erts_make_integer(res,BIF_P); + BIF_RET(res_sum); +} + + +BIF_RETTYPE +md5_1(BIF_ALIST_1) +{ + Eterm bin; + byte* bytes; + Eterm rest; + int res, err; + + MD5_CTX context; + MD5Init(&context); + + rest = do_chksum(&md5_wrap,BIF_P,BIF_ARG_1,100,(void *) &context,&res, + &err); + if (err != 0) { + BUMP_REDS(BIF_P,res); + BIF_ERROR(BIF_P, BADARG); + } + if (rest != NIL) { + BUMP_ALL_REDS(BIF_P); + bin = new_binary(BIF_P, (byte *) &context, sizeof(MD5_CTX)); + BIF_TRAP2(&chksum_md5_2_exp, BIF_P, bin, rest); + } + BUMP_REDS(BIF_P,res); + bin = new_binary(BIF_P, (byte *)NULL, 16); + bytes = binary_bytes(bin); + MD5Final(bytes, &context); + BIF_RET(bin); +} + +/* Hidden trap target */ +static BIF_RETTYPE +md5_2(BIF_ALIST_2) +{ + byte *bytes; + MD5_CTX context; + Eterm rest; + Eterm bin; + int res, err; + + /* No need to check context, this function cannot be called with unaligned + or badly sized context as it's always trapped to. */ + bytes = binary_bytes(BIF_ARG_1); + memcpy(&context,bytes,sizeof(MD5_CTX)); + rest = do_chksum(&md5_wrap,BIF_P,BIF_ARG_2,100,(void *) &context,&res, + &err); + if (err != 0) { + BUMP_REDS(BIF_P,res); + BIF_ERROR(BIF_P, BADARG); + } + if (rest != NIL) { + BUMP_ALL_REDS(BIF_P); + bin = new_binary(BIF_P, (byte *) &context, sizeof(MD5_CTX)); + BIF_TRAP2(&chksum_md5_2_exp, BIF_P, bin, rest); + } + BUMP_REDS(BIF_P,res); + bin = new_binary(BIF_P, (byte *)NULL, 16); + bytes = binary_bytes(bin); + MD5Final(bytes, &context); + BIF_RET(bin); +} + +BIF_RETTYPE +md5_init_0(BIF_ALIST_0) +{ + Eterm bin; + byte* bytes; + + bin = erts_new_heap_binary(BIF_P, (byte *)NULL, sizeof(MD5_CTX), &bytes); + MD5Init((MD5_CTX *)bytes); + BIF_RET(bin); +} + +BIF_RETTYPE +md5_update_2(BIF_ALIST_2) +{ + byte *bytes; + MD5_CTX context; + Eterm rest; + Eterm bin; + int res, err; + byte *temp_alloc = NULL; + + if ((bytes = erts_get_aligned_binary_bytes(BIF_ARG_1, &temp_alloc)) == NULL) { + erts_free_aligned_binary_bytes(temp_alloc); + BIF_ERROR(BIF_P, BADARG); + } + if (binary_size(BIF_ARG_1) != sizeof(MD5_CTX)) { + erts_free_aligned_binary_bytes(temp_alloc); + BIF_ERROR(BIF_P, BADARG); + } + memcpy(&context,bytes,sizeof(MD5_CTX)); + erts_free_aligned_binary_bytes(temp_alloc); + rest = do_chksum(&md5_wrap,BIF_P,BIF_ARG_2,100,(void *) &context,&res, + &err); + if (err != 0) { + BUMP_REDS(BIF_P,res); + BIF_ERROR(BIF_P, BADARG); + } + bin = new_binary(BIF_P, (byte *) &context, sizeof(MD5_CTX)); + if (rest != NIL) { + BUMP_ALL_REDS(BIF_P); + BIF_TRAP2(bif_export[BIF_md5_update_2], BIF_P, bin, rest); + } + BUMP_REDS(BIF_P,res); + BIF_RET(bin); +} + +BIF_RETTYPE +md5_final_1(BIF_ALIST_1) +{ + Eterm bin; + byte* context; + byte* result; + MD5_CTX ctx_copy; + byte* temp_alloc = NULL; + + if ((context = erts_get_aligned_binary_bytes(BIF_ARG_1, &temp_alloc)) == NULL) { + error: + erts_free_aligned_binary_bytes(temp_alloc); + BIF_ERROR(BIF_P, BADARG); + } + if (binary_size(BIF_ARG_1) != sizeof(MD5_CTX)) { + goto error; + } + bin = erts_new_heap_binary(BIF_P, (byte *)NULL, 16, &result); + memcpy(&ctx_copy, context, sizeof(MD5_CTX)); + erts_free_aligned_binary_bytes(temp_alloc); + MD5Final(result, &ctx_copy); + BIF_RET(bin); +} diff --git a/erts/emulator/beam/erl_bif_ddll.c b/erts/emulator/beam/erl_bif_ddll.c new file mode 100644 index 0000000000..9d5f0d9c02 --- /dev/null +++ b/erts/emulator/beam/erl_bif_ddll.c @@ -0,0 +1,1964 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2006-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* + * BIFs belonging to the 'erl_ddll' module together with utility + * functions for dynamic loading. The actual loading is done in + * erl_sys_ddll.c in respective system dependent directory. The + * driver structure contains a handle to the actual loaded "module" as + * well as record keeping information about processes having loaded + * the driver and processes monitoring the driver. A process in any + * way involved in ddll-drivers, get a special flag, which triggers + * cleenup at process exit. + */ + + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#define ERL_SYS_DRV + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "erl_process.h" +#include "error.h" +#include "erl_driver.h" +#include "bif.h" +#include "big.h" +#include "dist.h" +#include "erl_version.h" + +#ifdef ERTS_SMP +#define DDLL_SMP 1 +#else +#define DDLL_SMP 0 +#endif + + +/* + * Local types + */ + +typedef struct { + Eterm pid; + Process *proc; + Uint status; + Uint count; +} ProcEntryInfo; + +/* + * Forward + */ +static char *pick_list_or_atom(Eterm name_term); +static erts_driver_t *lookup_driver(char *name); +static Eterm mkatom(char *str); +static void add_proc_loaded(DE_Handle *dh, Process *proc); +static void add_proc_loaded_deref(DE_Handle *dh, Process *proc); +static void set_driver_reloading(DE_Handle *dh, Process *proc, char *path, char *name, Uint flags); +static int load_driver_entry(DE_Handle **dhp, char *path, char *name); +static int do_unload_driver_entry(DE_Handle *dh, Eterm *save_name); +static int do_load_driver_entry(DE_Handle *dh, char *path, char *name); +#if 0 +static void unload_driver_entry(DE_Handle *dh); +#endif +static int reload_driver_entry(DE_Handle *dh); +static int build_proc_info(DE_Handle *dh, ProcEntryInfo **out_pei, Uint filter); +static int is_last_user(DE_Handle *dh, Process *proc); +static DE_ProcEntry *find_proc_entry(DE_Handle *dh, Process *proc, Uint status); +static void remove_proc_entry(DE_Handle *dh, DE_ProcEntry *pe); +static int num_procs(DE_Handle *dh, Uint status); +/*static int num_entries(DE_Handle *dh, Process *proc, Uint status);*/ +static void notify_proc(Process *proc, Eterm ref, Eterm driver_name, + Eterm type, Eterm tag, int errcode); +static void notify_all(DE_Handle *dh, char *name, Uint awaiting, Eterm type, Eterm tag); +static int load_error_need(int code); +static Eterm build_load_error_hp(Eterm *hp, int code); +static Eterm build_load_error(Process *p, int code); +static int errdesc_to_code(Eterm errdesc, int *code /* out */); +static Eterm add_monitor(Process *p, DE_Handle *dh, Uint status); +static Eterm notify_when_loaded(Process *p, Eterm name_term, char *name, + ErtsProcLocks plocks); +static Eterm notify_when_unloaded(Process *p, Eterm name_term, char *name, + ErtsProcLocks plocks, Uint flag); +static void first_ddll_reference(DE_Handle *dh); +static void dereference_all_processes(DE_Handle *dh); +static void restore_process_references(DE_Handle *dh); +static void ddll_no_more_references(void *vdh); + +#define lock_drv_list() erts_smp_mtx_lock(&erts_driver_list_lock) +#define unlock_drv_list() erts_smp_mtx_unlock(&erts_driver_list_lock) +#define assert_drv_list_locked() \ + ERTS_SMP_LC_ASSERT(erts_smp_lc_mtx_is_locked(&erts_driver_list_lock)) +#define assert_drv_list_not_locked() \ + ERTS_SMP_LC_ASSERT(!erts_smp_lc_mtx_is_locked(&erts_driver_list_lock)) + + +#define FREE_PORT_FLAGS (ERTS_PORT_SFLGS_DEAD & (~ERTS_PORT_SFLG_INITIALIZING)) + +/* + * try_load(Path, Name, OptionList) -> {ok,Status} | + * {ok, PendingStatus, Ref} | + * {error, ErrorDesc} + * Path = Name = string() | atom() + * OptionList = [ Option ] + * Option = {driver_options, DriverOptionList} | + * {monitor,MonitorOption} | + * {reload, ReloadOption} + * DriverOptionList = [ DriverOption ] + * DriverOption = kill_ports + * MonitorOption = pending_driver | pending + * ReloadOption = pending_driver | pending + * Status = loaded | already_loaded | PendingStatus + * PendingStatus = pending_driver | pending_process + * Ref = ref() + * ErrorDesc = ErrorAtom | OpaqueError + * ErrorAtom = linked_in_driver | inconsistent | + * permanent | pending + */ +/* + * Try to load. If the driver is OK, add as LOADED. If the driver is + * UNLOAD, possibly change to reload and add as LOADED, + * there should be no other + * LOADED tagged pid's. If the driver is RELOAD then add/increment as + * LOADED (should be some LOADED pid). If the driver is not present, + * really load and add as LOADED {ok,loaded} {ok,pending_driver} + * {error, permanent} {error,load_error()} + */ +BIF_RETTYPE erl_ddll_try_load_3(Process *p, Eterm path_term, + Eterm name_term, Eterm options) +{ + char *path = NULL; + int path_len; + char *name = NULL; + DE_Handle *dh; + erts_driver_t *drv; + int res; + Eterm soft_error_term = NIL; + Eterm ok_term = NIL; + Eterm *hp; + Eterm t; + int monitor = 0; + int reload = 0; + Eterm l; + Uint flags = 0; + int kill_ports = 0; + int do_build_load_error = 0; + int build_this_load_error = 0; + + for(l = options; is_list(l); l = CDR(list_val(l))) { + Eterm opt = CAR(list_val(l)); + Eterm *tp; + if (is_not_tuple(opt)) { + goto error; + } + tp = tuple_val(opt); + if (*tp != make_arityval(2) || is_not_atom(tp[1])) { + goto error; + } + switch (tp[1]) { + case am_driver_options: + { + Eterm ll; + for(ll = tp[2]; is_list(ll); ll = CDR(list_val(ll))) { + Eterm dopt = CAR(list_val(ll)); + if (dopt == am_kill_ports) { + flags |= ERL_DE_FL_KILL_PORTS; + } else { + goto error; + } + } + if (is_not_nil(ll)) { + goto error; + } + } + break; + case am_monitor: + if (tp[2] == am_pending_driver) { + monitor = 1; + } else if (tp[2] == am_pending ) { + monitor = 2; + } else { + goto error; + } + break; + case am_reload: + if (tp[2] == am_pending_driver) { + reload = 1; + } else if (tp[2] == am_pending ) { + reload = 2; + } else { + goto error; + } + break; + default: + goto error; + } + } + if (is_not_nil(l)) { + goto error; + } + + + if ((name = pick_list_or_atom(name_term)) == NULL) { + goto error; + } + + path_len = io_list_len(path_term); + + if (path_len <= 0) { + goto error; + } + path = erts_alloc(ERTS_ALC_T_DDLL_TMP_BUF, path_len + 1 /* might need path separator */ + sys_strlen(name) + 1); + if (io_list_to_buf(path_term, path, path_len) != 0) { + goto error; + } + while (path_len > 0 && (path[path_len-1] == '\\' || path[path_len-1] == '/')) { + --path_len; + } + path[path_len++] = '/'; + /*path[path_len] = '\0';*/ + sys_strcpy(path+path_len,name); + +#if DDLL_SMP + erts_smp_proc_unlock(p, ERTS_PROC_LOCK_MAIN); + lock_drv_list(); +#endif + if ((drv = lookup_driver(name)) != NULL) { + if (drv->handle == NULL) { + /* static_driver */ + soft_error_term = am_linked_in_driver; + goto soft_error; + } else { + dh = drv->handle; + if (dh->status == ERL_DE_OK) { + int is_last = is_last_user(dh,p); + if (reload == 1 && !is_last) { + /*Want reload if no other users, + but there are others...*/ + soft_error_term = am_pending_process; + goto soft_error; + } + if (reload != 0) { + DE_ProcEntry *old; + if ((dh->flags & ERL_FL_CONSISTENT_MASK) != + (flags & ERL_FL_CONSISTENT_MASK)) { + soft_error_term = am_inconsistent; + goto soft_error; + } + if ((old = find_proc_entry(dh, p, ERL_DE_PROC_LOADED)) == + NULL) { + soft_error_term = am_not_loaded_by_this_process; + goto soft_error; + } else { + remove_proc_entry(dh, old); + erts_ddll_dereference_driver(dh); + erts_free(ERTS_ALC_T_DDLL_PROCESS, old); + } + /* Reload requested and granted */ + dereference_all_processes(dh); + set_driver_reloading(dh, p, path, name, flags); + if (dh->flags & ERL_DE_FL_KILL_PORTS) { + kill_ports = 1; + } + ok_term = (reload == 1) ? am_pending_driver : + am_pending_process; + } else { + /* Already loaded and healthy (might be by me) */ + if (sys_strcmp(dh->full_path, path) || + (dh->flags & ERL_FL_CONSISTENT_MASK) != + (flags & ERL_FL_CONSISTENT_MASK)) { + soft_error_term = am_inconsistent; + goto soft_error; + } + add_proc_loaded(dh,p); + erts_ddll_reference_driver(dh); + monitor = 0; + ok_term = mkatom("already_loaded"); + } + } else if (dh->status == ERL_DE_UNLOAD || + dh->status == ERL_DE_FORCE_UNLOAD) { + /* pending driver */ + if (reload != 0) { + soft_error_term = am_not_loaded_by_this_process; + goto soft_error; + } + if (sys_strcmp(dh->full_path, path) || + (dh->flags & ERL_FL_CONSISTENT_MASK) != + (flags & ERL_FL_CONSISTENT_MASK)) { + soft_error_term = am_inconsistent; + goto soft_error; + } + dh->status = ERL_DE_OK; + notify_all(dh, drv->name, + ERL_DE_PROC_AWAIT_UNLOAD, am_UP, + am_unload_cancelled); + add_proc_loaded(dh,p); + erts_ddll_reference_driver(dh); + monitor = 0; + ok_term = mkatom("already_loaded"); + } else if (dh->status == ERL_DE_RELOAD || + dh->status == ERL_DE_FORCE_RELOAD) { + if (reload != 0) { + soft_error_term = am_pending_reload; + goto soft_error; + } + if (sys_strcmp(dh->reload_full_path, path) || + (dh->reload_flags & ERL_FL_CONSISTENT_MASK) != + (flags & ERL_FL_CONSISTENT_MASK)) { + soft_error_term = am_inconsistent; + goto soft_error; + } + /* Load of granted unload... */ + add_proc_loaded_deref(dh,p); /* Dont reference, will happen after reload */ + ++monitor; + ok_term = am_pending_driver; + } else { /* ERL_DE_PERMANENT */ + soft_error_term = am_permanent; + goto soft_error; + } + } + } else { /* driver non-existing */ + if (reload != 0) { + soft_error_term = am_not_loaded; + goto soft_error; + } + if ((res = load_driver_entry(&dh, path, name)) != ERL_DE_NO_ERROR) { + build_this_load_error = res; + do_build_load_error = 1; + soft_error_term = am_undefined; + goto soft_error; + } else { + dh->flags = flags; + add_proc_loaded(dh,p); + first_ddll_reference(dh); + monitor = 0; + ok_term = mkatom("loaded"); + } + } + assert_drv_list_locked(); + if (kill_ports) { + int j; + /* Avoid closing the driver by referencing it */ + erts_ddll_reference_driver(dh); + ASSERT(dh->status == ERL_DE_RELOAD); + dh->status = ERL_DE_FORCE_RELOAD; +#if DDLL_SMP + unlock_drv_list(); +#endif + for (j = 0; j < erts_max_ports; j++) { + Port* prt = &erts_port[j]; +#ifdef DDLL_SMP + erts_smp_port_state_lock(prt); +#endif + if (!(prt->status & FREE_PORT_FLAGS) && + prt->drv_ptr->handle == dh) { +#if DDLL_SMP + erts_smp_atomic_inc(&prt->refc); + /* Extremely rare spinlock */ + while(prt->status & ERTS_PORT_SFLG_INITIALIZING) { + erts_smp_port_state_unlock(prt); + erts_smp_port_state_lock(prt); + } + erts_smp_port_state_unlock(prt); + erts_smp_mtx_lock(prt->lock); + if (!(prt->status & ERTS_PORT_SFLGS_DEAD)) { + driver_failure_atom(j, "driver_unloaded"); + } +#else + driver_failure_atom(j, "driver_unloaded"); +#endif + erts_port_release(prt); + } + else erts_smp_port_state_unlock(prt); + } + /* Dereference, eventually causing driver destruction */ +#if DDLL_SMP + lock_drv_list(); +#endif + erts_ddll_dereference_driver(dh); + } + +#if DDLL_SMP + erts_ddll_reference_driver(dh); + unlock_drv_list(); + erts_smp_proc_lock(p, ERTS_PROC_LOCK_MAIN); + lock_drv_list(); + erts_ddll_dereference_driver(dh); +#endif + + p->flags |= F_USING_DDLL; + if (monitor) { + Eterm mref = add_monitor(p, dh, ERL_DE_PROC_AWAIT_LOAD); + hp = HAlloc(p,4); + t = TUPLE3(hp, am_ok, ok_term, mref); + } else { + hp = HAlloc(p,3); + t = TUPLE2(hp, am_ok, ok_term); + } +#if DDLL_SMP + unlock_drv_list(); +#endif + erts_free(ERTS_ALC_T_DDLL_TMP_BUF, (void *) path); + erts_free(ERTS_ALC_T_DDLL_TMP_BUF, (void *) name); + ERTS_SMP_LC_ASSERT(ERTS_PROC_LOCK_MAIN & erts_proc_lc_my_proc_locks(p)); + BIF_RET(t); + soft_error: +#if DDLL_SMP + unlock_drv_list(); + erts_smp_proc_lock(p, ERTS_PROC_LOCK_MAIN); +#endif + if (do_build_load_error) { + soft_error_term = build_load_error(p, build_this_load_error); + } + + hp = HAlloc(p,3); + t = TUPLE2(hp, am_error, soft_error_term); + erts_free(ERTS_ALC_T_DDLL_TMP_BUF, (void *) path); + erts_free(ERTS_ALC_T_DDLL_TMP_BUF, (void *) name); + ERTS_SMP_LC_ASSERT(ERTS_PROC_LOCK_MAIN & erts_proc_lc_my_proc_locks(p)); + BIF_RET(t); + error: + assert_drv_list_not_locked(); + ERTS_SMP_LC_ASSERT(ERTS_PROC_LOCK_MAIN & erts_proc_lc_my_proc_locks(p)); + if (path != NULL) { + erts_free(ERTS_ALC_T_DDLL_TMP_BUF, (void *) path); + } + if (name != NULL) { + erts_free(ERTS_ALC_T_DDLL_TMP_BUF, (void *) name); + } + BIF_ERROR(p,BADARG); +} + +/* + * try_unload(Name, OptionList) -> {ok,Status} | + * {ok,PendingStatus, Ref} | + * {error, ErrorAtom} + * Name = string() | atom() + * OptionList = [ Option ] + * Option = {monitor,MonitorOption} | kill_ports + * MonitorOption = pending_driver | pending + * Status = unloaded | PendingStatus + * PendingStatus = pending_driver | pending_process + * Ref = ref() + * ErrorAtom = linked_in_driver | not_loaded | + * not_loaded_by_this_process | permanent + */ + +/* + You have to have loaded the driver and the pid state + is LOADED or AWAIT_LOAD. You will be removed from the list + regardless of driver state. + If the driver is loaded by someone else to, return is + {ok, pending_process} + If the driver is loaded but locked by a port, return is + {ok, pending_driver} + If the driver is loaded and free to unload (you're the last holding it) + {ok, unloaded} + If it's not loaded or not loaded by you + {error, not_loaded} or {error, not_loaded_by_you} + + Internally, if its in state UNLOADING, just return {ok, pending_driver} and + remove/decrement this pid (which should be an LOADED tagged one). + If the state is RELOADING, this pid should be in list as LOADED tagged, + only AWAIT_LOAD would be possible but not allowed for unloading, remove it + and, if the last LOADED tagged, change from RELOAD to UNLOAD and notify + any AWAIT_LOAD-waiters with {'DOWN', ref(), driver, name(), load_cancelled} + If the driver made itself permanent, {'UP', ref(), driver, name(), permanent} +*/ +Eterm erl_ddll_try_unload_2(Process *p, Eterm name_term, Eterm options) +{ + char *name = NULL; + Eterm ok_term = NIL; + Eterm soft_error_term = NIL; + erts_driver_t *drv; + DE_Handle *dh; + DE_ProcEntry *pe; + Eterm *hp; + Eterm t; + int monitor = 0; + Eterm l; + int kill_ports = 0; + + erts_smp_proc_unlock(p, ERTS_PROC_LOCK_MAIN); + + for(l = options; is_list(l); l = CDR(list_val(l))) { + Eterm opt = CAR(list_val(l)); + Eterm *tp; + if (is_not_tuple(opt)) { + if (opt == am_kill_ports) { + kill_ports = 1; + continue; + } else { + goto error; + } + } + tp = tuple_val(opt); + if (*tp != make_arityval(2) || tp[1] != am_monitor) { + goto error; + } + if (tp[2] == am_pending_driver) { + monitor = 1; + } else if (tp[2] == am_pending) { + monitor = 2; + } else { + goto error; + } + } + if (is_not_nil(l)) { + goto error; + } + + if ((name = pick_list_or_atom(name_term)) == NULL) { + goto error; + } + +#if DDLL_SMP + lock_drv_list(); +#endif + + if ((drv = lookup_driver(name)) == NULL) { + soft_error_term = am_not_loaded; + goto soft_error; + } + + if (drv->handle == NULL) { + soft_error_term = am_linked_in_driver; + goto soft_error; + } else if (drv->handle->status == ERL_DE_PERMANENT) { + soft_error_term = am_permanent; + goto soft_error; + } + dh = drv->handle; + if (dh->flags & ERL_DE_FL_KILL_PORTS) { + kill_ports = 1; + } + if ((pe = find_proc_entry(dh, p, ERL_DE_PROC_LOADED)) == NULL) { + if (num_procs(dh, ERL_DE_PROC_LOADED) > 0) { + soft_error_term = am_not_loaded_by_this_process; + goto soft_error; + } + } else { + remove_proc_entry(dh, pe); + if (!(pe->flags & ERL_DE_FL_DEREFERENCED)) { + erts_ddll_dereference_driver(dh); + } + erts_free(ERTS_ALC_T_DDLL_PROCESS, pe); + } + if (num_procs(dh, ERL_DE_PROC_LOADED) > 0) { + ok_term = am_pending_process; + --monitor; + goto done; + } + if (dh->status == ERL_DE_RELOAD || + dh->status == ERL_DE_FORCE_RELOAD) { + notify_all(dh, drv->name, + ERL_DE_PROC_AWAIT_LOAD, am_DOWN, am_load_cancelled); + erts_free(ERTS_ALC_T_DDLL_HANDLE,dh->reload_full_path); + erts_free(ERTS_ALC_T_DDLL_HANDLE,dh->reload_driver_name); + dh->reload_full_path = dh->reload_driver_name = NULL; + dh->reload_flags = 0; + } + if (dh->port_count > 0) { + ++kill_ports; + } + dh->status = ERL_DE_UNLOAD; + ok_term = am_pending_driver; +done: + assert_drv_list_locked(); + if (kill_ports > 1) { + int j; + /* Avoid closing the driver by referencing it */ + erts_ddll_reference_driver(dh); + dh->status = ERL_DE_FORCE_UNLOAD; +#if DDLL_SMP + unlock_drv_list(); +#endif + for (j = 0; j < erts_max_ports; j++) { + Port* prt = &erts_port[j]; +#if DDLL_SMP + erts_smp_port_state_lock(prt); +#endif + if (!(prt->status & FREE_PORT_FLAGS) + && prt->drv_ptr->handle == dh) { +#if DDLL_SMP + erts_smp_atomic_inc(&prt->refc); + /* Extremely rare spinlock */ + while(prt->status & ERTS_PORT_SFLG_INITIALIZING) { + erts_smp_port_state_unlock(prt); + erts_smp_port_state_lock(prt); + } + erts_smp_port_state_unlock(prt); + erts_smp_mtx_lock(prt->lock); + if (!(prt->status & ERTS_PORT_SFLGS_DEAD)) { + driver_failure_atom(j, "driver_unloaded"); + } +#else + driver_failure_atom(j, "driver_unloaded"); +#endif + erts_port_release(prt); + } + else erts_smp_port_state_unlock(prt); + } +#if DDLL_SMP + lock_drv_list(); +#endif + erts_ddll_dereference_driver(dh); + } + +#if DDLL_SMP + erts_ddll_reference_driver(dh); + unlock_drv_list(); + erts_smp_proc_lock(p, ERTS_PROC_LOCK_MAIN); + lock_drv_list(); + erts_ddll_dereference_driver(dh); +#endif + erts_free(ERTS_ALC_T_DDLL_TMP_BUF, (void *) name); + p->flags |= F_USING_DDLL; + if (monitor > 0) { + Eterm mref = add_monitor(p, dh, ERL_DE_PROC_AWAIT_UNLOAD); + hp = HAlloc(p,4); + t = TUPLE3(hp, am_ok, ok_term, mref); + } else { + hp = HAlloc(p,3); + t = TUPLE2(hp, am_ok, ok_term); + } + if (kill_ports > 1) { + ERTS_BIF_CHK_EXITED(p); /* May be exited by port killing */ + } +#if DDLL_SMP + unlock_drv_list(); +#endif + BIF_RET(t); + +soft_error: +#if DDLL_SMP + unlock_drv_list(); +#endif + erts_free(ERTS_ALC_T_DDLL_TMP_BUF, (void *) name); + erts_smp_proc_lock(p, ERTS_PROC_LOCK_MAIN); + hp = HAlloc(p,3); + t = TUPLE2(hp, am_error, soft_error_term); + BIF_RET(t); + + error: /* No lock fiddling before going here */ + assert_drv_list_not_locked(); + if (name != NULL) { + erts_free(ERTS_ALC_T_DDLL_TMP_BUF, (void *) name); + } + erts_smp_proc_lock(p, ERTS_PROC_LOCK_MAIN); + BIF_ERROR(p,BADARG); +} + + +/* + * A shadow of the "real" demonitor BIF + */ +BIF_RETTYPE erl_ddll_demonitor_1(Process *p, Eterm ref) +{ + if (is_not_internal_ref(ref)) { + BIF_ERROR(p, BADARG); + } + if (p->flags & F_USING_DDLL) { + erts_ddll_remove_monitor(p, ref, ERTS_PROC_LOCK_MAIN); + } + BIF_RET(am_true); +} + +/* + * A shadow of the "real" monitor BIF + */ +BIF_RETTYPE erl_ddll_monitor_2(Process *p, Eterm dr, Eterm what) +{ + if (dr != am_driver) { + BIF_ERROR(p,BADARG); + } + return erts_ddll_monitor_driver(p, what, ERTS_PROC_LOCK_MAIN); +} + +/* + * Return list of loaded drivers {ok,[string()]} + */ +Eterm erl_ddll_loaded_drivers_0(Process *p) +{ + Eterm *hp; + int need = 3; + Eterm res = NIL; + erts_driver_t *drv; +#if DDLL_SMP + lock_drv_list(); +#endif + for (drv = driver_list; drv; drv = drv->next) { + need += sys_strlen(drv->name)*2+2; + } + hp = HAlloc(p,need); + for (drv = driver_list; drv; drv = drv->next) { + Eterm l; + l = buf_to_intlist(&hp, drv->name, sys_strlen(drv->name), NIL); + res = CONS(hp,l,res); + hp += 2; + } + res = TUPLE2(hp,am_ok,res); + /* hp += 3 */ +#if DDLL_SMP + unlock_drv_list(); +#endif + BIF_RET(res); +} + +/* + * More detailed info about loaded drivers: + * item is processes, driver_options, port_count, linked_in_driver, + * permanent, awaiting_load, awaiting_unload + */ +Eterm erl_ddll_info_2(Process *p, Eterm name_term, Eterm item) +{ + char *name = NULL; + Eterm res = NIL; + erts_driver_t *drv; + ProcEntryInfo *pei = NULL; + int num_pei; + Eterm *hp; + int i; + Uint filter; +#if DDLL_SMP + int have_lock = 0; +#endif + + if ((name = pick_list_or_atom(name_term)) == NULL) { + goto error; + } + + if (!is_atom(item)) { + goto error; + } + +#if DDLL_SMP + lock_drv_list(); + have_lock = 1; +#endif + if ((drv = lookup_driver(name)) == NULL) { + goto error; + } + + switch (item) { + case am_processes: + filter = ERL_DE_PROC_LOADED; + break; + case am_driver_options: + if (drv->handle == NULL) { + res = am_linked_in_driver; + } else { + Uint start_flags = drv->handle->flags & ERL_FL_CONSISTENT_MASK; + /* Cheating, only one flag for now... */ + if (start_flags & ERL_DE_FL_KILL_PORTS) { + Eterm *myhp; + myhp = HAlloc(p,2); + res = CONS(myhp,am_kill_ports,NIL); + } else { + res = NIL; + } + } + goto done; + case am_port_count: + if (drv->handle == NULL) { + res = am_linked_in_driver; + } else if (drv->handle->status == ERL_DE_PERMANENT) { + res = am_permanent; + } else { + res = make_small(drv->handle->port_count); + } + goto done; + case am_linked_in_driver: + if (drv->handle == NULL){ + res = am_true; + } else { + res = am_false; + } + goto done; + case am_permanent: + if (drv->handle != NULL && drv->handle->status == ERL_DE_PERMANENT) { + res = am_true; + } else { + res = am_false; + } + goto done; + case am_awaiting_load: + filter = ERL_DE_PROC_AWAIT_LOAD; + break; + case am_awaiting_unload: + filter = ERL_DE_PROC_AWAIT_UNLOAD; + break; + default: + goto error; + } + + if (drv->handle == NULL) { + res = am_linked_in_driver; + goto done; + } else if (drv->handle->status == ERL_DE_PERMANENT) { + res = am_permanent; + goto done; + } + num_pei = build_proc_info(drv->handle, &pei, filter); + if (!num_pei) { + goto done; + } + hp = HAlloc(p,num_pei * (2+3)); + for (i = 0; i < num_pei; ++ i) { + Eterm tpl = TUPLE2(hp,pei[i].pid,make_small(pei[i].count)); + hp += 3; + res = CONS(hp,tpl,res); + hp += 2; + } + done: +#if DDLL_SMP + unlock_drv_list(); +#endif + if (pei) + erts_free(ERTS_ALC_T_DDLL_TMP_BUF, pei); + erts_free(ERTS_ALC_T_DDLL_TMP_BUF, (void *) name); + BIF_RET(res); + error: + if (name != NULL) { + erts_free(ERTS_ALC_T_DDLL_TMP_BUF, (void *) name); + } +#if DDLL_SMP + if (have_lock) { + unlock_drv_list(); + } +#endif + BIF_ERROR(p,BADARG); +} + +/* + * Backend for erl_ddll:format_error, handles all "soft" errors returned by builtins, + * possibly by calling the system specific error handler + */ +Eterm erl_ddll_format_error_int_1(Process *p, Eterm code_term) +{ + char *errstring = NULL; + int errint; + int len; + Eterm ret = NIL; + Eterm *hp; + + /* These errors can only appear in the erlang interface, not in the interface provided + to drivers... */ + switch (code_term) { + case am_inconsistent: + errstring = "Driver name and/or driver options are inconsistent with " + "currently loaded driver"; + break; + case am_linked_in_driver: + errstring = "Driver is statically linked and " + "cannot be loaded/unloaded"; + break; + case am_permanent: + errstring = "DDLL driver is permanent an can not be unloaded/loaded"; + break; + case am_not_loaded: + errstring = "DDLL driver is not loaded"; + break; + case am_not_loaded_by_this_process: + errstring = "DDLL driver was not loaded by this process"; + break; + case am_not_pending: + errstring = "DDLL load not pending for this driver name"; + break; + case am_already_loaded: + errstring = "DDLL driver is already loaded successfully"; + break; + case am_pending_reload: + errstring = "Driver reloading is already pending"; + break; + case am_pending_process: + errstring = "Driver is loaded by others when attempting " + "option {reload, pending_driver}"; + break; + default: + /* A "real" error, we translate the atom to a code and translate the code + to a string in the same manner as in the interface provided to drivers... */ + if (errdesc_to_code(code_term,&errint) != 0) { + goto error; + } +#if DDLL_SMP + lock_drv_list(); +#endif + errstring = erts_ddll_error(errint); +#if DDLL_SMP + unlock_drv_list(); +#endif + break; + } + if (errstring == NULL) { + goto error; + } + len = sys_strlen(errstring); + hp = HAlloc(p, 2 * len); + ret = buf_to_intlist(&hp, errstring, len, NIL); + BIF_RET(ret); + error: + BIF_ERROR(p,BADARG); +} + +void erts_ddll_init(void) +{ + erl_sys_ddll_init(); +} + +/* Return value as a bif, called by erlang:monitor */ +Eterm erts_ddll_monitor_driver(Process *p, + Eterm description, + ErtsProcLocks plocks) +{ + Eterm *tp; + Eterm ret; + char *name; + + if (is_not_tuple(description)) { + BIF_ERROR(p,BADARG); + } + tp = tuple_val(description); + if (*tp != make_arityval(2)) { + BIF_ERROR(p,BADARG); + } + if ((name = pick_list_or_atom(tp[1])) == NULL) { + BIF_ERROR(p,BADARG); + } + switch (tp[2]) { + case am_loaded: + ERTS_BIF_PREP_RET(ret, notify_when_loaded(p,tp[1],name,plocks)); + break; + case am_unloaded: + ERTS_BIF_PREP_RET(ret, notify_when_unloaded(p,tp[1],name,plocks, + ERL_DE_PROC_AWAIT_UNLOAD)); + break; + case am_unloaded_only: + ERTS_BIF_PREP_RET(ret, + notify_when_unloaded(p,tp[1],name,plocks, + ERL_DE_PROC_AWAIT_UNLOAD_ONLY)); + break; + default: + ERTS_BIF_PREP_ERROR(ret,p,BADARG); + break; + } + + erts_free(ERTS_ALC_T_DDLL_TMP_BUF, (void *) name); + return ret; +} + +void erts_ddll_remove_monitor(Process *p, Eterm ref, ErtsProcLocks plocks) +{ + erts_driver_t *drv; + erts_smp_proc_unlock(p, plocks); + lock_drv_list(); + drv = driver_list; + while (drv != NULL) { + if (drv->handle != NULL && drv->handle->status != ERL_DE_PERMANENT) { + DE_ProcEntry **pe = &(drv->handle->procs); + while ((*pe) != NULL) { + if ((*pe)->proc == p && + ((*pe)->awaiting_status == ERL_DE_PROC_AWAIT_LOAD || + (*pe)->awaiting_status == ERL_DE_PROC_AWAIT_UNLOAD || + (*pe)->awaiting_status == + ERL_DE_PROC_AWAIT_UNLOAD_ONLY) && + eq(make_internal_ref(&((*pe)->heap)),ref)) { + DE_ProcEntry *r = *pe; + *pe = r->next; + erts_free(ERTS_ALC_T_DDLL_PROCESS, (void *) r); + goto done; + } + pe = &((*pe)->next); + } + } + drv = drv->next; + } + done: + unlock_drv_list(); + erts_smp_proc_lock(p, plocks); +} + +/* + * Called from erl_process.c. + */ +void erts_ddll_proc_dead(Process *p, ErtsProcLocks plocks) +{ + erts_driver_t *drv; + erts_smp_proc_unlock(p, plocks); + lock_drv_list(); + drv = driver_list; + while (drv != NULL) { + if (drv->handle != NULL && drv->handle->status != ERL_DE_PERMANENT) { + DE_ProcEntry **pe = &(drv->handle->procs); + int kill_ports = (drv->handle->flags & ERL_DE_FL_KILL_PORTS); + int left = 0; + while ((*pe) != NULL) { + if ((*pe)->proc == p) { + DE_ProcEntry *r = *pe; + *pe = r->next; + if (!(r->flags & ERL_DE_FL_DEREFERENCED) && + r->awaiting_status == ERL_DE_PROC_LOADED) { + erts_ddll_dereference_driver(drv->handle); + } + erts_free(ERTS_ALC_T_DDLL_PROCESS, (void *) r); + } else { + if ((*pe)->awaiting_status == ERL_DE_PROC_LOADED) { + ++left; + } + pe = &((*pe)->next); + } + } + if (!left) { + DE_Handle *dh = drv->handle; + if (dh->status == ERL_DE_RELOAD || + dh->status == ERL_DE_FORCE_RELOAD) { + notify_all(dh, drv->name, + ERL_DE_PROC_AWAIT_LOAD, am_DOWN, am_load_cancelled); + erts_free(ERTS_ALC_T_DDLL_HANDLE,dh->reload_full_path); + erts_free(ERTS_ALC_T_DDLL_HANDLE,dh->reload_driver_name); + dh->reload_full_path = dh->reload_driver_name = NULL; + dh->reload_flags = 0; + } + dh->status = ERL_DE_UNLOAD; + } + if (!left && drv->handle->port_count > 0) { + if (kill_ports) { + int j; + DE_Handle *dh = drv->handle; + erts_ddll_reference_driver(dh); + dh->status = ERL_DE_FORCE_UNLOAD; +#if DDLL_SMP + unlock_drv_list(); +#endif + for (j = 0; j < erts_max_ports; j++) { + Port* prt = &erts_port[j]; +#if DDLL_SMP + erts_smp_port_state_lock(prt); +#endif + if (!(prt->status & FREE_PORT_FLAGS) && + prt->drv_ptr->handle == dh) { +#if DDLL_SMP + erts_smp_atomic_inc(&prt->refc); + while(prt->status & ERTS_PORT_SFLG_INITIALIZING) { + erts_smp_port_state_unlock(prt); + erts_smp_port_state_lock(prt); + } + erts_smp_port_state_unlock(prt); + erts_smp_mtx_lock(prt->lock); + if (!(prt->status & ERTS_PORT_SFLGS_DEAD)) { + driver_failure_atom(j, "driver_unloaded"); + } +#else + driver_failure_atom(j, "driver_unloaded"); +#endif + erts_port_release(prt); + } + else erts_smp_port_state_unlock(prt); + } +#if DDLL_SMP + lock_drv_list(); /* Needed for future list operations */ +#endif + drv = drv->next; /* before allowing destruction */ + erts_ddll_dereference_driver(dh); + } else { + drv = drv->next; + } + } else { + drv = drv->next; + } + } else { + drv = drv->next; + } + } + unlock_drv_list(); + erts_smp_proc_lock(p, plocks); +} +void erts_ddll_lock_driver(DE_Handle *dh, char *name) +{ + DE_ProcEntry *p,*q; + assert_drv_list_locked(); + notify_all(dh, name, + ERL_DE_PROC_AWAIT_LOAD, am_UP, am_permanent); + notify_all(dh, name, + ERL_DE_PROC_AWAIT_UNLOAD, am_UP, am_permanent); + notify_all(dh, name, + ERL_DE_PROC_AWAIT_UNLOAD_ONLY, am_UP, am_permanent); + + p = dh->procs; + while(p != NULL) { + q = p; + p = p->next; + erts_free(ERTS_ALC_T_DDLL_PROCESS, (void *) q); + } + dh->procs = NULL; + erts_ddll_reference_driver(dh); + dh->status = ERL_DE_PERMANENT; +} + + +void erts_ddll_increment_port_count(DE_Handle *dh) +{ + assert_drv_list_locked(); + dh->port_count++; +} + +void erts_ddll_decrement_port_count(DE_Handle *dh) +{ + assert_drv_list_locked(); + ASSERT(dh->port_count > 0); + dh->port_count--; +} + +static void first_ddll_reference(DE_Handle *dh) +{ + assert_drv_list_locked(); + erts_refc_init(&(dh->refc),1); +} + +void erts_ddll_reference_driver(DE_Handle *dh) +{ + assert_drv_list_locked(); + if (erts_refc_inctest(&(dh->refc),1) == 1) { + erts_refc_inc(&(dh->refc),2); /* add a reference for the scheduled operation */ + } +} + +void erts_ddll_reference_referenced_driver(DE_Handle *dh) +{ + erts_refc_inc(&(dh->refc),2); +} + +void erts_ddll_dereference_driver(DE_Handle *dh) +{ + if (erts_refc_dectest(&(dh->refc),0) == 0) { + /* No lock here, but if the driver is referenced again, + the scheduled deletion is added as a reference too, see above */ + erts_schedule_misc_op(ddll_no_more_references, (void *) dh); + } +} +static void dereference_all_processes(DE_Handle *dh) +{ + DE_ProcEntry *p; + assert_drv_list_locked(); + for(p = dh->procs;p != NULL; p = p->next) { + if (p->awaiting_status == ERL_DE_PROC_LOADED) { + ASSERT(!(p->flags & ERL_DE_FL_DEREFERENCED)); + erts_ddll_dereference_driver(dh); + p->flags |= ERL_DE_FL_DEREFERENCED; + } + } +} + +static void restore_process_references(DE_Handle *dh) +{ + DE_ProcEntry *p; + assert_drv_list_locked(); + ASSERT(erts_refc_read(&(dh->refc),0) == 0); + for(p = dh->procs;p != NULL; p = p->next) { + if (p->awaiting_status == ERL_DE_PROC_LOADED) { + ASSERT(p->flags & ERL_DE_FL_DEREFERENCED); + erts_refc_inc(&(dh->refc),1); + p->flags &= ~ERL_DE_FL_DEREFERENCED; + } + } +} + + +int erts_ddll_driver_ok(DE_Handle *dh) +{ + assert_drv_list_locked(); + return ((dh == NULL) || (dh->status != ERL_DE_FORCE_UNLOAD && + dh->status != ERL_DE_FORCE_RELOAD)); +} + + +static void ddll_no_more_references(void *vdh) +{ + DE_Handle *dh = (DE_Handle *) vdh; + int x; + + lock_drv_list(); + + x = erts_refc_read(&(dh->refc),0); + if (x > 0) { + x = erts_refc_dectest(&(dh->refc),0); /* delete the reference added for me */ + } + + + if (x == 0) { + DE_ProcEntry **p = &(dh->procs); + Eterm save_driver_name = am_undefined; + ASSERT(dh->status != ERL_DE_OK); + do_unload_driver_entry(dh,&save_driver_name); + while (*p != NULL) { + DE_ProcEntry *q; + if ((*p)->awaiting_status == ERL_DE_PROC_AWAIT_UNLOAD || + (*p)->awaiting_status == ERL_DE_PROC_AWAIT_UNLOAD_ONLY) { + notify_proc((*p)->proc, + make_internal_ref(&((*p)->heap)), + save_driver_name,am_DOWN,am_unloaded, 0); + q = *p; + *p = q->next; + erts_free(ERTS_ALC_T_DDLL_PROCESS, (void *) q); + } else { + ASSERT(dh->status == ERL_DE_RELOAD || + dh->status == ERL_DE_FORCE_RELOAD); + p = &((*p)->next); + } + } + + if (dh->status == ERL_DE_UNLOAD || dh->status == ERL_DE_FORCE_UNLOAD) { + ASSERT(dh->full_path != NULL); + erts_free(ERTS_ALC_T_DDLL_HANDLE, (void *) dh->full_path); + erts_free(ERTS_ALC_T_DDLL_HANDLE, (void *) dh); + } else { /* ERL_DE_RELOAD || ERL_DE_FORCE_RELOAD */ + int reload_res = + reload_driver_entry(dh); + p = &(dh->procs); + while (*p != NULL) { + DE_ProcEntry *q; + if ((*p)->awaiting_status == ERL_DE_PROC_AWAIT_LOAD) { + if (reload_res == 0) { + notify_proc((*p)->proc, + make_internal_ref(&((*p)->heap)), + save_driver_name, am_UP, am_loaded, 0); + } else { + notify_proc((*p)->proc, + make_internal_ref(&((*p)->heap)), + save_driver_name, am_DOWN, am_load_failure, reload_res); + } + q = *p; + *p = q->next; + erts_free(ERTS_ALC_T_DDLL_PROCESS, (void *) q); + } else { + if (reload_res != 0) { + DE_ProcEntry *q = *p; + *p = q->next; + erts_free(ERTS_ALC_T_DDLL_PROCESS, (void *) q); + } else { + p = &((*p)->next); + } + } + } + if (reload_res != 0) { + ASSERT(dh->full_path == NULL); + erts_free(ERTS_ALC_T_DDLL_HANDLE, (void *) dh); + } + } + } + unlock_drv_list(); +} + +char *erts_ddll_error(int code) { + switch (code) { + case ERL_DE_NO_ERROR: + return "No error"; + case ERL_DE_LOAD_ERROR_NO_INIT: + return "No driver init in dynamic library"; + case ERL_DE_LOAD_ERROR_FAILED_INIT: + return "Driver init failed"; + case ERL_DE_LOAD_ERROR_BAD_NAME: + return "Bad driver name"; + case ERL_DE_LOAD_ERROR_NAME_TO_LONG: + return "Driver name to long"; + case ERL_DE_LOAD_ERROR_INCORRECT_VERSION: + return "Driver compiled with incorrect version of erl_driver.h"; + case ERL_DE_ERROR_NO_DDLL_FUNCTIONALITY: + return "DDLL functionality not available on this platform"; + case ERL_DE_ERROR_UNSPECIFIED: + return "Unspecified dynamic library error"; + case ERL_DE_LOOKUP_ERROR_NOT_FOUND: + return "Symbol not found in dynamic library"; + default: + return erts_sys_ddll_error(code); + } +} + +/* + * Utilities + */ +static Eterm notify_when_loaded(Process *p, Eterm name_term, char *name, ErtsProcLocks plocks) +{ + Eterm r = NIL; + Eterm immediate_tag = NIL; + Eterm immediate_type = NIL; + erts_driver_t *drv; + + ERTS_SMP_LC_ASSERT(ERTS_PROC_LOCK_MAIN & plocks); +#if DDLL_SMP + lock_drv_list(); +#endif + if ((drv = lookup_driver(name)) == NULL) { + immediate_tag = am_unloaded; + immediate_type = am_DOWN; + goto immediate; + } + if (drv->handle == NULL || drv->handle->status == ERL_DE_PERMANENT) { + immediate_tag = am_permanent; + immediate_type = am_UP; + goto immediate; + } + + switch (drv->handle->status) { + case ERL_DE_OK: + immediate_tag = am_loaded; + immediate_type = am_UP; + goto immediate; + case ERL_DE_UNLOAD: + case ERL_DE_FORCE_UNLOAD: + immediate_tag = am_load_cancelled; + immediate_type = am_DOWN; + goto immediate; + case ERL_DE_RELOAD: + case ERL_DE_FORCE_RELOAD: + break; + default: + erl_exit(1,"Internal error, unknown state %u in dynamic driver.", drv->handle->status); + } + p->flags |= F_USING_DDLL; + r = add_monitor(p, drv->handle, ERL_DE_PROC_AWAIT_LOAD); +#if DDLL_SMP + unlock_drv_list(); +#endif + BIF_RET(r); + immediate: + r = erts_make_ref(p); +#if DDLL_SMP + erts_smp_proc_unlock(p, plocks); +#endif + notify_proc(p, r, name_term, immediate_type, immediate_tag, 0); +#if DDLL_SMP + unlock_drv_list(); + erts_smp_proc_lock(p, plocks); +#endif + BIF_RET(r); +} + +static Eterm notify_when_unloaded(Process *p, Eterm name_term, char *name, ErtsProcLocks plocks, Uint flag) +{ + Eterm r = NIL; + Eterm immediate_tag = NIL; + Eterm immediate_type = NIL; + erts_driver_t *drv; + + ERTS_SMP_LC_ASSERT(ERTS_PROC_LOCK_MAIN & plocks); +#if DDLL_SMP + lock_drv_list(); +#endif + if ((drv = lookup_driver(name)) == NULL) { + immediate_tag = am_unloaded; + immediate_type = am_DOWN; + goto immediate; + } + if (drv->handle == NULL || drv->handle->status == ERL_DE_PERMANENT) { + immediate_tag = am_permanent; + immediate_type = am_UP; + goto immediate; + } + + p->flags |= F_USING_DDLL; + r = add_monitor(p, drv->handle, flag); +#if DDLL_SMP + unlock_drv_list(); +#endif + BIF_RET(r); + immediate: + r = erts_make_ref(p); +#if DDLL_SMP + erts_smp_proc_unlock(p, plocks); +#endif + notify_proc(p, r, name_term, immediate_type, immediate_tag, 0); +#if DDLL_SMP + unlock_drv_list(); + erts_smp_proc_lock(p, plocks); +#endif + BIF_RET(r); +} + + +static int is_last_user(DE_Handle *dh, Process *proc) { + DE_ProcEntry *p = dh->procs; + int found = 0; + + assert_drv_list_locked(); + + while (p != NULL) { + if (p->proc == proc && p->awaiting_status == ERL_DE_PROC_LOADED) { + if (found == 0) { + found = 1; + } else { + return 0; + } + } else if (p->awaiting_status == ERL_DE_PROC_LOADED) { + return 0; + } + p = p->next; + } + return found; +} + +static DE_ProcEntry *find_proc_entry(DE_Handle *dh, Process *proc, Uint status) +{ + DE_ProcEntry *p = dh->procs; + + assert_drv_list_locked(); + + while (p != NULL) { + if (p->proc == proc && p->awaiting_status == status) { + return p; + } + p = p->next; + } + return NULL; +} + +static void remove_proc_entry(DE_Handle *dh, DE_ProcEntry *pe) +{ + DE_ProcEntry **p = &(dh->procs); + + while (*p != NULL && *p != pe) { + p = &((*p)->next); + } + if ((*p) != NULL) { + *p = (*p)->next; + } +} + +static int num_procs(DE_Handle *dh, Uint status) { + DE_ProcEntry *p = dh->procs; + int i = 0; + + assert_drv_list_locked(); + + while (p != NULL) { + if (p->awaiting_status == status) { + ++i; + } + p = p->next; + } + return i; +} +/* +static int num_entries(DE_Handle *dh, Process *proc, Uint status) { + DE_ProcEntry *p = dh->procs; + int i = 0; + + assert_drv_list_locked(); + while (p != NULL) { + if (p->awaiting_status == status && p->proc == proc) { + ++i; + } + p = p->next; + } + return i; +} +*/ +static void add_proc_loaded(DE_Handle *dh, Process *proc) +{ + DE_ProcEntry *p; + assert_drv_list_locked(); + p = erts_alloc(ERTS_ALC_T_DDLL_PROCESS, sizeof(DE_ProcEntry)); + p->proc = proc; + p->flags = 0; + p->awaiting_status = ERL_DE_PROC_LOADED; + p->next = dh->procs; + dh->procs = p; +} + +static void add_proc_loaded_deref(DE_Handle *dh, Process *proc) +{ + DE_ProcEntry *p; + assert_drv_list_locked(); + p = erts_alloc(ERTS_ALC_T_DDLL_PROCESS, sizeof(DE_ProcEntry)); + p->proc = proc; + p->awaiting_status = ERL_DE_PROC_LOADED; + p->flags = ERL_DE_FL_DEREFERENCED; + p->next = dh->procs; + dh->procs = p; +} + +static Eterm copy_ref(Eterm ref, Eterm *hp) +{ + RefThing *ptr = ref_thing_ptr(ref); + memcpy(hp, ptr, sizeof(RefThing)); + return (make_internal_ref(hp)); +} + +static void add_proc_waiting(DE_Handle *dh, Process *proc, + Uint status, Eterm ref) +{ + DE_ProcEntry *p; + assert_drv_list_locked(); + p = erts_alloc(ERTS_ALC_T_DDLL_PROCESS, sizeof(DE_ProcEntry)); + p->proc = proc; + p->flags = 0; + p->awaiting_status = status; + copy_ref(ref, p->heap); + p->next = dh->procs; + dh->procs = p; +} + +static Eterm add_monitor(Process *p, DE_Handle *dh, Uint status) +{ + Eterm r; + + assert_drv_list_locked(); + r = erts_make_ref(p); + add_proc_waiting(dh, p, status, r); + return r; +} + + +static void set_driver_reloading(DE_Handle *dh, Process *proc, char *path, char *name, Uint flags) +{ + DE_ProcEntry *p; + + assert_drv_list_locked(); + p = erts_alloc(ERTS_ALC_T_DDLL_PROCESS, sizeof(DE_ProcEntry)); + p->proc = proc; + p->awaiting_status = ERL_DE_OK; + p->next = dh->procs; + p->flags = ERL_DE_FL_DEREFERENCED; + dh->procs = p; + dh->status = ERL_DE_RELOAD; + dh->reload_full_path = erts_alloc(ERTS_ALC_T_DDLL_HANDLE, sys_strlen(path) + 1); + strcpy(dh->reload_full_path,path); + dh->reload_driver_name = erts_alloc(ERTS_ALC_T_DDLL_HANDLE, sys_strlen(name) + 1); + strcpy(dh->reload_driver_name,name); + dh->reload_flags = flags; +} + +static int do_load_driver_entry(DE_Handle *dh, char *path, char *name) +{ + void *init_handle; + int res; + ErlDrvEntry *dp; + + assert_drv_list_locked(); + + if ((res = erts_sys_ddll_open(path, &(dh->handle))) != ERL_DE_NO_ERROR) { + return res; + } + + if ((res = erts_sys_ddll_load_driver_init(dh->handle, + &init_handle)) != ERL_DE_NO_ERROR) { + erts_sys_ddll_close(dh->handle); + return ERL_DE_LOAD_ERROR_NO_INIT; + } + + dp = erts_sys_ddll_call_init(init_handle); + if (dp == NULL) { + erts_sys_ddll_close(dh->handle); + return ERL_DE_LOAD_ERROR_FAILED_INIT; + } + + switch (dp->extended_marker) { + case 0: + /* + * This may be an old driver that has been recompiled. If so, + * at least the fields that existed in extended driver version + * 1.0 should be zero. If not, a it is a bad driver. We cannot + * be completely certain that this is a valid driver but this is + * the best we can do with old drivers... + */ + if (dp->major_version != 0 + || dp->minor_version != 0 + || dp->driver_flags != 0 + || dp->handle2 != NULL + || dp->process_exit != NULL) { + /* Old driver; needs to be recompiled... */ + return ERL_DE_LOAD_ERROR_INCORRECT_VERSION; + } + break; + case ERL_DRV_EXTENDED_MARKER: + if (ERL_DRV_EXTENDED_MAJOR_VERSION != dp->major_version + || ERL_DRV_EXTENDED_MINOR_VERSION < dp->minor_version) { + /* Incompatible driver version */ + return ERL_DE_LOAD_ERROR_INCORRECT_VERSION; + } + break; + default: + /* Old driver; needs to be recompiled... */ + return ERL_DE_LOAD_ERROR_INCORRECT_VERSION; + } + + if (strcmp(name, dp->driver_name) != 0) { + erts_sys_ddll_close(dh->handle); + return ERL_DE_LOAD_ERROR_BAD_NAME; + } + erts_smp_atomic_init(&(dh->refc), (long) 0); + dh->port_count = 0; + dh->full_path = erts_alloc(ERTS_ALC_T_DDLL_HANDLE, sys_strlen(path) + 1); + sys_strcpy(dh->full_path, path); + dh->flags = 0; + dh->status = ERL_DE_OK; + + if (erts_add_driver_entry(dp, dh, 1) != 0 /* io.c */) { + /* + * The init in the driver struct did not return 0 + */ + erts_free(ERTS_ALC_T_DDLL_HANDLE, dh->full_path); + dh->full_path = NULL; + erts_sys_ddll_close(dh->handle); + return ERL_DE_LOAD_ERROR_FAILED_INIT; + } + + return ERL_DE_NO_ERROR; +} + +static int do_unload_driver_entry(DE_Handle *dh, Eterm *save_name) +{ + erts_driver_t *q, *p = driver_list; + + assert_drv_list_locked(); + + while (p != NULL) { + if (p->handle == dh) { + + q = p; + if (p->prev == NULL) { + driver_list = p->next; + } else { + p->prev->next = p->next; + } + if (p->next != NULL) { + p->next->prev = p->prev; + } + + if (save_name != NULL) { + *save_name = mkatom(q->name); + } + /* XXX:PaN Future locking problems? Don't dare to let go of the diver_list lock here!*/ + if (q->finish) { + int fpe_was_unmasked = erts_block_fpe(); + (*(q->finish))(); + erts_unblock_fpe(fpe_was_unmasked); + } + erts_sys_ddll_close(dh->handle); + erts_destroy_driver(q); + return 1; + } + p = p->next; + } + return 0; +} + +static int load_driver_entry(DE_Handle **dhp, char *path, char *name) +{ + int res; + DE_Handle *dh = erts_alloc(ERTS_ALC_T_DDLL_HANDLE, sizeof(DE_Handle)); + + assert_drv_list_locked(); + + dh->handle = NULL; + dh->procs = NULL; + dh->port_count = 0; + erts_refc_init(&(dh->refc), (long) 0); + dh->status = -1; + dh->reload_full_path = NULL; + dh->reload_driver_name = NULL; + dh->reload_flags = 0; + dh->full_path = NULL; + dh->flags = 0; + + if ((res = do_load_driver_entry(dh, path, name)) != ERL_DE_NO_ERROR) { + erts_free(ERTS_ALC_T_DDLL_HANDLE, (void *) dh); + dh = NULL; + } + *dhp = dh; + return res; +} + +#if 0 +static void unload_driver_entry(DE_Handle *dh) +{ + do_unload_driver_entry(dh, NULL); + if (dh->full_path != NULL) { + erts_free(ERTS_ALC_T_DDLL_HANDLE, (void *) dh->full_path); + } + erts_free(ERTS_ALC_T_DDLL_HANDLE, (void *) dh); +} +#endif +static int reload_driver_entry(DE_Handle *dh) +{ + char *path = dh->reload_full_path; + char *name = dh->reload_driver_name; + int loadres; + Uint flags = dh->reload_flags; + + assert_drv_list_locked(); + + dh->reload_full_path = NULL; + dh->reload_driver_name = NULL; + + ASSERT(erts_refc_read(&(dh->refc),0) == 0); + ASSERT(dh->full_path != NULL); + erts_free(ERTS_ALC_T_DDLL_HANDLE, (void *) dh->full_path); + dh->full_path = NULL; + + loadres = do_load_driver_entry(dh, path, name); + erts_free(ERTS_ALC_T_DDLL_HANDLE, (void *) path); + erts_free(ERTS_ALC_T_DDLL_HANDLE, (void *) name); + if (loadres == ERL_DE_NO_ERROR) { + dh->status = ERL_DE_OK; + dh->flags = flags; + } + restore_process_references(dh); + return loadres; +} + +/* + * Notification {tag = atom(), ref = ref(), driver_name = atom()} or + * {'$DDLL_load_failure', ref = ref(), driver_name = atom(), + * error_term = atom() | {system_error, int()}} + */ + +static void notify_proc(Process *proc, Eterm ref, Eterm driver_name, Eterm type, + Eterm tag, int errcode) +{ + Eterm mess; + Eterm r; + Eterm *hp; + ErlHeapFragment *bp; + ErlOffHeap *ohp; + ErtsProcLocks rp_locks = 0; + ERTS_SMP_CHK_NO_PROC_LOCKS; + + assert_drv_list_locked(); + if (errcode != 0) { + int need = load_error_need(errcode); + Eterm e; + hp = erts_alloc_message_heap(6 /* tuple */ + 3 /* Error tuple */ + + REF_THING_SIZE + need, &bp, &ohp, + proc, &rp_locks); + r = copy_ref(ref,hp); + hp += REF_THING_SIZE; + e = build_load_error_hp(hp, errcode); + hp += need; + mess = TUPLE2(hp,tag,e); + hp += 3; + mess = TUPLE5(hp,type,r,am_driver,driver_name,mess); + } else { + hp = erts_alloc_message_heap(6 /* tuple */ + REF_THING_SIZE, &bp, &ohp, proc, &rp_locks); + r = copy_ref(ref,hp); + hp += REF_THING_SIZE; + mess = TUPLE5(hp,type,r,am_driver,driver_name,tag); + } + erts_queue_message(proc, &rp_locks, bp, mess, am_undefined); + erts_smp_proc_unlock(proc, rp_locks); + ERTS_SMP_CHK_NO_PROC_LOCKS; +} + +static void notify_all(DE_Handle *dh, char *name, Uint awaiting, Eterm type, Eterm tag) +{ + DE_ProcEntry **p; + + assert_drv_list_locked(); + + p = &(dh->procs); + while (*p != NULL) { + if ((*p)->awaiting_status == awaiting) { + DE_ProcEntry *pe; + pe = *p; + *p = pe->next; + notify_proc(pe->proc, make_internal_ref(&(pe->heap)), mkatom(name), type, tag, 0); + erts_free(ERTS_ALC_T_DDLL_PROCESS, (void *) pe); + } else { + p = &((*p)->next); + } + } +} + + + +typedef struct errcode_entry { + char *atm; + int code; +} ErrcodeEntry; + +static ErrcodeEntry errcode_tab[] = { + {"no_error", ERL_DE_NO_ERROR}, + {"no_driver_init", ERL_DE_LOAD_ERROR_NO_INIT}, + {"driver_init_failed", ERL_DE_LOAD_ERROR_FAILED_INIT}, + {"bad_driver_name", ERL_DE_LOAD_ERROR_BAD_NAME}, + {"driver_name_to_long", ERL_DE_LOAD_ERROR_NAME_TO_LONG}, + {"driver_incorrect_version", ERL_DE_LOAD_ERROR_INCORRECT_VERSION}, + {"no_ddll_available", ERL_DE_ERROR_NO_DDLL_FUNCTIONALITY}, + {"unspecified_error", ERL_DE_ERROR_UNSPECIFIED}, + {"symbol_not_found", ERL_DE_LOOKUP_ERROR_NOT_FOUND}, + {NULL,0} +}; + +static int errdesc_to_code(Eterm errdesc, int *code /* out */) +{ + int i; + if (is_atom(errdesc)) { + Atom *ap = atom_tab(atom_val(errdesc)); + for (i = 0; errcode_tab[i].atm != NULL; ++i) { + int len = sys_strlen(errcode_tab[i].atm); + if (len == ap->len && + !sys_strncmp(errcode_tab[i].atm,(char *) ap->name,len)) { + *code = errcode_tab[i].code; + return 0; + } + } + return -1; + } else if (is_tuple(errdesc)) { + Eterm *tp = tuple_val(errdesc); + if (*tp != make_arityval(2) || tp[1] != am_open_error || is_not_small(tp[2])) { + return -1; + } + *code = signed_val(tp[2]); + return 0; + } + return -1; +} + +static Eterm build_load_error(Process *p, int code) +{ + int need = load_error_need(code); + Eterm *hp = NULL; + ERTS_SMP_LC_ASSERT(ERTS_PROC_LOCK_MAIN & erts_proc_lc_my_proc_locks(p)); + if (need) { + hp = HAlloc(p,need); + } + return build_load_error_hp(hp,code); +} + +static int load_error_need(int code) +{ + ErrcodeEntry *ee = errcode_tab; + while (ee->atm != NULL) { + if (ee->code == code) { + return 0; + } + ++ee; + } + return 3; +} + +static Eterm build_load_error_hp(Eterm *hp, int code) +{ + ErrcodeEntry *ee = errcode_tab; + while (ee->atm != NULL) { + if (ee->code == code) { + return mkatom(ee->atm); + } + ++ee; + } + return TUPLE2(hp,am_open_error, make_small(code)); +} + + + +static Eterm mkatom(char *str) +{ + return am_atom_put(str, sys_strlen(str)); +} + +static char *pick_list_or_atom(Eterm name_term) +{ + char *name = NULL; + int name_len; + if (is_atom(name_term)) { + Atom *ap = atom_tab(atom_val(name_term)); + if (ap->len == 0) { + /* If io_lists with zero length is not allowed, + then the empty atom shouldn't */ + goto error; + } + name = erts_alloc(ERTS_ALC_T_DDLL_TMP_BUF, ap->len + 1); + memcpy(name,ap->name,ap->len); + name[ap->len] = '\0'; + } else { + name_len = io_list_len(name_term); + if (name_len <= 0) { + goto error; + } + name = erts_alloc(ERTS_ALC_T_DDLL_TMP_BUF, name_len + 1); + if (io_list_to_buf(name_term, name, name_len) != 0) { + goto error; + } + name[name_len] = '\0'; + } + return name; + error: + if (name != NULL) { + erts_free(ERTS_ALC_T_DDLL_TMP_BUF, (void *) name); + } + return NULL; +} + +static int build_proc_info(DE_Handle *dh, ProcEntryInfo **out_pei, Uint filter) +{ + ProcEntryInfo *pei = NULL; + int num_pei = 0; + int num_pei_allocated = 0; + int i; + DE_ProcEntry *pe; + + assert_drv_list_locked(); + + for (pe = dh->procs; pe != NULL; pe = pe->next) { + Eterm id = pe->proc->id; + Uint stat = pe->awaiting_status; + if (stat == ERL_DE_PROC_AWAIT_UNLOAD_ONLY) { + stat = ERL_DE_PROC_AWAIT_UNLOAD; + } + if (stat != filter) { + continue; + } + for (i = 0; i < num_pei; ++i) { + if (pei[i].pid == id && pei[i].status == stat) { + break; + } + } + if (i < num_pei) { + pei[i].count++; + } else { + if (num_pei >= num_pei_allocated) { + pei = (pei == NULL) + ? erts_alloc(ERTS_ALC_T_DDLL_TMP_BUF, + sizeof(ProcEntryInfo) * (num_pei_allocated = 10)) + : erts_realloc(ERTS_ALC_T_DDLL_TMP_BUF, pei, + sizeof(ProcEntryInfo) * (num_pei_allocated += 10)); + } + pei[num_pei].pid = id; + pei[num_pei].proc = pe->proc; + pei[num_pei].status = stat; + pei[num_pei].count = 1; + ++num_pei; + } + } + *out_pei = pei; + return num_pei; +} + + + +static erts_driver_t *lookup_driver(char *name) +{ + erts_driver_t *drv; + assert_drv_list_locked(); + for (drv = driver_list; drv != NULL && strcmp(drv->name, name); drv = drv->next) + ; + return drv; +} diff --git a/erts/emulator/beam/erl_bif_guard.c b/erts/emulator/beam/erl_bif_guard.c new file mode 100644 index 0000000000..8b47db10dd --- /dev/null +++ b/erts/emulator/beam/erl_bif_guard.c @@ -0,0 +1,628 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2006-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* + * Numeric guard BIFs. + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "erl_process.h" +#include "error.h" +#include "bif.h" +#include "big.h" +#include "erl_binary.h" + +static Eterm gc_double_to_integer(Process* p, double x, Eterm* reg, Uint live); + +static Eterm double_to_integer(Process* p, double x); + +/* + * Guard BIFs called using apply/3 and guard BIFs that never build + * anything on the heap. + */ + +BIF_RETTYPE abs_1(BIF_ALIST_1) +{ + Eterm res; + Sint i0, i; + Eterm* hp; + + /* integer arguments */ + if (is_small(BIF_ARG_1)) { + i0 = signed_val(BIF_ARG_1); + i = labs(i0); + if (i0 == MIN_SMALL) { + hp = HAlloc(BIF_P, BIG_UINT_HEAP_SIZE); + BIF_RET(uint_to_big(i, hp)); + } else { + BIF_RET(make_small(i)); + } + } else if (is_big(BIF_ARG_1)) { + if (!big_sign(BIF_ARG_1)) { + BIF_RET(BIF_ARG_1); + } else { + int sz = big_arity(BIF_ARG_1) + 1; + Uint* x; + + hp = HAlloc(BIF_P, sz); /* See note at beginning of file */ + sz--; + res = make_big(hp); + x = big_val(BIF_ARG_1); + *hp++ = make_pos_bignum_header(sz); + x++; /* skip thing */ + while(sz--) + *hp++ = *x++; + BIF_RET(res); + } + } else if (is_float(BIF_ARG_1)) { + FloatDef f; + + GET_DOUBLE(BIF_ARG_1, f); + if (f.fd < 0.0) { + hp = HAlloc(BIF_P, FLOAT_SIZE_OBJECT); + f.fd = fabs(f.fd); + res = make_float(hp); + PUT_DOUBLE(f, hp); + BIF_RET(res); + } + else + BIF_RET(BIF_ARG_1); + } + BIF_ERROR(BIF_P, BADARG); +} + +BIF_RETTYPE float_1(BIF_ALIST_1) +{ + Eterm res; + Eterm* hp; + FloatDef f; + + /* check args */ + if (is_not_integer(BIF_ARG_1)) { + if (is_float(BIF_ARG_1)) { + BIF_RET(BIF_ARG_1); + } else { + badarg: + BIF_ERROR(BIF_P, BADARG); + } + } + if (is_small(BIF_ARG_1)) { + Sint i = signed_val(BIF_ARG_1); + f.fd = i; /* use "C"'s auto casting */ + } else if (big_to_double(BIF_ARG_1, &f.fd) < 0) { + goto badarg; + } + hp = HAlloc(BIF_P, FLOAT_SIZE_OBJECT); + res = make_float(hp); + PUT_DOUBLE(f, hp); + BIF_RET(res); +} + +BIF_RETTYPE trunc_1(BIF_ALIST_1) +{ + Eterm res; + FloatDef f; + + /* check arg */ + if (is_not_float(BIF_ARG_1)) { + if (is_integer(BIF_ARG_1)) + BIF_RET(BIF_ARG_1); + BIF_ERROR(BIF_P, BADARG); + } + /* get the float */ + GET_DOUBLE(BIF_ARG_1, f); + + /* truncate it and return the resultant integer */ + res = double_to_integer(BIF_P, (f.fd >= 0.0) ? floor(f.fd) : ceil(f.fd)); + BIF_RET(res); +} + +BIF_RETTYPE round_1(BIF_ALIST_1) +{ + Eterm res; + FloatDef f; + + /* check arg */ + if (is_not_float(BIF_ARG_1)) { + if (is_integer(BIF_ARG_1)) + BIF_RET(BIF_ARG_1); + BIF_ERROR(BIF_P, BADARG); + } + + /* get the float */ + GET_DOUBLE(BIF_ARG_1, f); + + /* round it and return the resultant integer */ + res = double_to_integer(BIF_P, (f.fd > 0.0) ? f.fd + 0.5 : f.fd - 0.5); + BIF_RET(res); +} + +BIF_RETTYPE length_1(BIF_ALIST_1) +{ + Eterm list; + Uint i; + + if (is_nil(BIF_ARG_1)) + BIF_RET(SMALL_ZERO); + if (is_not_list(BIF_ARG_1)) { + BIF_ERROR(BIF_P, BADARG); + } + list = BIF_ARG_1; + i = 0; + while (is_list(list)) { + i++; + list = CDR(list_val(list)); + } + if (is_not_nil(list)) { + BIF_ERROR(BIF_P, BADARG); + } + BIF_RET(make_small(i)); +} + +/* returns the size of a tuple or a binary */ + +BIF_RETTYPE size_1(BIF_ALIST_1) +{ + if (is_tuple(BIF_ARG_1)) { + Eterm* tupleptr = tuple_val(BIF_ARG_1); + + BIF_RET(make_small(arityval(*tupleptr))); + } else if (is_binary(BIF_ARG_1)) { + Uint sz = binary_size(BIF_ARG_1); + if (IS_USMALL(0, sz)) { + return make_small(sz); + } else { + Eterm* hp = HAlloc(BIF_P, BIG_UINT_HEAP_SIZE); + BIF_RET(uint_to_big(sz, hp)); + } + } + BIF_ERROR(BIF_P, BADARG); +} + +/**********************************************************************/ +/* returns the bitsize of a bitstring */ + +BIF_RETTYPE bit_size_1(BIF_ALIST_1) +{ + Uint low_bits; + Uint bytesize; + Uint high_bits; + if (is_binary(BIF_ARG_1)) { + bytesize = binary_size(BIF_ARG_1); + high_bits = bytesize >> ((sizeof(Uint) * 8)-3); + low_bits = (bytesize << 3) + binary_bitsize(BIF_ARG_1); + if (high_bits == 0) { + if (IS_USMALL(0,low_bits)) { + BIF_RET(make_small(low_bits)); + } else { + Eterm* hp = HAlloc(BIF_P, BIG_UINT_HEAP_SIZE); + BIF_RET(uint_to_big(low_bits, hp)); + } + } else { + Uint sz = BIG_UINT_HEAP_SIZE+1; + Eterm* hp = HAlloc(BIF_P, sz); + hp[0] = make_pos_bignum_header(sz-1); + BIG_DIGIT(hp,0) = low_bits; + BIG_DIGIT(hp,1) = high_bits; + BIF_RET(make_big(hp)); + } + } else { + BIF_ERROR(BIF_P, BADARG); + } +} + +/**********************************************************************/ +/* returns the number of bytes need to store a bitstring */ + +BIF_RETTYPE byte_size_1(BIF_ALIST_1) +{ + if (is_binary(BIF_ARG_1)) { + Uint bytesize = binary_size(BIF_ARG_1); + if (binary_bitsize(BIF_ARG_1) > 0) { + bytesize++; + } + if (IS_USMALL(0, bytesize)) { + BIF_RET(make_small(bytesize)); + } else { + Eterm* hp = HAlloc(BIF_P, BIG_UINT_HEAP_SIZE); + BIF_RET(uint_to_big(bytesize, hp)); + } + } else { + BIF_ERROR(BIF_P, BADARG); + } +} + +/* + * Generate the integer part from a double. + */ +static Eterm +double_to_integer(Process* p, double x) +{ + int is_negative; + int ds; + ErtsDigit* xp; + int i; + Eterm res; + size_t sz; + Eterm* hp; + double dbase; + + if ((x < (double) (MAX_SMALL+1)) && (x > (double) (MIN_SMALL-1))) { + Sint xi = x; + return make_small(xi); + } + + if (x >= 0) { + is_negative = 0; + } else { + is_negative = 1; + x = -x; + } + + /* Unscale & (calculate exponent) */ + ds = 0; + dbase = ((double)(D_MASK)+1); + while(x >= 1.0) { + x /= dbase; /* "shift" right */ + ds++; + } + sz = BIG_NEED_SIZE(ds); /* number of words including arity */ + + hp = HAlloc(p, sz); + res = make_big(hp); + xp = (ErtsDigit*) (hp + 1); + + for (i = ds-1; i >= 0; i--) { + ErtsDigit d; + + x *= dbase; /* "shift" left */ + d = x; /* trunc */ + xp[i] = d; /* store digit */ + x -= d; /* remove integer part */ + } + while ((ds & (BIG_DIGITS_PER_WORD-1)) != 0) { + xp[ds++] = 0; + } + + if (is_negative) { + *hp = make_neg_bignum_header(sz-1); + } else { + *hp = make_pos_bignum_header(sz-1); + } + return res; +} + +/* + * The following code is used when a guard that may build on the + * heap is called directly. They must not use HAlloc(), but must + * do a garbage collection if there is insufficient heap space. + */ + +#define ERTS_NEED_GC(p, need) ((HEAP_LIMIT((p)) - HEAP_TOP((p))) <= (need)) + +Eterm erts_gc_length_1(Process* p, Eterm* reg, Uint live) +{ + Eterm list = reg[live]; + int i; + + if (is_nil(list)) + return SMALL_ZERO; + i = 0; + while (is_list(list)) { + i++; + list = CDR(list_val(list)); + } + if (is_not_nil(list)) { + BIF_ERROR(p, BADARG); + } + return make_small(i); +} + +Eterm erts_gc_size_1(Process* p, Eterm* reg, Uint live) +{ + Eterm arg = reg[live]; + if (is_tuple(arg)) { + Eterm* tupleptr = tuple_val(arg); + return make_small(arityval(*tupleptr)); + } else if (is_binary(arg)) { + Uint sz = binary_size(arg); + if (IS_USMALL(0, sz)) { + return make_small(sz); + } else { + Eterm* hp; + if (ERTS_NEED_GC(p, BIG_UINT_HEAP_SIZE)) { + erts_garbage_collect(p, BIG_UINT_HEAP_SIZE, reg, live); + } + hp = p->htop; + p->htop += BIG_UINT_HEAP_SIZE; + return uint_to_big(sz, hp); + } + } + BIF_ERROR(p, BADARG); +} + +Eterm erts_gc_bit_size_1(Process* p, Eterm* reg, Uint live) +{ + Eterm arg = reg[live]; + if (is_binary(arg)) { + Uint low_bits; + Uint bytesize; + Uint high_bits; + bytesize = binary_size(arg); + high_bits = bytesize >> ((sizeof(Uint) * 8)-3); + low_bits = (bytesize << 3) + binary_bitsize(arg); + if (high_bits == 0) { + if (IS_USMALL(0,low_bits)) { + return make_small(low_bits); + } else { + Eterm* hp; + if (ERTS_NEED_GC(p, BIG_UINT_HEAP_SIZE)) { + erts_garbage_collect(p, BIG_UINT_HEAP_SIZE, reg, live); + } + hp = p->htop; + p->htop += BIG_UINT_HEAP_SIZE; + return uint_to_big(low_bits, hp); + } + } else { + Uint sz = BIG_UINT_HEAP_SIZE+1; + Eterm* hp; + if (ERTS_NEED_GC(p, sz)) { + erts_garbage_collect(p, sz, reg, live); + } + hp = p->htop; + p->htop += sz; + hp[0] = make_pos_bignum_header(sz-1); + BIG_DIGIT(hp,0) = low_bits; + BIG_DIGIT(hp,1) = high_bits; + return make_big(hp); + } + } else { + BIF_ERROR(p, BADARG); + } +} + +Eterm erts_gc_byte_size_1(Process* p, Eterm* reg, Uint live) +{ + Eterm arg = reg[live]; + if (is_binary(arg)) { + Uint bytesize = binary_size(arg); + if (binary_bitsize(arg) > 0) { + bytesize++; + } + if (IS_USMALL(0, bytesize)) { + return make_small(bytesize); + } else { + Eterm* hp; + if (ERTS_NEED_GC(p, BIG_UINT_HEAP_SIZE)) { + erts_garbage_collect(p, BIG_UINT_HEAP_SIZE, reg, live); + } + hp = p->htop; + p->htop += BIG_UINT_HEAP_SIZE; + return uint_to_big(bytesize, hp); + } + } else { + BIF_ERROR(p, BADARG); + } +} + +Eterm erts_gc_abs_1(Process* p, Eterm* reg, Uint live) +{ + Eterm arg; + Eterm res; + Sint i0, i; + Eterm* hp; + + arg = reg[live]; + + /* integer arguments */ + if (is_small(arg)) { + i0 = signed_val(arg); + i = labs(i0); + if (i0 == MIN_SMALL) { + if (ERTS_NEED_GC(p, BIG_UINT_HEAP_SIZE)) { + erts_garbage_collect(p, BIG_UINT_HEAP_SIZE, reg, live+1); + arg = reg[live]; + } + hp = p->htop; + p->htop += BIG_UINT_HEAP_SIZE; + return uint_to_big(i, hp); + } else { + return make_small(i); + } + } else if (is_big(arg)) { + if (!big_sign(arg)) { + return arg; + } else { + int sz = big_arity(arg) + 1; + Uint* x; + + if (ERTS_NEED_GC(p, sz)) { + erts_garbage_collect(p, sz, reg, live+1); + arg = reg[live]; + } + hp = p->htop; + p->htop += sz; + sz--; + res = make_big(hp); + x = big_val(arg); + *hp++ = make_pos_bignum_header(sz); + x++; /* skip thing */ + while(sz--) + *hp++ = *x++; + return res; + } + } else if (is_float(arg)) { + FloatDef f; + + GET_DOUBLE(arg, f); + if (f.fd < 0.0) { + if (ERTS_NEED_GC(p, FLOAT_SIZE_OBJECT)) { + erts_garbage_collect(p, FLOAT_SIZE_OBJECT, reg, live+1); + arg = reg[live]; + } + hp = p->htop; + p->htop += FLOAT_SIZE_OBJECT; + f.fd = fabs(f.fd); + res = make_float(hp); + PUT_DOUBLE(f, hp); + return res; + } + else + return arg; + } + BIF_ERROR(p, BADARG); +} + +Eterm erts_gc_float_1(Process* p, Eterm* reg, Uint live) +{ + Eterm arg; + Eterm res; + Eterm* hp; + FloatDef f; + + /* check args */ + arg = reg[live]; + if (is_not_integer(arg)) { + if (is_float(arg)) { + return arg; + } else { + badarg: + BIF_ERROR(p, BADARG); + } + } + if (is_small(arg)) { + Sint i = signed_val(arg); + f.fd = i; /* use "C"'s auto casting */ + } else if (big_to_double(arg, &f.fd) < 0) { + goto badarg; + } + if (ERTS_NEED_GC(p, FLOAT_SIZE_OBJECT)) { + erts_garbage_collect(p, FLOAT_SIZE_OBJECT, reg, live+1); + arg = reg[live]; + } + hp = p->htop; + p->htop += FLOAT_SIZE_OBJECT; + res = make_float(hp); + PUT_DOUBLE(f, hp); + return res; +} + +Eterm erts_gc_round_1(Process* p, Eterm* reg, Uint live) +{ + Eterm arg; + FloatDef f; + + arg = reg[live]; + if (is_not_float(arg)) { + if (is_integer(arg)) { + return arg; + } + BIF_ERROR(p, BADARG); + } + GET_DOUBLE(arg, f); + + return gc_double_to_integer(p, (f.fd > 0.0) ? f.fd + 0.5 : f.fd - 0.5, + reg, live); +} + +Eterm erts_gc_trunc_1(Process* p, Eterm* reg, Uint live) +{ + Eterm arg; + FloatDef f; + + arg = reg[live]; + if (is_not_float(arg)) { + if (is_integer(arg)) { + return arg; + } + BIF_ERROR(p, BADARG); + } + /* get the float */ + GET_DOUBLE(arg, f); + + /* truncate it and return the resultant integer */ + return gc_double_to_integer(p, (f.fd >= 0.0) ? floor(f.fd) : ceil(f.fd), + reg, live); +} + +static Eterm +gc_double_to_integer(Process* p, double x, Eterm* reg, Uint live) +{ + int is_negative; + int ds; + ErtsDigit* xp; + int i; + Eterm res; + size_t sz; + Eterm* hp; + double dbase; + + if ((x < (double) (MAX_SMALL+1)) && (x > (double) (MIN_SMALL-1))) { + Sint xi = x; + return make_small(xi); + } + + if (x >= 0) { + is_negative = 0; + } else { + is_negative = 1; + x = -x; + } + + /* Unscale & (calculate exponent) */ + ds = 0; + dbase = ((double)(D_MASK)+1); + while(x >= 1.0) { + x /= dbase; /* "shift" right */ + ds++; + } + sz = BIG_NEED_SIZE(ds); /* number of words including arity */ + if (ERTS_NEED_GC(p, sz)) { + erts_garbage_collect(p, sz, reg, live); + } + hp = p->htop; + p->htop += sz; + res = make_big(hp); + xp = (ErtsDigit*) (hp + 1); + + for (i = ds-1; i >= 0; i--) { + ErtsDigit d; + + x *= dbase; /* "shift" left */ + d = x; /* trunc */ + xp[i] = d; /* store digit */ + x -= d; /* remove integer part */ + } + while ((ds & (BIG_DIGITS_PER_WORD-1)) != 0) { + xp[ds++] = 0; + } + + if (is_negative) { + *hp = make_neg_bignum_header(sz-1); + } else { + *hp = make_pos_bignum_header(sz-1); + } + return res; +} diff --git a/erts/emulator/beam/erl_bif_info.c b/erts/emulator/beam/erl_bif_info.c new file mode 100644 index 0000000000..60216aa8e4 --- /dev/null +++ b/erts/emulator/beam/erl_bif_info.c @@ -0,0 +1,3803 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1999-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "erl_process.h" +#include "erl_nmgc.h" +#include "error.h" +#include "erl_driver.h" +#include "bif.h" +#include "big.h" +#include "erl_version.h" +#include "erl_db_util.h" +#include "erl_message.h" +#include "erl_binary.h" +#include "erl_db.h" +#include "erl_instrument.h" +#include "dist.h" +#include "erl_gc.h" +#ifdef ELIB_ALLOC_IS_CLIB +#include "elib_stat.h" +#endif +#ifdef HIPE +#include "hipe_arch.h" +#endif + +#ifdef ERTS_ENABLE_LOCK_COUNT +#include "erl_lock_count.h" +#endif + +#ifdef VALGRIND +#include +#include +#endif + +#define DECL_AM(S) Eterm AM_ ## S = am_atom_put(#S, sizeof(#S) - 1) + +/* Keep erts_system_version as a global variable for easy access from a core */ +static char erts_system_version[] = ("Erlang " ERLANG_OTP_RELEASE + " (erts-" ERLANG_VERSION ")" +#ifndef OTP_RELEASE + " [source]" +#endif +#ifdef ARCH_64 + " [64-bit]" +#endif +#ifdef ERTS_SMP + " [smp:%bpu:%bpu]" +#endif + " [rq:%bpu]" +#ifdef USE_THREADS + " [async-threads:%d]" +#endif +#ifdef HIPE + " [hipe]" +#endif +#ifdef ERTS_ENABLE_KERNEL_POLL + " [kernel-poll:%s]" +#endif +#ifdef HYBRID + " [hybrid heap]" +#endif +#ifdef INCREMENTAL + " [incremental GC]" +#endif +#ifdef ET_DEBUG +#if ET_DEBUG + " [type-assertions]" +#endif +#endif +#ifdef DEBUG + " [debug-compiled]" +#endif +#ifdef ERTS_ENABLE_LOCK_CHECK + " [lock-checking]" +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + " [lock-counting]" +#endif +#ifdef PURIFY + " [purify-compiled]" +#endif +#ifdef VALGRIND + " [valgrind-compiled]" +#endif + "\n"); + +#define ASIZE(a) (sizeof(a)/sizeof(a[0])) + +#if defined(HAVE_SOLARIS_SPARC_PERFMON) +# include +# define PERFMON_SETPCR _IOW('P', 1, unsigned long long) +# define PERFMON_GETPCR _IOR('P', 2, unsigned long long) +#endif + +static Eterm +bld_bin_list(Uint **hpp, Uint *szp, ProcBin* pb) +{ + Eterm res = NIL; + Eterm tuple; + + for (; pb; pb = pb->next) { + Eterm val = erts_bld_uint(hpp, szp, (Uint) pb->val); + Eterm orig_size = erts_bld_uint(hpp, szp, pb->val->orig_size); + + if (szp) + *szp += 4+2; + if (hpp) { + Uint refc = (Uint) erts_smp_atomic_read(&pb->val->refc); + tuple = TUPLE3(*hpp, val, orig_size, make_small(refc)); + res = CONS(*hpp + 4, tuple, res); + *hpp += 4+2; + } + } + return res; +} + + +/* + make_monitor_list: + returns a list of records.. + -record(erl_monitor, { + type, % MON_ORIGIN or MON_TARGET (1 or 3) + ref, + pid, % Process or nodename + name % registered name or [] + }). +*/ + +static void do_calc_mon_size(ErtsMonitor *mon, void *vpsz) +{ + Uint *psz = vpsz; + *psz += IS_CONST(mon->ref) ? 0 : NC_HEAP_SIZE(mon->ref); + *psz += IS_CONST(mon->pid) ? 0 : NC_HEAP_SIZE(mon->pid); + *psz += 8; /* CONS + 5-tuple */ +} + +typedef struct { + Process *p; + Eterm *hp; + Eterm res; + Eterm tag; +} MonListContext; + +static void do_make_one_mon_element(ErtsMonitor *mon, void * vpmlc) +{ + MonListContext *pmlc = vpmlc; + Eterm tup; + Eterm r = (IS_CONST(mon->ref) + ? mon->ref + : STORE_NC(&(pmlc->hp), &MSO(pmlc->p).externals, mon->ref)); + Eterm p = (IS_CONST(mon->pid) + ? mon->pid + : STORE_NC(&(pmlc->hp), &MSO(pmlc->p).externals, mon->pid)); + tup = TUPLE5(pmlc->hp, pmlc->tag, make_small(mon->type), r, p, mon->name); + pmlc->hp += 6; + pmlc->res = CONS(pmlc->hp, tup, pmlc->res); + pmlc->hp += 2; +} + +static Eterm +make_monitor_list(Process *p, ErtsMonitor *root) +{ + DECL_AM(erl_monitor); + Uint sz = 0; + MonListContext mlc; + + erts_doforall_monitors(root, &do_calc_mon_size, &sz); + if (sz == 0) { + return NIL; + } + mlc.p = p; + mlc.hp = HAlloc(p,sz); + mlc.res = NIL; + mlc.tag = AM_erl_monitor; + erts_doforall_monitors(root, &do_make_one_mon_element, &mlc); + return mlc.res; +} + +/* + make_link_list: + returns a list of records.. + -record(erl_link, { + type, % LINK_NODE or LINK_PID (1 or 3) + pid, % Process or nodename + targets % List of erl_link's or nil + }). +*/ + +static void do_calc_lnk_size(ErtsLink *lnk, void *vpsz) +{ + Uint *psz = vpsz; + *psz += IS_CONST(lnk->pid) ? 0 : NC_HEAP_SIZE(lnk->pid); + if (lnk->type != LINK_NODE && ERTS_LINK_ROOT(lnk) != NULL) { + /* Node links use this pointer as ref counter... */ + erts_doforall_links(ERTS_LINK_ROOT(lnk),&do_calc_lnk_size,vpsz); + } + *psz += 7; /* CONS + 4-tuple */ +} + +typedef struct { + Process *p; + Eterm *hp; + Eterm res; + Eterm tag; +} LnkListContext; + +static void do_make_one_lnk_element(ErtsLink *lnk, void * vpllc) +{ + LnkListContext *pllc = vpllc; + Eterm tup; + Eterm old_res, targets = NIL; + Eterm p = (IS_CONST(lnk->pid) + ? lnk->pid + : STORE_NC(&(pllc->hp), &MSO(pllc->p).externals, lnk->pid)); + if (lnk->type == LINK_NODE) { + targets = make_small(ERTS_LINK_REFC(lnk)); + } else if (ERTS_LINK_ROOT(lnk) != NULL) { + old_res = pllc->res; + pllc->res = NIL; + erts_doforall_links(ERTS_LINK_ROOT(lnk),&do_make_one_lnk_element, vpllc); + targets = pllc->res; + pllc->res = old_res; + } + tup = TUPLE4(pllc->hp, pllc->tag, make_small(lnk->type), p, targets); + pllc->hp += 5; + pllc->res = CONS(pllc->hp, tup, pllc->res); + pllc->hp += 2; +} + +static Eterm +make_link_list(Process *p, ErtsLink *root, Eterm tail) +{ + DECL_AM(erl_link); + Uint sz = 0; + LnkListContext llc; + + erts_doforall_links(root, &do_calc_lnk_size, &sz); + if (sz == 0) { + return tail; + } + llc.p = p; + llc.hp = HAlloc(p,sz); + llc.res = tail; + llc.tag = AM_erl_link; + erts_doforall_links(root, &do_make_one_lnk_element, &llc); + return llc.res; +} + +int +erts_print_system_version(int to, void *arg, Process *c_p) +{ +#ifdef ERTS_SMP + Uint total, online, active; + (void) erts_schedulers_state(&total, &online, &active, 0); +#endif + return erts_print(to, arg, erts_system_version +#ifdef ERTS_SMP + , total, online, erts_no_run_queues +#else + , 1 +#endif +#ifdef USE_THREADS + , erts_async_max_threads +#endif +#ifdef ERTS_ENABLE_KERNEL_POLL + , erts_use_kernel_poll ? "true" : "false" +#endif + ); +} + +typedef struct { + Eterm entity; + Eterm node; +} MonitorInfo; + +typedef struct { + MonitorInfo *mi; + Uint mi_i; + Uint mi_max; + int sz; +} MonitorInfoCollection; + +#define INIT_MONITOR_INFOS(MIC) do { \ + (MIC).mi = NULL; \ + (MIC).mi_i = (MIC).mi_max = 0; \ + (MIC).sz = 0; \ +} while(0) + +#define MI_INC 50 +#define EXTEND_MONITOR_INFOS(MICP) \ +do { \ + if ((MICP)->mi_i >= (MICP)->mi_max) { \ + (MICP)->mi = ((MICP)->mi ? erts_realloc(ERTS_ALC_T_TMP, \ + (MICP)->mi, \ + ((MICP)->mi_max+MI_INC) \ + * sizeof(MonitorInfo)) \ + : erts_alloc(ERTS_ALC_T_TMP, \ + MI_INC*sizeof(MonitorInfo))); \ + (MICP)->mi_max += MI_INC; \ + } \ + } while (0) +#define DESTROY_MONITOR_INFOS(MIC) \ +do { \ + if ((MIC).mi != NULL) { \ + erts_free(ERTS_ALC_T_TMP, (void *) (MIC).mi); \ + } \ + } while (0) + +static void collect_one_link(ErtsLink *lnk, void *vmicp) +{ + MonitorInfoCollection *micp = vmicp; + EXTEND_MONITOR_INFOS(micp); + if (!(lnk->type == LINK_PID)) { + return; + } + micp->mi[micp->mi_i].entity = lnk->pid; + micp->sz += 2 + NC_HEAP_SIZE(lnk->pid); + micp->mi_i++; +} + +static void collect_one_origin_monitor(ErtsMonitor *mon, void *vmicp) +{ + MonitorInfoCollection *micp = vmicp; + + if (mon->type != MON_ORIGIN) { + return; + } + EXTEND_MONITOR_INFOS(micp); + if (is_atom(mon->pid)) { /* external by name */ + micp->mi[micp->mi_i].entity = mon->name; + micp->mi[micp->mi_i].node = mon->pid; + micp->sz += 3; /* need one 2-tuple */ + } else if (is_external_pid(mon->pid)) { /* external by pid */ + micp->mi[micp->mi_i].entity = mon->pid; + micp->mi[micp->mi_i].node = NIL; + micp->sz += NC_HEAP_SIZE(mon->pid); + } else if (!is_nil(mon->name)) { /* internal by name */ + micp->mi[micp->mi_i].entity = mon->name; + micp->mi[micp->mi_i].node = erts_this_dist_entry->sysname; + micp->sz += 3; /* need one 2-tuple */ + } else { /* internal by pid */ + micp->mi[micp->mi_i].entity = mon->pid; + micp->mi[micp->mi_i].node = NIL; + /* no additional heap space needed */ + } + micp->mi_i++; + micp->sz += 2 + 3; /* For a cons cell and a 2-tuple */ +} + +static void collect_one_target_monitor(ErtsMonitor *mon, void *vmicp) +{ + MonitorInfoCollection *micp = vmicp; + + if (mon->type != MON_TARGET) { + return; + } + + EXTEND_MONITOR_INFOS(micp); + + micp->mi[micp->mi_i].node = NIL; + micp->mi[micp->mi_i].entity = mon->pid; + micp->sz += (NC_HEAP_SIZE(mon->pid) + 2 /* cons */); + micp->mi_i++; +} + +typedef struct { + Process *c_p; + ErtsProcLocks c_p_locks; + ErtsSuspendMonitor **smi; + Uint smi_i; + Uint smi_max; + int sz; +} ErtsSuspendMonitorInfoCollection; + +#define ERTS_INIT_SUSPEND_MONITOR_INFOS(SMIC, CP, CPL) do { \ + (SMIC).c_p = (CP); \ + (SMIC).c_p_locks = (CPL); \ + (SMIC).smi = NULL; \ + (SMIC).smi_i = (SMIC).smi_max = 0; \ + (SMIC).sz = 0; \ +} while(0) + +#define ERTS_SMI_INC 50 +#define ERTS_EXTEND_SUSPEND_MONITOR_INFOS(SMICP) \ +do { \ + if ((SMICP)->smi_i >= (SMICP)->smi_max) { \ + (SMICP)->smi = ((SMICP)->smi \ + ? erts_realloc(ERTS_ALC_T_TMP, \ + (SMICP)->smi, \ + ((SMICP)->smi_max \ + + ERTS_SMI_INC) \ + * sizeof(ErtsSuspendMonitor *)) \ + : erts_alloc(ERTS_ALC_T_TMP, \ + ERTS_SMI_INC \ + * sizeof(ErtsSuspendMonitor *))); \ + (SMICP)->smi_max += ERTS_SMI_INC; \ + } \ + } while (0) + +#define ERTS_DESTROY_SUSPEND_MONITOR_INFOS(SMIC) \ +do { \ + if ((SMIC).smi != NULL) { \ + erts_free(ERTS_ALC_T_TMP, (void *) (SMIC).smi); \ + } \ + } while (0) + +static void +collect_one_suspend_monitor(ErtsSuspendMonitor *smon, void *vsmicp) +{ + ErtsSuspendMonitorInfoCollection *smicp = vsmicp; + Process *suspendee = erts_pid2proc(smicp->c_p, + smicp->c_p_locks, + smon->pid, + 0); + if (suspendee) { /* suspendee is alive */ + Sint a, p; + if (smon->active) { + smon->active += smon->pending; + smon->pending = 0; + } + + ASSERT((smon->active && !smon->pending) + || (smon->pending && !smon->active)); + + ERTS_EXTEND_SUSPEND_MONITOR_INFOS(smicp); + + smicp->smi[smicp->smi_i] = smon; + smicp->sz += 2 /* cons */ + 4 /* 3-tuple */; + + a = (Sint) smon->active; /* quiet compiler warnings */ + p = (Sint) smon->pending; /* on 64-bit machines */ + + if (!IS_SSMALL(a)) + smicp->sz += BIG_UINT_HEAP_SIZE; + if (!IS_SSMALL(p)) + smicp->sz += BIG_UINT_HEAP_SIZE; + smicp->smi_i++; + } +} + + +static void one_link_size(ErtsLink *lnk, void *vpu) +{ + Uint *pu = vpu; + *pu += ERTS_LINK_SIZE*sizeof(Uint); + if(!IS_CONST(lnk->pid)) + *pu += NC_HEAP_SIZE(lnk->pid)*sizeof(Uint); + if (lnk->type != LINK_NODE && ERTS_LINK_ROOT(lnk) != NULL) { + erts_doforall_links(ERTS_LINK_ROOT(lnk),&one_link_size,vpu); + } +} +static void one_mon_size(ErtsMonitor *mon, void *vpu) +{ + Uint *pu = vpu; + *pu += ERTS_MONITOR_SIZE*sizeof(Uint); + if(!IS_CONST(mon->pid)) + *pu += NC_HEAP_SIZE(mon->pid)*sizeof(Uint); + if(!IS_CONST(mon->ref)) + *pu += NC_HEAP_SIZE(mon->ref)*sizeof(Uint); +} + +/* + * process_info/[1,2] + */ + +#define ERTS_PI_FAIL_TYPE_BADARG 0 +#define ERTS_PI_FAIL_TYPE_YIELD 1 +#define ERTS_PI_FAIL_TYPE_AWAIT_EXIT 2 + +static ERTS_INLINE ErtsProcLocks +pi_locks(Eterm info) +{ + switch (info) { + case am_status: + case am_priority: + return ERTS_PROC_LOCK_STATUS; + case am_links: + case am_monitors: + case am_monitored_by: + case am_suspending: + return ERTS_PROC_LOCK_LINK; + case am_messages: + case am_message_queue_len: + case am_total_heap_size: + return ERTS_PROC_LOCK_MAIN|ERTS_PROC_LOCK_MSGQ; + case am_memory: + return ERTS_PROC_LOCK_MAIN|ERTS_PROC_LOCK_LINK|ERTS_PROC_LOCK_MSGQ; + default: + return ERTS_PROC_LOCK_MAIN; + } +} + +/* + * All valid process_info arguments. + */ +static Eterm pi_args[] = { + am_registered_name, + am_current_function, + am_initial_call, + am_status, + am_messages, + am_message_queue_len, + am_links, + am_monitors, + am_monitored_by, + am_dictionary, + am_trap_exit, + am_error_handler, + am_heap_size, + am_stack_size, + am_memory, + am_garbage_collection, + am_group_leader, + am_reductions, + am_priority, + am_trace, + am_binary, + am_sequential_trace_token, + am_catchlevel, + am_backtrace, + am_last_calls, + am_total_heap_size, + am_suspending, +#ifdef HYBRID + am_message_binary +#endif +}; + +#define ERTS_PI_ARGS ((int) (sizeof(pi_args)/sizeof(Eterm))) + +static ERTS_INLINE Eterm +pi_ix2arg(int ix) +{ + if (ix < 0 || ERTS_PI_ARGS <= ix) + return am_undefined; + return pi_args[ix]; +} + +static ERTS_INLINE int +pi_arg2ix(Eterm arg) +{ + switch (arg) { + case am_registered_name: return 0; + case am_current_function: return 1; + case am_initial_call: return 2; + case am_status: return 3; + case am_messages: return 4; + case am_message_queue_len: return 5; + case am_links: return 6; + case am_monitors: return 7; + case am_monitored_by: return 8; + case am_dictionary: return 9; + case am_trap_exit: return 10; + case am_error_handler: return 11; + case am_heap_size: return 12; + case am_stack_size: return 13; + case am_memory: return 14; + case am_garbage_collection: return 15; + case am_group_leader: return 16; + case am_reductions: return 17; + case am_priority: return 18; + case am_trace: return 19; + case am_binary: return 20; + case am_sequential_trace_token: return 21; + case am_catchlevel: return 22; + case am_backtrace: return 23; + case am_last_calls: return 24; + case am_total_heap_size: return 25; + case am_suspending: return 26; +#ifdef HYBRID + case am_message_binary: return 27; +#endif + default: return -1; + } +} + +static Eterm pi_1_keys[] = { + am_registered_name, + am_current_function, + am_initial_call, + am_status, + am_message_queue_len, + am_messages, + am_links, + am_dictionary, + am_trap_exit, + am_error_handler, + am_priority, + am_group_leader, + am_total_heap_size, + am_heap_size, + am_stack_size, + am_reductions, + am_garbage_collection, + am_suspending +}; + +#define ERTS_PI_1_NO_OF_KEYS (sizeof(pi_1_keys)/sizeof(Eterm)) + +static Eterm pi_1_keys_list; +static Uint pi_1_keys_list_heap[2*ERTS_PI_1_NO_OF_KEYS]; + +static void +process_info_init(void) +{ + Eterm *hp = &pi_1_keys_list_heap[0]; + int i; + + pi_1_keys_list = NIL; + + for (i = ERTS_PI_1_NO_OF_KEYS-1; i >= 0; i--) { + pi_1_keys_list = CONS(hp, pi_1_keys[i], pi_1_keys_list); + hp += 2; + } + +#ifdef DEBUG + { /* Make sure the process_info argument mappings are consistent */ + int ix; + for (ix = 0; ix < ERTS_PI_ARGS; ix++) { + ASSERT(pi_arg2ix(pi_ix2arg(ix)) == ix); + } + } +#endif + +} + +static ERTS_INLINE Process * +pi_pid2proc(Process *c_p, Eterm pid, ErtsProcLocks info_locks) +{ +#ifdef ERTS_SMP + /* + * If the main lock is needed, we use erts_pid2proc_not_running() + * instead of erts_pid2proc() for two reasons: + * * Current function of pid and possibly other information will + * have been updated so that process_info() is consistent with an + * info-request/info-response signal model. + * * We avoid blocking the whole scheduler executing the + * process that is calling process_info() for a long time + * which will happen if pid is currently running. + * The caller of process_info() may have to yield if pid + * is currently running. + */ + + if (info_locks & ERTS_PROC_LOCK_MAIN) + return erts_pid2proc_not_running(c_p, ERTS_PROC_LOCK_MAIN, + pid, info_locks); + else +#endif + return erts_pid2proc(c_p, ERTS_PROC_LOCK_MAIN, + pid, info_locks); +} + + + +BIF_RETTYPE +process_info_aux(Process *BIF_P, + Process *rp, + Eterm rpid, + Eterm item, + int always_wrap); + +#define ERTS_PI_RES_ELEM_IX_BUF_INC 1024 +#define ERTS_PI_DEF_RES_ELEM_IX_BUF_SZ ERTS_PI_ARGS + +static Eterm +process_info_list(Process *c_p, Eterm pid, Eterm list, int always_wrap, + int *fail_type) +{ + int want_messages = 0; + int def_res_elem_ix_buf[ERTS_PI_DEF_RES_ELEM_IX_BUF_SZ]; + int *res_elem_ix = &def_res_elem_ix_buf[0]; + int res_elem_ix_ix = -1; + int res_elem_ix_sz = ERTS_PI_DEF_RES_ELEM_IX_BUF_SZ; + Eterm part_res[ERTS_PI_ARGS]; + Eterm res, arg; + Uint *hp, *hp_end; + ErtsProcLocks locks = (ErtsProcLocks) 0; + int res_len, ix; + Process *rp = NULL; + + *fail_type = ERTS_PI_FAIL_TYPE_BADARG; + + for (ix = 0; ix < ERTS_PI_ARGS; ix++) + part_res[ix] = THE_NON_VALUE; + + ASSERT(is_list(list)); + + while (is_list(list)) { + Eterm* consp = list_val(list); + + arg = CAR(consp); + ix = pi_arg2ix(arg); + if (ix < 0) { + res = THE_NON_VALUE; + goto done; + } + if (arg == am_messages) + want_messages = 1; + locks |= pi_locks(arg); + res_elem_ix_ix++; + if (res_elem_ix_ix >= res_elem_ix_sz) { + if (res_elem_ix != &def_res_elem_ix_buf[0]) + res_elem_ix = + erts_realloc(ERTS_ALC_T_TMP, + res_elem_ix, + sizeof(int)*(res_elem_ix_sz + += ERTS_PI_RES_ELEM_IX_BUF_INC)); + else { + int new_res_elem_ix_sz = ERTS_PI_RES_ELEM_IX_BUF_INC; + int *new_res_elem_ix = erts_alloc(ERTS_ALC_T_TMP, + sizeof(int)*new_res_elem_ix_sz); + sys_memcpy((void *) new_res_elem_ix, + (void *) res_elem_ix, + sizeof(int)*res_elem_ix_sz); + res_elem_ix = new_res_elem_ix; + res_elem_ix_sz = new_res_elem_ix_sz; + } + } + res_elem_ix[res_elem_ix_ix] = ix; + list = CDR(consp); + } + if (is_not_nil(list)) { + res = THE_NON_VALUE; + goto done; + } + + res_len = res_elem_ix_ix+1; + + ASSERT(res_len > 0); + + rp = pi_pid2proc(c_p, pid, locks|ERTS_PROC_LOCK_STATUS); + if (!rp) { + res = am_undefined; + goto done; + } + else if (rp == ERTS_PROC_LOCK_BUSY) { + rp = NULL; + res = THE_NON_VALUE; + *fail_type = ERTS_PI_FAIL_TYPE_YIELD; + goto done; + } + else if (c_p != rp && ERTS_PROC_PENDING_EXIT(rp)) { + locks |= ERTS_PROC_LOCK_STATUS; + res = THE_NON_VALUE; + *fail_type = ERTS_PI_FAIL_TYPE_AWAIT_EXIT; + goto done; + } + else if (!(locks & ERTS_PROC_LOCK_STATUS)) { + erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_STATUS); + } + + + /* + * We always handle 'messages' first if it should be part + * of the result. This since if both 'messages' and + * 'message_queue_len' are wanted, 'messages' may + * change the result of 'message_queue_len' (in case + * the queue contain bad distribution messages). + */ + if (want_messages) { + ix = pi_arg2ix(am_messages); + ASSERT(part_res[ix] == THE_NON_VALUE); + part_res[ix] = process_info_aux(c_p, rp, pid, am_messages, always_wrap); + ASSERT(part_res[ix] != THE_NON_VALUE); + } + + for (; res_elem_ix_ix >= 0; res_elem_ix_ix--) { + ix = res_elem_ix[res_elem_ix_ix]; + if (part_res[ix] == THE_NON_VALUE) { + arg = pi_ix2arg(ix); + part_res[ix] = process_info_aux(c_p, rp, pid, arg, always_wrap); + ASSERT(part_res[ix] != THE_NON_VALUE); + } + } + + hp = HAlloc(c_p, res_len*2); + hp_end = hp + res_len*2; + res = NIL; + + for (res_elem_ix_ix = res_len - 1; res_elem_ix_ix >= 0; res_elem_ix_ix--) { + ix = res_elem_ix[res_elem_ix_ix]; + ASSERT(part_res[ix] != THE_NON_VALUE); + /* + * If we should ignore the value of registered_name, + * its value is nil. For more info, see comment in the + * beginning of process_info_aux(). + */ + if (is_nil(part_res[ix])) { + ASSERT(!always_wrap); + ASSERT(pi_ix2arg(ix) == am_registered_name); + } + else { + res = CONS(hp, part_res[ix], res); + hp += 2; + } + } + + if (!always_wrap) { + HRelease(c_p, hp_end, hp); + } + + done: + + if (c_p == rp) + locks &= ~ERTS_PROC_LOCK_MAIN; + if (locks && rp) + erts_smp_proc_unlock(rp, locks); + + if (res_elem_ix != &def_res_elem_ix_buf[0]) + erts_free(ERTS_ALC_T_TMP, res_elem_ix); + + return res; +} + +BIF_RETTYPE process_info_1(BIF_ALIST_1) +{ + Eterm res; + int fail_type; + + if (is_external_pid(BIF_ARG_1) + && external_pid_dist_entry(BIF_ARG_1) == erts_this_dist_entry) + BIF_RET(am_undefined); + + if (is_not_internal_pid(BIF_ARG_1) + || internal_pid_index(BIF_ARG_1) >= erts_max_processes) { + BIF_ERROR(BIF_P, BADARG); + } + + res = process_info_list(BIF_P, BIF_ARG_1, pi_1_keys_list, 0, &fail_type); + if (is_non_value(res)) { + switch (fail_type) { + case ERTS_PI_FAIL_TYPE_BADARG: + BIF_ERROR(BIF_P, BADARG); + case ERTS_PI_FAIL_TYPE_YIELD: + ERTS_BIF_YIELD1(bif_export[BIF_process_info_1], BIF_P, BIF_ARG_1); + case ERTS_PI_FAIL_TYPE_AWAIT_EXIT: + ERTS_BIF_AWAIT_X_DATA_TRAP(BIF_P, BIF_ARG_1, am_undefined); + default: + erl_exit(ERTS_ABORT_EXIT, "%s:%d: Internal error", __FILE__, __LINE__); + } + } + + ASSERT(!(BIF_P->flags & F_P2PNR_RESCHED)); + BIF_RET(res); +} + + +BIF_RETTYPE process_info_2(BIF_ALIST_2) +{ + Eterm res; + Process *rp; + Eterm pid = BIF_ARG_1; + ErtsProcLocks info_locks; + int fail_type; + + if (is_external_pid(pid) + && external_pid_dist_entry(pid) == erts_this_dist_entry) + BIF_RET(am_undefined); + + if (is_not_internal_pid(pid) + || internal_pid_index(BIF_ARG_1) >= erts_max_processes) { + BIF_ERROR(BIF_P, BADARG); + } + + if (is_nil(BIF_ARG_2)) + BIF_RET(NIL); + + if (is_list(BIF_ARG_2)) { + res = process_info_list(BIF_P, BIF_ARG_1, BIF_ARG_2, 1, &fail_type); + if (is_non_value(res)) { + switch (fail_type) { + case ERTS_PI_FAIL_TYPE_BADARG: + BIF_ERROR(BIF_P, BADARG); + case ERTS_PI_FAIL_TYPE_YIELD: + ERTS_BIF_YIELD2(bif_export[BIF_process_info_2], BIF_P, + BIF_ARG_1, BIF_ARG_2); + case ERTS_PI_FAIL_TYPE_AWAIT_EXIT: + ERTS_BIF_AWAIT_X_DATA_TRAP(BIF_P, BIF_ARG_1, am_undefined); + default: + erl_exit(ERTS_ABORT_EXIT, "%s:%d: Internal error", + __FILE__, __LINE__); + } + } + ASSERT(!(BIF_P->flags & F_P2PNR_RESCHED)); + BIF_RET(res); + } + + if (pi_arg2ix(BIF_ARG_2) < 0) + BIF_ERROR(BIF_P, BADARG); + + info_locks = pi_locks(BIF_ARG_2); + + rp = pi_pid2proc(BIF_P, pid, info_locks|ERTS_PROC_LOCK_STATUS); + if (!rp) + res = am_undefined; + else if (rp == ERTS_PROC_LOCK_BUSY) + ERTS_BIF_YIELD2(bif_export[BIF_process_info_2], BIF_P, + BIF_ARG_1, BIF_ARG_2); + else if (rp != BIF_P && ERTS_PROC_PENDING_EXIT(rp)) { + erts_smp_proc_unlock(rp, info_locks|ERTS_PROC_LOCK_STATUS); + ERTS_BIF_AWAIT_X_DATA_TRAP(BIF_P, BIF_ARG_1, am_undefined); + } + else { + if (!(info_locks & ERTS_PROC_LOCK_STATUS)) + erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_STATUS); + res = process_info_aux(BIF_P, rp, pid, BIF_ARG_2, 0); + } + ASSERT(is_value(res)); + +#ifdef ERTS_SMP + if (BIF_P == rp) + info_locks &= ~ERTS_PROC_LOCK_MAIN; + if (rp && info_locks) + erts_smp_proc_unlock(rp, info_locks); +#endif + + ASSERT(!(BIF_P->flags & F_P2PNR_RESCHED)); + BIF_RET(res); +} + +Eterm +process_info_aux(Process *BIF_P, + Process *rp, + Eterm rpid, + Eterm item, + int always_wrap) +{ + Eterm *hp; + Eterm res = NIL; + + ASSERT(rp); + + /* + * Q: Why this always_wrap argument? + * + * A: registered_name is strange. If process has no registered name, + * process_info(Pid, registered_name) returns [], and + * the result of process_info(Pid) has no {registered_name, Name} + * tuple in the resulting list. This is inconsistent with all other + * options, but we do not dare to change it. + * + * When process_info/2 is called with a list as second argument, + * registered_name behaves as it should, i.e. a + * {registered_name, []} will appear in the resulting list. + * + * If always_wrap != 0, process_info_aux() always wrap the result + * in a key two tuple. + */ + + switch (item) { + + case am_registered_name: + if (rp->reg != NULL) { + hp = HAlloc(BIF_P, 3); + res = rp->reg->name; + } else { + if (always_wrap) { + hp = HAlloc(BIF_P, 3); + res = NIL; + } + else { + return NIL; + } + } + break; + + case am_current_function: + if (rp->current == NULL) { + rp->current = find_function_from_pc(rp->i); + } + if (rp->current == NULL) { + hp = HAlloc(BIF_P, 3); + res = am_undefined; + } else { + Eterm* current; + + if (rp->current[0] == am_erlang && + rp->current[1] == am_process_info && + (rp->current[2] == 1 || rp->current[2] == 2) && + (current = find_function_from_pc(rp->cp)) != NULL) { + + /* + * The current function is erlang:process_info/2, + * which is not the answer that the application want. + * We will use the function pointed into by rp->cp + * instead. + */ + + rp->current = current; + } + + hp = HAlloc(BIF_P, 3+4); + res = TUPLE3(hp, rp->current[0], + rp->current[1], make_small(rp->current[2])); + hp += 4; + } + break; + + case am_initial_call: + hp = HAlloc(BIF_P, 3+4); + res = TUPLE3(hp, + rp->initial[INITIAL_MOD], + rp->initial[INITIAL_FUN], + make_small(rp->initial[INITIAL_ARI])); + hp += 4; + break; + + case am_status: + res = erts_process_status(BIF_P, ERTS_PROC_LOCK_MAIN, rp, rpid); + ASSERT(res != am_undefined); + hp = HAlloc(BIF_P, 3); + break; + + case am_messages: { + ErlMessage* mp; + int n; + + ERTS_SMP_MSGQ_MV_INQ2PRIVQ(rp); + n = rp->msg.len; + + if (n == 0 || rp->trace_flags & F_SENSITIVE) { + hp = HAlloc(BIF_P, 3); + } else { + int remove_bad_messages = 0; + struct { + Uint copy_struct_size; + ErlMessage* msgp; + } *mq = erts_alloc(ERTS_ALC_T_TMP, n*sizeof(*mq)); + Sint i = 0; + Uint heap_need = 3; + Eterm *hp_end; + + for (mp = rp->msg.first; mp; mp = mp->next) { + heap_need += 2; + mq[i].msgp = mp; + if (rp != BIF_P) { + Eterm msg = ERL_MESSAGE_TERM(mq[i].msgp); + if (is_value(msg)) { + mq[i].copy_struct_size = (is_immed(msg) +#ifdef HYBRID + || NO_COPY(msg) +#endif + ? 0 + : size_object(msg)); + } + else if (mq[i].msgp->data.attached) { + mq[i].copy_struct_size + = erts_msg_attached_data_size(mq[i].msgp); + } + else { + /* Bad distribution message; ignore */ + remove_bad_messages = 1; + mq[i].copy_struct_size = 0; + } + heap_need += mq[i].copy_struct_size; + } + else { + mq[i].copy_struct_size = 0; + if (mp->data.attached) + heap_need += erts_msg_attached_data_size(mp); + } + i++; + } + + hp = HAlloc(BIF_P, heap_need); + hp_end = hp + heap_need; + ASSERT(i == n); + for (i--; i >= 0; i--) { + Eterm msg = ERL_MESSAGE_TERM(mq[i].msgp); + if (rp != BIF_P) { + if (is_value(msg)) { + if (mq[i].copy_struct_size) + msg = copy_struct(msg, + mq[i].copy_struct_size, + &hp, + &MSO(BIF_P)); + } + else if (mq[i].msgp->data.attached) { + ErlHeapFragment *hfp; + /* + * Decode it into a message buffer and attach it + * to the message instead of the attached external + * term. + * + * Note that we may not pass a process pointer + * to erts_msg_distext2heap(), since it would then + * try to alter locks on that process. + */ + msg = erts_msg_distext2heap( + NULL, NULL, &hfp, &ERL_MESSAGE_TOKEN(mq[i].msgp), + mq[i].msgp->data.dist_ext); + + ERL_MESSAGE_TERM(mq[i].msgp) = msg; + mq[i].msgp->data.heap_frag = hfp; + + if (is_non_value(msg)) { + ASSERT(!mq[i].msgp->data.heap_frag); + /* Bad distribution message; ignore */ + remove_bad_messages = 1; + continue; + } + else { + /* Make our copy of the message */ + ASSERT(size_object(msg) == hfp->size); + msg = copy_struct(msg, + hfp->size, + &hp, + &MSO(BIF_P)); + } + } + else { + /* Bad distribution message; ignore */ + remove_bad_messages = 1; + continue; + } + } + else { + if (mq[i].msgp->data.attached) { + /* Decode it on the heap */ + erts_move_msg_attached_data_to_heap(&hp, + &MSO(BIF_P), + mq[i].msgp); + msg = ERL_MESSAGE_TERM(mq[i].msgp); + ASSERT(!mq[i].msgp->data.attached); + if (is_non_value(msg)) { + /* Bad distribution message; ignore */ + remove_bad_messages = 1; + continue; + } + } + } + + res = CONS(hp, msg, res); + hp += 2; + } + HRelease(BIF_P, hp_end, hp+3); + erts_free(ERTS_ALC_T_TMP, mq); + if (remove_bad_messages) { + ErlMessage **mpp; + /* + * We need to remove bad distribution messages from + * the queue, so that the value returned for + * 'message_queue_len' is consistent with the value + * returned for 'messages'. + */ + mpp = &rp->msg.first; + mp = rp->msg.first; + while (mp) { + if (is_value(ERL_MESSAGE_TERM(mp))) { + mpp = &mp->next; + mp = mp->next; + } + else { + ErlMessage* bad_mp = mp; + ASSERT(!mp->data.attached); + if (rp->msg.save == &mp->next) + rp->msg.save = mpp; + if (rp->msg.last == &mp->next) + rp->msg.last = mpp; + *mpp = mp->next; + mp = mp->next; + rp->msg.len--; + free_message(bad_mp); + } + } + } + } + break; + } + + case am_message_queue_len: + hp = HAlloc(BIF_P, 3); + ERTS_SMP_MSGQ_MV_INQ2PRIVQ(rp); + res = make_small(rp->msg.len); + break; + + case am_links: { + MonitorInfoCollection mic; + int i; + Eterm item; + + INIT_MONITOR_INFOS(mic); + + erts_doforall_links(rp->nlinks,&collect_one_link,&mic); + + hp = HAlloc(BIF_P, 3 + mic.sz); + res = NIL; + for (i = 0; i < mic.mi_i; i++) { + item = STORE_NC(&hp, &MSO(BIF_P).externals, mic.mi[i].entity); + res = CONS(hp, item, res); + hp += 2; + } + DESTROY_MONITOR_INFOS(mic); + break; + } + + case am_monitors: { + MonitorInfoCollection mic; + int i; + + INIT_MONITOR_INFOS(mic); + erts_doforall_monitors(rp->monitors,&collect_one_origin_monitor,&mic); + hp = HAlloc(BIF_P, 3 + mic.sz); + res = NIL; + for (i = 0; i < mic.mi_i; i++) { + if (is_atom(mic.mi[i].entity)) { + /* Monitor by name. + * Build {process, {Name, Node}} and cons it. + */ + Eterm t1, t2; + + t1 = TUPLE2(hp, mic.mi[i].entity, mic.mi[i].node); + hp += 3; + t2 = TUPLE2(hp, am_process, t1); + hp += 3; + res = CONS(hp, t2, res); + hp += 2; + } + else { + /* Monitor by pid. Build {process, Pid} and cons it. */ + Eterm t; + Eterm pid = STORE_NC(&hp, + &MSO(BIF_P).externals, + mic.mi[i].entity); + t = TUPLE2(hp, am_process, pid); + hp += 3; + res = CONS(hp, t, res); + hp += 2; + } + } + DESTROY_MONITOR_INFOS(mic); + break; + } + + case am_monitored_by: { + MonitorInfoCollection mic; + int i; + Eterm item; + + INIT_MONITOR_INFOS(mic); + erts_doforall_monitors(rp->monitors,&collect_one_target_monitor,&mic); + hp = HAlloc(BIF_P, 3 + mic.sz); + + res = NIL; + for (i = 0; i < mic.mi_i; ++i) { + item = STORE_NC(&hp, &MSO(BIF_P).externals, mic.mi[i].entity); + res = CONS(hp, item, res); + hp += 2; + } + DESTROY_MONITOR_INFOS(mic); + break; + } + + case am_suspending: { + ErtsSuspendMonitorInfoCollection smic; + int i; + Eterm item; +#ifdef DEBUG + Eterm *hp_end; +#endif + + ERTS_INIT_SUSPEND_MONITOR_INFOS(smic, + BIF_P, + (BIF_P == rp + ? ERTS_PROC_LOCK_MAIN + : 0) | ERTS_PROC_LOCK_LINK); + + erts_doforall_suspend_monitors(rp->suspend_monitors, + &collect_one_suspend_monitor, + &smic); + hp = HAlloc(BIF_P, 3 + smic.sz); +#ifdef DEBUG + hp_end = hp + smic.sz; +#endif + + res = NIL; + for (i = 0; i < smic.smi_i; i++) { + Sint a = (Sint) smic.smi[i]->active; /* quiet compiler warnings */ + Sint p = (Sint) smic.smi[i]->pending; /* on 64-bit machines... */ + Eterm active; + Eterm pending; + if (IS_SSMALL(a)) + active = make_small(a); + else { + active = small_to_big(a, hp); + hp += BIG_UINT_HEAP_SIZE; + } + if (IS_SSMALL(p)) + pending = make_small(p); + else { + pending = small_to_big(p, hp); + hp += BIG_UINT_HEAP_SIZE; + } + item = TUPLE3(hp, smic.smi[i]->pid, active, pending); + hp += 4; + res = CONS(hp, item, res); + hp += 2; + } + + ERTS_DESTROY_SUSPEND_MONITOR_INFOS(smic); + ASSERT(hp == hp_end); + + break; + } + + case am_dictionary: + if (rp->trace_flags & F_SENSITIVE) { + res = NIL; + } else { + res = erts_dictionary_copy(BIF_P, rp->dictionary); + } + hp = HAlloc(BIF_P, 3); + break; + + case am_trap_exit: + hp = HAlloc(BIF_P, 3); + if (rp->flags & F_TRAPEXIT) + res = am_true; + else + res = am_false; + break; + + case am_error_handler: + hp = HAlloc(BIF_P, 3); + res = erts_proc_get_error_handler(BIF_P); + break; + + case am_heap_size: { + Uint hsz = 3; + (void) erts_bld_uint(NULL, &hsz, HEAP_SIZE(rp)); + hp = HAlloc(BIF_P, hsz); + res = erts_bld_uint(&hp, NULL, HEAP_SIZE(rp)); + break; + } + + case am_total_heap_size: { + ErlMessage *mp; + Uint total_heap_size; + Uint hsz = 3; + + total_heap_size = rp->heap_sz; + if (rp->old_hend && rp->old_heap) + total_heap_size += rp->old_hend - rp->old_heap; + + total_heap_size += rp->mbuf_sz; + + ERTS_SMP_MSGQ_MV_INQ2PRIVQ(rp); + + for (mp = rp->msg.first; mp; mp = mp->next) + if (mp->data.attached) + total_heap_size += erts_msg_attached_data_size(mp); + + (void) erts_bld_uint(NULL, &hsz, total_heap_size); + hp = HAlloc(BIF_P, hsz); + res = erts_bld_uint(&hp, NULL, total_heap_size); + break; + } + + case am_stack_size: { + Uint stack_size = STACK_START(rp) - rp->stop; + Uint hsz = 3; + (void) erts_bld_uint(NULL, &hsz, stack_size); + hp = HAlloc(BIF_P, hsz); + res = erts_bld_uint(&hp, NULL, stack_size); + break; + } + + case am_memory: { /* Memory consumed in bytes */ + ErlMessage *mp; + Uint size = 0; + Uint hsz = 3; + struct saved_calls *scb; + size += sizeof(Process); + + ERTS_SMP_MSGQ_MV_INQ2PRIVQ(rp); + + erts_doforall_links(rp->nlinks, &one_link_size, &size); + erts_doforall_monitors(rp->monitors, &one_mon_size, &size); + size += (rp->heap_sz + rp->mbuf_sz) * sizeof(Eterm); + if (rp->old_hend && rp->old_heap) + size += (rp->old_hend - rp->old_heap) * sizeof(Eterm); + + size += rp->msg.len * sizeof(ErlMessage); + + for (mp = rp->msg.first; mp; mp = mp->next) + if (mp->data.attached) + size += erts_msg_attached_data_size(mp)*sizeof(Eterm); + + if (rp->arg_reg != rp->def_arg_reg) { + size += rp->arity * sizeof(rp->arg_reg[0]); + } + + if (rp->psd) + size += sizeof(ErtsPSD); + + scb = ERTS_PROC_GET_SAVED_CALLS_BUF(rp); + if (scb) { + size += (sizeof(struct saved_calls) + + (scb->len-1) * sizeof(scb->ct[0])); + } + + size += erts_dicts_mem_size(rp); + + (void) erts_bld_uint(NULL, &hsz, size); + hp = HAlloc(BIF_P, hsz); + res = erts_bld_uint(&hp, NULL, size); + break; + } + + case am_garbage_collection: { + DECL_AM(minor_gcs); + Eterm t; + + hp = HAlloc(BIF_P, 3+2+3+2+3); + t = TUPLE2(hp, AM_minor_gcs, make_small(GEN_GCS(rp))); + hp += 3; + res = CONS(hp, t, NIL); + hp += 2; + t = TUPLE2(hp, am_fullsweep_after, make_small(MAX_GEN_GCS(rp))); + hp += 3; + res = CONS(hp, t, res); + hp += 2; + break; + } + + case am_group_leader: { + int sz = NC_HEAP_SIZE(rp->group_leader); + hp = HAlloc(BIF_P, 3 + sz); + res = STORE_NC(&hp, &MSO(BIF_P).externals, rp->group_leader); + break; + } + + case am_reductions: { + Uint reds = rp->reds + erts_current_reductions(BIF_P, rp); + Uint hsz = 3; + (void) erts_bld_uint(NULL, &hsz, reds); + hp = HAlloc(BIF_P, hsz); + res = erts_bld_uint(&hp, NULL, reds); + break; + } + + case am_priority: + hp = HAlloc(BIF_P, 3); + res = erts_get_process_priority(rp); + break; + + case am_trace: + hp = HAlloc(BIF_P, 3); + res = make_small(rp->trace_flags & TRACEE_FLAGS); + break; + + case am_binary: { + Uint sz = 3; + (void) bld_bin_list(NULL, &sz, MSO(rp).mso); + hp = HAlloc(BIF_P, sz); + res = bld_bin_list(&hp, NULL, MSO(rp).mso); + break; + } + +#ifdef HYBRID + case am_message_binary: { + Uint sz = 3; + (void) bld_bin_list(NULL, &sz, erts_global_offheap.mso); + hp = HAlloc(BIF_P, sz); + res = bld_bin_list(&hp, NULL, erts_global_offheap.mso); + break; + } +#endif + + case am_sequential_trace_token: + res = copy_object(rp->seq_trace_token, BIF_P); + hp = HAlloc(BIF_P, 3); + break; + + case am_catchlevel: + hp = HAlloc(BIF_P, 3); + res = make_small(catchlevel(BIF_P)); + break; + + case am_backtrace: { + erts_dsprintf_buf_t *dsbufp = erts_create_tmp_dsbuf(0); + erts_stack_dump(ERTS_PRINT_DSBUF, (void *) dsbufp, rp); + res = new_binary(BIF_P, (byte *) dsbufp->str, (int) dsbufp->str_len); + erts_destroy_tmp_dsbuf(dsbufp); + hp = HAlloc(BIF_P, 3); + break; + } + + case am_last_calls: { + struct saved_calls *scb = ERTS_PROC_GET_SAVED_CALLS_BUF(BIF_P); + if (!scb) { + hp = HAlloc(BIF_P, 3); + res = am_false; + } else { + /* + * One cons cell and a 3-struct, and a 2-tuple. + * Might be less than that, if there are sends, receives or timeouts, + * so we must do a HRelease() to avoid creating holes. + */ + Uint needed = scb->n*(2+4) + 3; + Eterm* limit; + Eterm term, list; + int i, j; + + hp = HAlloc(BIF_P, needed); + limit = hp + needed; + list = NIL; + for (i = 0; i < scb->n; i++) { + j = scb->cur - i - 1; + if (j < 0) + j += scb->len; + if (scb->ct[j] == &exp_send) + term = am_send; + else if (scb->ct[j] == &exp_receive) + term = am_receive; + else if (scb->ct[j] == &exp_timeout) + term = am_timeout; + else { + term = TUPLE3(hp, + scb->ct[j]->code[0], + scb->ct[j]->code[1], + make_small(scb->ct[j]->code[2])); + hp += 4; + } + list = CONS(hp, term, list); + hp += 2; + } + res = list; + res = TUPLE2(hp, item, res); + hp += 3; + HRelease(BIF_P,limit,hp); + return res; + } + break; + } + + default: + return THE_NON_VALUE; /* will produce badarg */ + + } + + return TUPLE2(hp, item, res); +} +#undef MI_INC + +#if defined(VALGRIND) +static int check_if_xml(void) +{ + char buf[1]; + size_t bufsz = sizeof(buf); + return erts_sys_getenv("VALGRIND_LOG_XML", buf, &bufsz) >= 0; +} +#else +#define check_if_xml() 0 +#endif + +/* + * This function takes care of calls to erlang:system_info/1 when the argument + * is a tuple. + */ +static BIF_RETTYPE +info_1_tuple(Process* BIF_P, /* Pointer to current process. */ + Eterm* tp, /* Pointer to first element in tuple */ + int arity) /* Arity of tuple (untagged). */ +{ + Eterm ret; + Eterm sel; + + sel = *tp++; + + if (sel == am_allocator_sizes && arity == 2) { + return erts_allocator_info_term(BIF_P, *tp, 1); + } else if (sel == am_allocated) { + if (arity == 2) { + Eterm res = THE_NON_VALUE; + char *buf; + int len = is_string(*tp); + if (len <= 0) + return res; + buf = (char *) erts_alloc(ERTS_ALC_T_TMP, len+1); + if (intlist_to_buf(*tp, buf, len) != len) + erl_exit(1, "%s:%d: Internal error\n", __FILE__, __LINE__); + buf[len] = '\0'; + res = erts_instr_dump_memory_map(buf) ? am_true : am_false; + erts_free(ERTS_ALC_T_TMP, (void *) buf); + if (is_non_value(res)) + goto badarg; + return res; + } + else if (arity == 3 && tp[0] == am_status) { + if (is_atom(tp[1])) + return erts_instr_get_stat(BIF_P, tp[1], 1); + else { + Eterm res = THE_NON_VALUE; + char *buf; + int len = is_string(tp[1]); + if (len <= 0) + return res; + buf = (char *) erts_alloc(ERTS_ALC_T_TMP, len+1); + if (intlist_to_buf(tp[1], buf, len) != len) + erl_exit(1, "%s:%d: Internal error\n", __FILE__, __LINE__); + buf[len] = '\0'; + res = erts_instr_dump_stat(buf, 1) ? am_true : am_false; + erts_free(ERTS_ALC_T_TMP, (void *) buf); + if (is_non_value(res)) + goto badarg; + return res; + } + } + else + goto badarg; + } else if (sel == am_allocator && arity == 2) { + return erts_allocator_info_term(BIF_P, *tp, 0); + } else if (ERTS_IS_ATOM_STR("internal_cpu_topology", sel) && arity == 2) { + return erts_get_cpu_topology_term(BIF_P, *tp); + } else if (ERTS_IS_ATOM_STR("cpu_topology", sel) && arity == 2) { + Eterm res = erts_get_cpu_topology_term(BIF_P, *tp); + ERTS_BIF_PREP_TRAP1(ret, erts_format_cpu_topology_trap, BIF_P, res); + return ret; +#if defined(PURIFY) || defined(VALGRIND) + } else if (ERTS_IS_ATOM_STR("error_checker", sel) +#if defined(PURIFY) + || sel == am_purify +#elif defined(VALGRIND) + || ERTS_IS_ATOM_STR("valgrind", sel) +#endif + ) { + if (*tp == am_memory) { +#if defined(PURIFY) + BIF_RET(erts_make_integer(purify_new_leaks(), BIF_P)); +#elif defined(VALGRIND) + VALGRIND_DO_LEAK_CHECK; + BIF_RET(make_small(0)); +#endif + } else if (*tp == am_fd) { +#if defined(PURIFY) + BIF_RET(erts_make_integer(purify_new_fds_inuse(), BIF_P)); +#elif defined(VALGRIND) + /* Not present in valgrind... */ + BIF_RET(make_small(0)); +#endif + } else if (*tp == am_running) { +#if defined(PURIFY) + BIF_RET(purify_is_running() ? am_true : am_false); +#elif defined(VALGRIND) + BIF_RET(RUNNING_ON_VALGRIND ? am_true : am_false); +#endif + } else if (is_list(*tp)) { +#if defined(PURIFY) +#define ERTS_ERROR_CHECKER_PRINTF purify_printf +#elif defined(VALGRIND) +#define ERTS_ERROR_CHECKER_PRINTF VALGRIND_PRINTF +#endif + int buf_size = 8*1024; /* Try with 8KB first */ + char *buf = erts_alloc(ERTS_ALC_T_TMP, buf_size); + int r = io_list_to_buf(*tp, (char*) buf, buf_size - 1); + if (r < 0) { + erts_free(ERTS_ALC_T_TMP, (void *) buf); + buf_size = io_list_len(*tp); + if (buf_size < 0) + goto badarg; + buf_size++; + buf = erts_alloc(ERTS_ALC_T_TMP, buf_size); + r = io_list_to_buf(*tp, (char*) buf, buf_size - 1); + ASSERT(r == buf_size - 1); + } + buf[buf_size - 1 - r] = '\0'; + if (check_if_xml()) { + ERTS_ERROR_CHECKER_PRINTF("" + "%s\n", buf); + } else { + ERTS_ERROR_CHECKER_PRINTF("%s\n", buf); + } + erts_free(ERTS_ALC_T_TMP, (void *) buf); + BIF_RET(am_true); +#undef ERTS_ERROR_CHECKER_PRINTF + } +#endif +#ifdef QUANTIFY + } else if (sel == am_quantify) { + if (*tp == am_clear) { + quantify_clear_data(); + BIF_RET(am_true); + } else if (*tp == am_start) { + quantify_start_recording_data(); + BIF_RET(am_true); + } else if (*tp == am_stop) { + quantify_stop_recording_data(); + BIF_RET(am_true); + } else if (*tp == am_running) { + BIF_RET(quantify_is_running() ? am_true : am_false); + } +#endif +#if defined(__GNUC__) && defined(HAVE_SOLARIS_SPARC_PERFMON) + } else if (ERTS_IS_ATOM_STR("ultrasparc_set_pcr", sel)) { + unsigned long long tmp; + int fd; + int rc; + + if (arity != 2 || !is_small(*tp)) { + goto badarg; + } + tmp = signed_val(*tp); + if ((fd = open("/dev/perfmon", O_RDONLY)) == -1) { + BIF_RET(am_false); + } + rc = ioctl(fd, PERFMON_SETPCR, &tmp); + close(fd); + if (rc < 0) { + BIF_RET(am_false); + } + BIF_RET(am_true); +#endif + } + + badarg: + ERTS_BIF_PREP_ERROR(ret, BIF_P, BADARG); + + return ret; +} + +#define INFO_DSBUF_INC_SZ 256 + +static erts_dsprintf_buf_t * +grow_info_dsbuf(erts_dsprintf_buf_t *dsbufp, size_t need) +{ + size_t size; + size_t free_size = dsbufp->size - dsbufp->str_len; + + ASSERT(dsbufp); + + if (need <= free_size) + return dsbufp; + size = need - free_size + INFO_DSBUF_INC_SZ; + size = ((size + INFO_DSBUF_INC_SZ - 1)/INFO_DSBUF_INC_SZ)*INFO_DSBUF_INC_SZ; + size += dsbufp->size; + ASSERT(dsbufp->str_len + need <= size); + dsbufp->str = (char *) erts_realloc(ERTS_ALC_T_INFO_DSBUF, + (void *) dsbufp->str, + size); + dsbufp->size = size; + return dsbufp; +} + +static erts_dsprintf_buf_t * +erts_create_info_dsbuf(Uint size) +{ + Uint init_size = size ? size : INFO_DSBUF_INC_SZ; + erts_dsprintf_buf_t init = ERTS_DSPRINTF_BUF_INITER(grow_info_dsbuf); + erts_dsprintf_buf_t *dsbufp = erts_alloc(ERTS_ALC_T_INFO_DSBUF, + sizeof(erts_dsprintf_buf_t)); + sys_memcpy((void *) dsbufp, (void *) &init, sizeof(erts_dsprintf_buf_t)); + dsbufp->str = (char *) erts_alloc(ERTS_ALC_T_INFO_DSBUF, init_size); + dsbufp->str[0] = '\0'; + dsbufp->size = init_size; + return dsbufp; +} + +static void +erts_destroy_info_dsbuf(erts_dsprintf_buf_t *dsbufp) +{ + if (dsbufp->str) + erts_free(ERTS_ALC_T_INFO_DSBUF, (void *) dsbufp->str); + erts_free(ERTS_ALC_T_INFO_DSBUF, (void *) dsbufp); +} + +static Eterm +c_compiler_used(Eterm **hpp, Uint *szp) +{ + +#if defined(__GNUC__) +# if defined(__GNUC_MINOR__) && defined(__GNUC_PATCHLEVEL__) +# define ERTS_GNUC_VSN_NUMS 3 +# elif defined(__GNUC_MINOR__) +# define ERTS_GNUC_VSN_NUMS 2 +# else +# define ERTS_GNUC_VSN_NUMS 1 +# endif + return erts_bld_tuple(hpp, + szp, + 2, + erts_bld_atom(hpp, szp, "gnuc"), +#if ERTS_GNUC_VSN_NUMS > 1 + erts_bld_tuple(hpp, + szp, + ERTS_GNUC_VSN_NUMS, +#endif + erts_bld_uint(hpp, szp, + (Uint) __GNUC__) +#ifdef __GNUC_MINOR__ + , + erts_bld_uint(hpp, szp, + (Uint) __GNUC_MINOR__) +#ifdef __GNUC_PATCHLEVEL__ + , + erts_bld_uint(hpp, szp, + (Uint) __GNUC_PATCHLEVEL__) +#endif +#endif +#if ERTS_GNUC_VSN_NUMS > 1 + ) +#endif + ); + +#elif defined(_MSC_VER) + return erts_bld_tuple(hpp, + szp, + 2, + erts_bld_atom(hpp, szp, "msc"), + erts_bld_uint(hpp, szp, (Uint) _MSC_VER)); + +#else + return erts_bld_tuple(hpp, + szp, + 2, + am_undefined, + am_undefined); +#endif + +} + +BIF_RETTYPE system_info_1(BIF_ALIST_1) +{ + Eterm res; + Eterm* hp; + Eterm val; + int i; + + if (is_tuple(BIF_ARG_1)) { + Eterm* tp = tuple_val(BIF_ARG_1); + Uint arity = *tp++; + return info_1_tuple(BIF_P, tp, arityval(arity)); + } else if (BIF_ARG_1 == am_scheduler_id) { +#ifdef ERTS_SMP + ASSERT(BIF_P->scheduler_data); + BIF_RET(make_small(BIF_P->scheduler_data->no)); +#else + BIF_RET(make_small(1)); +#endif + } else if (BIF_ARG_1 == am_compat_rel) { + ASSERT(erts_compat_rel > 0); + BIF_RET(make_small(erts_compat_rel)); + } else if (BIF_ARG_1 == am_multi_scheduling) { +#ifndef ERTS_SMP + BIF_RET(am_disabled); +#else + if (erts_no_schedulers == 1) + BIF_RET(am_disabled); + else { + BIF_RET(erts_is_multi_scheduling_blocked() + ? am_blocked + : am_enabled); + } +#endif + } else if (BIF_ARG_1 == am_allocated_areas) { + res = erts_allocated_areas(NULL, NULL, BIF_P); + BIF_RET(res); + } else if (BIF_ARG_1 == am_allocated) { + BIF_RET(erts_instr_get_memory_map(BIF_P)); + } else if (BIF_ARG_1 == am_hipe_architecture) { +#if defined(HIPE) + BIF_RET(hipe_arch_name); +#else + BIF_RET(am_undefined); +#endif + } else if (BIF_ARG_1 == am_trace_control_word) { + BIF_RET(db_get_trace_control_word_0(BIF_P)); + } else if (ERTS_IS_ATOM_STR("ets_realloc_moves", BIF_ARG_1)) { + BIF_RET((erts_ets_realloc_always_moves) ? am_true : am_false); + } else if (BIF_ARG_1 == am_sequential_tracer) { + val = erts_get_system_seq_tracer(); + ASSERT(is_internal_pid(val) || is_internal_port(val) || val==am_false) + hp = HAlloc(BIF_P, 3); + res = TUPLE2(hp, am_sequential_tracer, val); + BIF_RET(res); + } else if (BIF_ARG_1 == am_garbage_collection){ + Uint val = (Uint) erts_smp_atomic_read(&erts_max_gen_gcs); + hp = HAlloc(BIF_P, 3+2); + res = TUPLE2(hp, am_fullsweep_after, make_small(val)); + hp += 3; + res = CONS(hp, res, NIL); + BIF_RET(res); + } else if (BIF_ARG_1 == am_fullsweep_after){ + Uint val = (Uint) erts_smp_atomic_read(&erts_max_gen_gcs); + hp = HAlloc(BIF_P, 3); + res = TUPLE2(hp, am_fullsweep_after, make_small(val)); + BIF_RET(res); + } else if (BIF_ARG_1 == am_process_count) { + BIF_RET(make_small(erts_process_count())); + } else if (BIF_ARG_1 == am_process_limit) { + BIF_RET(make_small(erts_max_processes)); + } else if (BIF_ARG_1 == am_info + || BIF_ARG_1 == am_procs + || BIF_ARG_1 == am_loaded + || BIF_ARG_1 == am_dist) { + erts_dsprintf_buf_t *dsbufp = erts_create_info_dsbuf(0); + + /* Need to be the only thread running... */ + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN); + erts_smp_block_system(0); + + if (BIF_ARG_1 == am_info) + info(ERTS_PRINT_DSBUF, (void *) dsbufp); + else if (BIF_ARG_1 == am_procs) + process_info(ERTS_PRINT_DSBUF, (void *) dsbufp); + else if (BIF_ARG_1 == am_loaded) + loaded(ERTS_PRINT_DSBUF, (void *) dsbufp); + else + distribution_info(ERTS_PRINT_DSBUF, (void *) dsbufp); + + erts_smp_release_system(); + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_MAIN); + + ASSERT(dsbufp && dsbufp->str); + res = new_binary(BIF_P, (byte *) dsbufp->str, (int) dsbufp->str_len); + erts_destroy_info_dsbuf(dsbufp); + BIF_RET(res); + } else if (ERTS_IS_ATOM_STR("dist_ctrl", BIF_ARG_1)) { + DistEntry *dep; + i = 0; + /* Need to be the only thread running... */ + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN); + erts_smp_block_system(0); + for (dep = erts_visible_dist_entries; dep; dep = dep->next) + ++i; + for (dep = erts_hidden_dist_entries; dep; dep = dep->next) + ++i; + hp = HAlloc(BIF_P,i*(3+2)); + res = NIL; + for (dep = erts_hidden_dist_entries; dep; dep = dep->next) { + Eterm tpl; + ASSERT(is_immed(dep->cid)); + tpl = TUPLE2(hp, dep->sysname, dep->cid); + hp +=3; + res = CONS(hp, tpl, res); + hp += 2; + } + for (dep = erts_visible_dist_entries; dep; dep = dep->next) { + Eterm tpl; + ASSERT(is_immed(dep->cid)); + tpl = TUPLE2(hp, dep->sysname, dep->cid); + hp +=3; + res = CONS(hp, tpl, res); + hp += 2; + } + erts_smp_release_system(); + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_MAIN); + BIF_RET(res); + } else if (BIF_ARG_1 == am_system_version) { + erts_dsprintf_buf_t *dsbufp = erts_create_tmp_dsbuf(0); + erts_print_system_version(ERTS_PRINT_DSBUF, (void *) dsbufp, BIF_P); + hp = HAlloc(BIF_P, dsbufp->str_len*2); + res = buf_to_intlist(&hp, dsbufp->str, dsbufp->str_len, NIL); + erts_destroy_tmp_dsbuf(dsbufp); + BIF_RET(res); + } else if (BIF_ARG_1 == am_system_architecture) { + hp = HAlloc(BIF_P, 2*(sizeof(ERLANG_ARCHITECTURE)-1)); + BIF_RET(buf_to_intlist(&hp, + ERLANG_ARCHITECTURE, + sizeof(ERLANG_ARCHITECTURE)-1, + NIL)); + } + else if (BIF_ARG_1 == am_memory_types) { + return erts_instr_get_type_info(BIF_P); + } + else if (BIF_ARG_1 == am_os_type) { + Eterm type = am_atom_put(os_type, strlen(os_type)); + Eterm flav, tup; + char *buf = erts_alloc(ERTS_ALC_T_TMP, 1024); /* More than enough */ + + os_flavor(buf, 1024); + flav = am_atom_put(buf, strlen(buf)); + hp = HAlloc(BIF_P, 3); + tup = TUPLE2(hp, type, flav); + erts_free(ERTS_ALC_T_TMP, (void *) buf); + BIF_RET(tup); + } + else if (BIF_ARG_1 == am_allocator) { + BIF_RET(erts_allocator_options((void *) BIF_P)); + } + else if (BIF_ARG_1 == am_thread_pool_size) { +#ifdef USE_THREADS + extern int erts_async_max_threads; +#endif + int n; + +#ifdef USE_THREADS + n = erts_async_max_threads; +#else + n = 0; +#endif + BIF_RET(make_small(n)); + } + else if (BIF_ARG_1 == am_alloc_util_allocators) { + BIF_RET(erts_alloc_util_allocators((void *) BIF_P)); + } + else if (BIF_ARG_1 == am_elib_malloc) { +#ifdef ELIB_ALLOC_IS_CLIB + struct elib_stat stat; + DECL_AM(heap_size); + DECL_AM(max_alloced_size); + DECL_AM(alloced_size); + DECL_AM(free_size); + DECL_AM(no_alloced_blocks); + DECL_AM(no_free_blocks); + DECL_AM(smallest_alloced_block); + DECL_AM(largest_free_block); + Eterm atoms[8]; + Eterm ints[8]; + Uint **hpp; + Uint sz; + Uint *szp; + int length; +#ifdef DEBUG + Uint *endp; +#endif + + elib_stat(&stat); + + /* First find out the heap size needed ... */ + hpp = NULL; + szp = &sz; + sz = 0; + + build_elib_malloc_term: + length = 0; + atoms[length] = AM_heap_size; + ints[length++] = erts_bld_uint(hpp, szp, + (Uint) stat.mem_total*sizeof(Uint)); + atoms[length] = AM_max_alloced_size; + ints[length++] = erts_bld_uint(hpp, szp, + (Uint) stat.mem_max_alloc*sizeof(Uint)); + atoms[length] = AM_alloced_size; + ints[length++] = erts_bld_uint(hpp, szp, + (Uint) stat.mem_alloc*sizeof(Uint)); + atoms[length] = AM_free_size; + ints[length++] = erts_bld_uint(hpp, szp, + (Uint) stat.mem_free*sizeof(Uint)); + atoms[length] = AM_no_alloced_blocks; + ints[length++] = erts_bld_uint(hpp, szp, (Uint) stat.mem_blocks); + atoms[length] = AM_no_free_blocks; + ints[length++] = erts_bld_uint(hpp, szp, (Uint) stat.free_blocks); + atoms[length] = AM_smallest_alloced_block; + ints[length++] = erts_bld_uint(hpp, szp, + (Uint) stat.min_used*sizeof(Uint)); + atoms[length] = AM_largest_free_block; + ints[length++] = erts_bld_uint(hpp, szp, + (Uint) stat.max_free*sizeof(Uint)); + + + + ASSERT(length <= sizeof(atoms)/sizeof(Eterm)); + ASSERT(length <= sizeof(ints)/sizeof(Eterm)); + + res = erts_bld_2tup_list(hpp, szp, length, atoms, ints); + + if (szp) { + /* ... and then build the term */ + hp = HAlloc(BIF_P, sz); +#ifdef DEBUG + endp = hp + sz; +#endif + + szp = NULL; + hpp = &hp; + goto build_elib_malloc_term; + } + +#ifdef DEBUG + ASSERT(endp == hp); +#endif + +#else /* #ifdef ELIB_ALLOC_IS_CLIB */ + res = am_false; +#endif /* #ifdef ELIB_ALLOC_IS_CLIB */ + + BIF_RET(res); + } + else if (BIF_ARG_1 == am_os_version) { + int major, minor, build; + Eterm tup; + + os_version(&major, &minor, &build); + hp = HAlloc(BIF_P, 4); + tup = TUPLE3(hp, + make_small(major), + make_small(minor), + make_small(build)); + BIF_RET(tup); + } + else if (BIF_ARG_1 == am_version) { + int n = strlen(ERLANG_VERSION); + hp = HAlloc(BIF_P, ((sizeof ERLANG_VERSION)-1) * 2); + BIF_RET(buf_to_intlist(&hp, ERLANG_VERSION, n, NIL)); + } + else if (BIF_ARG_1 == am_machine) { + int n = strlen(EMULATOR); + hp = HAlloc(BIF_P, n*2); + BIF_RET(buf_to_intlist(&hp, EMULATOR, n, NIL)); + } + else if (BIF_ARG_1 == am_garbage_collection) { + BIF_RET(am_generational); +#ifdef ERTS_OPCODE_COUNTER_SUPPORT + } else if (BIF_ARG_1 == am_instruction_counts) { +#ifdef DEBUG + Eterm *endp; +#endif + Eterm *hp, **hpp; + Uint hsz, *hszp; + int i; + + hpp = NULL; + hsz = 0; + hszp = &hsz; + + bld_instruction_counts: + + res = NIL; + for (i = num_instructions-1; i >= 0; i--) { + res = erts_bld_cons(hpp, hszp, + erts_bld_tuple(hpp, hszp, 2, + am_atom_put(opc[i].name, + strlen(opc[i].name)), + erts_bld_uint(hpp, hszp, + opc[i].count)), + res); + } + + if (!hpp) { + hp = HAlloc(BIF_P, hsz); + hpp = &hp; +#ifdef DEBUG + endp = hp + hsz; +#endif + hszp = NULL; + goto bld_instruction_counts; + } + +#ifdef DEBUG + ASSERT(endp == hp); +#endif + + BIF_RET(res); +#endif /* #ifndef ERTS_SMP */ + } else if (BIF_ARG_1 == am_wordsize) { + return make_small(sizeof(Eterm)); + } else if (BIF_ARG_1 == am_endian) { +#if defined(WORDS_BIGENDIAN) + return am_big; +#else + return am_little; +#endif + } else if (BIF_ARG_1 == am_heap_sizes) { + return erts_heap_sizes(BIF_P); + } else if (BIF_ARG_1 == am_global_heaps_size) { +#ifdef HYBRID + Uint hsz = 0; + Uint sz = 0; + + sz += global_heap_sz; +#ifdef INCREMENTAL + /* The size of the old generation is a bit hard to define here... + * The amount of live data in the last collection perhaps..? */ + sz = 0; +#else + if (global_old_hend && global_old_heap) + sz += global_old_hend - global_old_heap; +#endif + + sz *= sizeof(Eterm); + + (void) erts_bld_uint(NULL, &hsz, sz); + hp = hsz ? HAlloc(BIF_P, hsz) : NULL; + res = erts_bld_uint(&hp, NULL, sz); +#else + res = make_small(0); +#endif + return res; + } else if (BIF_ARG_1 == am_heap_type) { +#if defined(HYBRID) + return am_hybrid; +#else + return am_private; +#endif + } else if (ERTS_IS_ATOM_STR("cpu_topology", BIF_ARG_1)) { + res = erts_get_cpu_topology_term(BIF_P, am_used); + BIF_TRAP1(erts_format_cpu_topology_trap, BIF_P, res); +#if defined(__GNUC__) && defined(HAVE_SOLARIS_SPARC_PERFMON) + } else if (ERTS_IS_ATOM_STR("ultrasparc_read_tick1", BIF_ARG_1)) { + register unsigned high asm("%l0"); + register unsigned low asm("%l1"); + + hp = HAlloc(BIF_P, 5); + asm volatile (".word 0xa3410000;" /* rd %tick, %l1 */ + ".word 0xa1347020" /* srlx %l1, 0x20, %l0 */ + : "=r" (high), "=r" (low)); + res = TUPLE4(hp, make_small(high >> 16), + make_small(high & 0xFFFF), + make_small(low >> 16), + make_small(low & 0xFFFF)); + BIF_RET(res); + } else if (ERTS_IS_ATOM_STR("ultrasparc_read_tick2", BIF_ARG_1)) { + register unsigned high asm("%l0"); + register unsigned low asm("%l1"); + + asm volatile (".word 0xa3410000;" /* rd %tick, %l1 */ + ".word 0xa1347020" /* srlx %l1, 0x20, %l0 */ + : "=r" (high), "=r" (low)); + hp = HAlloc(BIF_P, 5); + res = TUPLE4(hp, make_small(high >> 16), + make_small(high & 0xFFFF), + make_small(low >> 16), + make_small(low & 0xFFFF)); + BIF_RET(res); + } else if (ERTS_IS_ATOM_STR("ultrasparc_read_pic1", BIF_ARG_1)) { + register unsigned high asm("%l0"); + register unsigned low asm("%l1"); + + hp = HAlloc(BIF_P, 5); + asm volatile (".word 0xa3444000;" /* rd %asr17, %l1 */ + ".word 0xa1347020" /* srlx %l1, 0x20, %l0 */ + : "=r" (high), "=r" (low)); + res = TUPLE4(hp, make_small(high >> 16), + make_small(high & 0xFFFF), + make_small(low >> 16), + make_small(low & 0xFFFF)); + BIF_RET(res); + } else if (ERTS_IS_ATOM_STR("ultrasparc_read_pic2", BIF_ARG_1)) { + register unsigned high asm("%l0"); + register unsigned low asm("%l1"); + + asm volatile (".word 0xa3444000;" /* rd %asr17, %l1 */ + ".word 0xa1347020" /* srlx %l1, 0x20, %l0 */ + : "=r" (high), "=r" (low)); + hp = HAlloc(BIF_P, 5); + res = TUPLE4(hp, make_small(high >> 16), + make_small(high & 0xFFFF), + make_small(low >> 16), + make_small(low & 0xFFFF)); + BIF_RET(res); +#endif + } else if (BIF_ARG_1 == am_threads) { +#ifdef USE_THREADS + return am_true; +#else + return am_false; +#endif + } else if (BIF_ARG_1 == am_creation) { + return make_small(erts_this_node->creation); + } else if (BIF_ARG_1 == am_break_ignored) { + extern int ignore_break; + if (ignore_break) + return am_true; + else + return am_false; + } + /* Arguments that are unusual follow ... */ + else if (ERTS_IS_ATOM_STR("logical_processors", BIF_ARG_1)) { + int no = erts_get_cpu_configured(erts_cpuinfo); + if (no > 0) + BIF_RET(make_small((Uint) no)); + else { + DECL_AM(unknown); + BIF_RET(AM_unknown); + } + } + else if (ERTS_IS_ATOM_STR("logical_processors_online", BIF_ARG_1)) { + int no = erts_get_cpu_online(erts_cpuinfo); + if (no > 0) + BIF_RET(make_small((Uint) no)); + else { + DECL_AM(unknown); + BIF_RET(AM_unknown); + } + } + else if (ERTS_IS_ATOM_STR("logical_processors_available", BIF_ARG_1)) { + int no = erts_get_cpu_available(erts_cpuinfo); + if (no > 0) + BIF_RET(make_small((Uint) no)); + else { + DECL_AM(unknown); + BIF_RET(AM_unknown); + } + } else if (ERTS_IS_ATOM_STR("otp_release", BIF_ARG_1)) { + int n = sizeof(ERLANG_OTP_RELEASE)-1; + hp = HAlloc(BIF_P, 2*n); + BIF_RET(buf_to_intlist(&hp, ERLANG_OTP_RELEASE, n, NIL)); + } else if (ERTS_IS_ATOM_STR("driver_version", BIF_ARG_1)) { + char buf[42]; + int n = erts_snprintf(buf, 42, "%d.%d", + ERL_DRV_EXTENDED_MAJOR_VERSION, + ERL_DRV_EXTENDED_MINOR_VERSION); + hp = HAlloc(BIF_P, 2*n); + BIF_RET(buf_to_intlist(&hp, buf, n, NIL)); + } else if (ERTS_IS_ATOM_STR("smp_support", BIF_ARG_1)) { +#ifdef ERTS_SMP + BIF_RET(am_true); +#else + BIF_RET(am_false); +#endif + } else if (ERTS_IS_ATOM_STR("scheduler_bind_type", BIF_ARG_1)) { + BIF_RET(erts_bound_schedulers_term(BIF_P)); + } else if (ERTS_IS_ATOM_STR("scheduler_bindings", BIF_ARG_1)) { + BIF_RET(erts_get_schedulers_binds(BIF_P)); + } else if (ERTS_IS_ATOM_STR("constant_pool_support", BIF_ARG_1)) { + BIF_RET(am_true); + } else if (ERTS_IS_ATOM_STR("schedulers", BIF_ARG_1) + || ERTS_IS_ATOM_STR("schedulers_total", BIF_ARG_1)) { + res = make_small(erts_no_schedulers); + BIF_RET(res); + } else if (ERTS_IS_ATOM_STR("schedulers_state", BIF_ARG_1)) { +#ifndef ERTS_SMP + Eterm *hp = HAlloc(BIF_P, 4); + res = TUPLE3(hp, make_small(1), make_small(1), make_small(1)); + BIF_RET(res); +#else + Uint total, online, active; + switch (erts_schedulers_state(&total, + &online, + &active, + 1)) { + case ERTS_SCHDLR_SSPND_DONE: { + Eterm *hp = HAlloc(BIF_P, 4); + res = TUPLE3(hp, + make_small(total), + make_small(online), + make_small(active)); + BIF_RET(res); + } + case ERTS_SCHDLR_SSPND_YIELD_RESTART: + ERTS_VBUMP_ALL_REDS(BIF_P); + BIF_TRAP1(bif_export[BIF_system_info_1], + BIF_P, BIF_ARG_1); + default: + ASSERT(0); + BIF_ERROR(BIF_P, EXC_INTERNAL_ERROR); + } +#endif + } else if (ERTS_IS_ATOM_STR("schedulers_online", BIF_ARG_1)) { +#ifndef ERTS_SMP + BIF_RET(make_small(1)); +#else + Uint total, online, active; + switch (erts_schedulers_state(&total, &online, &active, 1)) { + case ERTS_SCHDLR_SSPND_DONE: + BIF_RET(make_small(online)); + case ERTS_SCHDLR_SSPND_YIELD_RESTART: + ERTS_VBUMP_ALL_REDS(BIF_P); + BIF_TRAP1(bif_export[BIF_system_info_1], + BIF_P, BIF_ARG_1); + default: + ASSERT(0); + BIF_ERROR(BIF_P, EXC_INTERNAL_ERROR); + } +#endif + } else if (ERTS_IS_ATOM_STR("schedulers_active", BIF_ARG_1)) { +#ifndef ERTS_SMP + BIF_RET(make_small(1)); +#else + Uint total, online, active; + switch (erts_schedulers_state(&total, &online, &active, 1)) { + case ERTS_SCHDLR_SSPND_DONE: + BIF_RET(make_small(active)); + case ERTS_SCHDLR_SSPND_YIELD_RESTART: + ERTS_VBUMP_ALL_REDS(BIF_P); + BIF_TRAP1(bif_export[BIF_system_info_1], + BIF_P, BIF_ARG_1); + default: + ASSERT(0); + BIF_ERROR(BIF_P, EXC_INTERNAL_ERROR); + } +#endif + } else if (ERTS_IS_ATOM_STR("run_queues", BIF_ARG_1)) { + res = make_small(erts_no_run_queues); + BIF_RET(res); + } else if (ERTS_IS_ATOM_STR("c_compiler_used", BIF_ARG_1)) { + Eterm *hp = NULL; + Uint sz = 0; + (void) c_compiler_used(NULL, &sz); + if (sz) + hp = HAlloc(BIF_P, sz); + BIF_RET(c_compiler_used(&hp, NULL)); + } else if (ERTS_IS_ATOM_STR("stop_memory_trace", BIF_ARG_1)) { + erts_mtrace_stop(); + BIF_RET(am_true); + } else if (ERTS_IS_ATOM_STR("context_reductions", BIF_ARG_1)) { + BIF_RET(make_small(CONTEXT_REDS)); + } else if (ERTS_IS_ATOM_STR("kernel_poll", BIF_ARG_1)) { +#ifdef ERTS_ENABLE_KERNEL_POLL + BIF_RET(erts_use_kernel_poll ? am_true : am_false); +#else + BIF_RET(am_false); +#endif + } else if (ERTS_IS_ATOM_STR("lock_checking", BIF_ARG_1)) { +#ifdef ERTS_ENABLE_LOCK_CHECK + BIF_RET(am_true); +#else + BIF_RET(am_false); +#endif + } else if (ERTS_IS_ATOM_STR("lock_counting", BIF_ARG_1)) { +#ifdef ERTS_ENABLE_LOCK_COUNT + BIF_RET(am_true); +#else + BIF_RET(am_false); +#endif + } else if (ERTS_IS_ATOM_STR("debug_compiled", BIF_ARG_1)) { +#ifdef DEBUG + BIF_RET(am_true); +#else + BIF_RET(am_false); +#endif + } else if (ERTS_IS_ATOM_STR("check_io", BIF_ARG_1)) { + BIF_RET(erts_check_io_info(BIF_P)); + } else if (ERTS_IS_ATOM_STR("multi_scheduling_blockers", BIF_ARG_1)) { +#ifndef ERTS_SMP + BIF_RET(NIL); +#else + if (erts_no_schedulers == 1) + BIF_RET(NIL); + else + BIF_RET(erts_multi_scheduling_blockers(BIF_P)); +#endif + } else if (ERTS_IS_ATOM_STR("modified_timing_level", BIF_ARG_1)) { + BIF_RET(ERTS_USE_MODIFIED_TIMING() + ? make_small(erts_modified_timing_level) + : am_undefined); + } else if (ERTS_IS_ATOM_STR("port_tasks", BIF_ARG_1)) { + BIF_RET(am_true); + } else if (ERTS_IS_ATOM_STR("io_thread", BIF_ARG_1)) { + BIF_RET(am_false); + } else if (ERTS_IS_ATOM_STR("scheduling_statistics", BIF_ARG_1)) { + BIF_RET(erts_sched_stat_term(BIF_P, 0)); + } else if (ERTS_IS_ATOM_STR("total_scheduling_statistics", BIF_ARG_1)) { + BIF_RET(erts_sched_stat_term(BIF_P, 1)); + } else if (ERTS_IS_ATOM_STR("taints", BIF_ARG_1)) { + BIF_RET(erts_nif_taints(BIF_P)); + } + + BIF_ERROR(BIF_P, BADARG); +} + +Eterm +port_info_1(Process* p, Eterm pid) +{ + static Eterm keys[] = { + am_name, + am_links, + am_id, + am_connected, + am_input, + am_output + }; + Eterm items[ASIZE(keys)]; + Eterm result = NIL; + Eterm reg_name; + Eterm* hp; + Uint need; + int i; + + /* + * Collect all information about the port. + */ + + for (i = 0; i < ASIZE(keys); i++) { + Eterm item; + + item = port_info_2(p, pid, keys[i]); + if (is_non_value(item)) { + return THE_NON_VALUE; + } + if (item == am_undefined) { + return am_undefined; + } + items[i] = item; + } + reg_name = port_info_2(p, pid, am_registered_name); + + /* + * Build the resulting list. + */ + + need = 2*ASIZE(keys); + if (is_tuple(reg_name)) { + need += 2; + } + hp = HAlloc(p, need); + for (i = ASIZE(keys) - 1; i >= 0; i--) { + result = CONS(hp, items[i], result); + hp += 2; + } + if (is_tuple(reg_name)) { + result = CONS(hp, reg_name, result); + } + + return result; +} + + +/**********************************************************************/ +/* Return information on ports */ +/* Info: +** id Port index +** connected (Pid) +** links List of pids +** name String +** input Number of bytes input from port program +** output Number of bytes output to the port program +*/ + +BIF_RETTYPE port_info_2(BIF_ALIST_2) +{ + BIF_RETTYPE ret; + Eterm portid = BIF_ARG_1; + Port *prt; + Eterm item = BIF_ARG_2; + Eterm res; + Eterm* hp; + int count; + + if (is_internal_port(portid)) + prt = erts_id2port(portid, BIF_P, ERTS_PROC_LOCK_MAIN); + else if (is_atom(portid)) + erts_whereis_name(BIF_P, ERTS_PROC_LOCK_MAIN, + portid, NULL, 0, 0, &prt); + else if (is_external_port(portid) + && external_port_dist_entry(portid) == erts_this_dist_entry) + BIF_RET(am_undefined); + else { + BIF_ERROR(BIF_P, BADARG); + } + + if (!prt) { + BIF_RET(am_undefined); + } + + if (item == am_id) { + hp = HAlloc(BIF_P, 3); + res = make_small(internal_port_number(portid)); + } + else if (item == am_links) { + MonitorInfoCollection mic; + int i; + Eterm item; + + INIT_MONITOR_INFOS(mic); + + erts_doforall_links(prt->nlinks, &collect_one_link, &mic); + + hp = HAlloc(BIF_P, 3 + mic.sz); + res = NIL; + for (i = 0; i < mic.mi_i; i++) { + item = STORE_NC(&hp, &MSO(BIF_P).externals, mic.mi[i].entity); + res = CONS(hp, item, res); + hp += 2; + } + DESTROY_MONITOR_INFOS(mic); + + } + else if (item == am_monitors) { + MonitorInfoCollection mic; + int i; + Eterm item; + + INIT_MONITOR_INFOS(mic); + + erts_doforall_monitors(prt->monitors, &collect_one_origin_monitor, &mic); + + hp = HAlloc(BIF_P, 3 + mic.sz); + res = NIL; + for (i = 0; i < mic.mi_i; i++) { + Eterm t; + item = STORE_NC(&hp, &MSO(BIF_P).externals, mic.mi[i].entity); + t = TUPLE2(hp, am_process, item); + hp += 3; + res = CONS(hp, t, res); + hp += 2; + } + DESTROY_MONITOR_INFOS(mic); + + } + else if (item == am_name) { + count = sys_strlen(prt->name); + + hp = HAlloc(BIF_P, 3 + 2*count); + res = buf_to_intlist(&hp, prt->name, count, NIL); + } + else if (item == am_connected) { + hp = HAlloc(BIF_P, 3); + res = prt->connected; /* internal pid */ + } + else if (item == am_input) { + Uint hsz = 3; + Uint n = prt->bytes_in; + (void) erts_bld_uint(NULL, &hsz, n); + hp = HAlloc(BIF_P, hsz); + res = erts_bld_uint(&hp, NULL, n); + } + else if (item == am_output) { + Uint hsz = 3; + Uint n = prt->bytes_out; + (void) erts_bld_uint(NULL, &hsz, n); + hp = HAlloc(BIF_P, hsz); + res = erts_bld_uint(&hp, NULL, n); + } + else if (item == am_registered_name) { + RegProc *reg; + reg = prt->reg; + if (reg == NULL) { + ERTS_BIF_PREP_RET(ret, NIL); + goto done; + } else { + hp = HAlloc(BIF_P, 3); + res = reg->name; + } + } + else if (item == am_memory) { + /* All memory consumed in bytes (the Port struct should not be + included though). + */ + Uint hsz = 3; + Uint size = 0; + ErlHeapFragment* bp; + + hp = HAlloc(BIF_P, 3); + + erts_doforall_links(prt->nlinks, &one_link_size, &size); + + for (bp = prt->bp; bp; bp = bp->next) + size += sizeof(ErlHeapFragment) + (bp->size - 1)*sizeof(Eterm); + + if (prt->linebuf) + size += sizeof(LineBuf) + prt->linebuf->ovsiz; + + /* ... */ + + + /* All memory allocated by the driver should be included, but it is + hard to retrieve... */ + + (void) erts_bld_uint(NULL, &hsz, size); + hp = HAlloc(BIF_P, hsz); + res = erts_bld_uint(&hp, NULL, size); + } + else if (item == am_queue_size) { + Uint ioq_size = erts_port_ioq_size(prt); + Uint hsz = 3; + (void) erts_bld_uint(NULL, &hsz, ioq_size); + hp = HAlloc(BIF_P, hsz); + res = erts_bld_uint(&hp, NULL, ioq_size); + } + else if (ERTS_IS_ATOM_STR("locking", item)) { + hp = HAlloc(BIF_P, 3); +#ifndef ERTS_SMP + res = am_false; +#else + if (prt->status & ERTS_PORT_SFLG_PORT_SPECIFIC_LOCK) { + DECL_AM(port_level); + ASSERT(prt->drv_ptr->flags + & ERL_DRV_FLAG_USE_PORT_LOCKING); + res = AM_port_level; + } + else { + DECL_AM(driver_level); + ASSERT(!(prt->drv_ptr->flags + & ERL_DRV_FLAG_USE_PORT_LOCKING)); + res = AM_driver_level; + } +#endif + } + else { + ERTS_BIF_PREP_ERROR(ret, BIF_P, BADARG); + goto done; + } + + ERTS_BIF_PREP_RET(ret, TUPLE2(hp, item, res)); + + done: + + erts_smp_port_unlock(prt); + + return ret; +} + + +Eterm +fun_info_2(Process* p, Eterm fun, Eterm what) +{ + Eterm* hp; + Eterm val; + + if (is_fun(fun)) { + ErlFunThing* funp = (ErlFunThing *) fun_val(fun); + + switch (what) { + case am_type: + hp = HAlloc(p, 3); + val = am_local; + break; + case am_pid: + hp = HAlloc(p, 3); + val = funp->creator; + break; + case am_module: + hp = HAlloc(p, 3); + val = funp->fe->module; + break; + case am_new_index: + hp = HAlloc(p, 3); + val = make_small(funp->fe->index); + break; + case am_new_uniq: + val = new_binary(p, funp->fe->uniq, 16); + hp = HAlloc(p, 3); + break; + case am_index: + hp = HAlloc(p, 3); + val = make_small(funp->fe->old_index); + break; + case am_uniq: + hp = HAlloc(p, 3); + val = make_small(funp->fe->old_uniq); + break; + case am_env: + { + Uint num_free = funp->num_free; + int i; + + hp = HAlloc(p, 3 + 2*num_free); + val = NIL; + for (i = num_free-1; i >= 0; i--) { + val = CONS(hp, funp->env[i], val); + hp += 2; + } + } + break; + case am_refc: + val = erts_make_integer(erts_smp_atomic_read(&funp->fe->refc), p); + hp = HAlloc(p, 3); + break; + case am_arity: + hp = HAlloc(p, 3); + val = make_small(funp->arity); + break; + case am_name: + hp = HAlloc(p, 3); + val = funp->fe->address[-2]; + break; + default: + goto error; + } + } else if (is_export(fun)) { + Export* exp = (Export *) (export_val(fun))[1]; + switch (what) { + case am_type: + hp = HAlloc(p, 3); + val = am_external; + break; + case am_pid: + hp = HAlloc(p, 3); + val = am_undefined; + break; + case am_module: + hp = HAlloc(p, 3); + val = exp->code[0]; + break; + case am_new_index: + hp = HAlloc(p, 3); + val = am_undefined; + break; + case am_new_uniq: + hp = HAlloc(p, 3); + val = am_undefined; + break; + case am_index: + hp = HAlloc(p, 3); + val = am_undefined; + break; + case am_uniq: + hp = HAlloc(p, 3); + val = am_undefined; + break; + case am_env: + hp = HAlloc(p, 3); + val = NIL; + break; + case am_refc: + hp = HAlloc(p, 3); + val = am_undefined; + break; + case am_arity: + hp = HAlloc(p, 3); + val = make_small(exp->code[2]); + break; + case am_name: + hp = HAlloc(p, 3); + val = exp->code[1]; + break; + default: + goto error; + } + } else { + error: + BIF_ERROR(p, BADARG); + } + return TUPLE2(hp, what, val); +} + +BIF_RETTYPE is_process_alive_1(BIF_ALIST_1) +{ + if(is_internal_pid(BIF_ARG_1)) { + Process *rp; + + if (BIF_ARG_1 == BIF_P->id) + BIF_RET(am_true); + + if(internal_pid_index(BIF_ARG_1) >= erts_max_processes) + BIF_ERROR(BIF_P, BADARG); + + rp = erts_pid2proc(BIF_P, ERTS_PROC_LOCK_MAIN, + BIF_ARG_1, ERTS_PROC_LOCK_STATUS); + if (!rp) { + BIF_RET(am_false); + } + else { + int have_pending_exit = ERTS_PROC_PENDING_EXIT(rp); + erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_STATUS); + if (have_pending_exit) + ERTS_BIF_AWAIT_X_DATA_TRAP(BIF_P, BIF_ARG_1, am_false); + else + BIF_RET(am_true); + } + } + else if(is_external_pid(BIF_ARG_1)) { + if(external_pid_dist_entry(BIF_ARG_1) == erts_this_dist_entry) + BIF_RET(am_false); /* A pid from an old incarnation of this node */ + else + BIF_ERROR(BIF_P, BADARG); + } + else { + BIF_ERROR(BIF_P, BADARG); + } +} + +BIF_RETTYPE process_display_2(BIF_ALIST_2) +{ + Process *rp; + + if (BIF_ARG_2 != am_backtrace) + BIF_ERROR(BIF_P, BADARG); + + rp = erts_pid2proc_nropt(BIF_P, ERTS_PROC_LOCK_MAIN, + BIF_ARG_1, ERTS_PROC_LOCKS_ALL); + if(!rp) { + BIF_ERROR(BIF_P, BADARG); + } + if (rp == ERTS_PROC_LOCK_BUSY) + ERTS_BIF_YIELD2(bif_export[BIF_process_display_2], BIF_P, + BIF_ARG_1, BIF_ARG_2); + if (rp != BIF_P && ERTS_PROC_PENDING_EXIT(rp)) { + Eterm args[2] = {BIF_ARG_1, BIF_ARG_2}; + erts_smp_proc_unlock(rp, ERTS_PROC_LOCKS_ALL); + ERTS_BIF_AWAIT_X_APPLY_TRAP(BIF_P, + BIF_ARG_1, + am_erlang, + am_process_display, + args, + 2); + } + erts_stack_dump(ERTS_PRINT_STDERR, NULL, rp); +#ifdef ERTS_SMP + erts_smp_proc_unlock(rp, (BIF_P == rp + ? ERTS_PROC_LOCKS_ALL_MINOR + : ERTS_PROC_LOCKS_ALL)); +#endif + BIF_RET(am_true); +} + + +/* this is a general call which return some possibly useful information */ + +BIF_RETTYPE statistics_1(BIF_ALIST_1) +{ + Eterm res; + Eterm* hp; + + if (BIF_ARG_1 == am_context_switches) { + Eterm cs = erts_make_integer(erts_get_total_context_switches(), BIF_P); + hp = HAlloc(BIF_P, 3); + res = TUPLE2(hp, cs, SMALL_ZERO); + BIF_RET(res); + } else if (BIF_ARG_1 == am_garbage_collection) { + Uint hsz = 4; + ErtsGCInfo gc_info; + Eterm gcs; + Eterm recl; + erts_gc_info(&gc_info); + (void) erts_bld_uint(NULL, &hsz, gc_info.garbage_collections); + (void) erts_bld_uint(NULL, &hsz, gc_info.reclaimed); + hp = HAlloc(BIF_P, hsz); + gcs = erts_bld_uint(&hp, NULL, gc_info.garbage_collections); + recl = erts_bld_uint(&hp, NULL, gc_info.reclaimed); + res = TUPLE3(hp, gcs, recl, SMALL_ZERO); + BIF_RET(res); + } else if (BIF_ARG_1 == am_reductions) { + Uint reds; + Uint diff; + Uint hsz = 3; + Eterm b1, b2; + + erts_get_total_reductions(&reds, &diff); + (void) erts_bld_uint(NULL, &hsz, reds); + (void) erts_bld_uint(NULL, &hsz, diff); + hp = HAlloc(BIF_P, hsz); + b1 = erts_bld_uint(&hp, NULL, reds); + b2 = erts_bld_uint(&hp, NULL, diff); + res = TUPLE2(hp, b1, b2); + BIF_RET(res); + } else if (BIF_ARG_1 == am_exact_reductions) { + Uint reds; + Uint diff; + Uint hsz = 3; + Eterm b1, b2; + + erts_get_exact_total_reductions(BIF_P, &reds, &diff); + (void) erts_bld_uint(NULL, &hsz, reds); + (void) erts_bld_uint(NULL, &hsz, diff); + hp = HAlloc(BIF_P, hsz); + b1 = erts_bld_uint(&hp, NULL, reds); + b2 = erts_bld_uint(&hp, NULL, diff); + res = TUPLE2(hp, b1, b2); + BIF_RET(res); + } else if (BIF_ARG_1 == am_runtime) { + unsigned long u1, u2, dummy; + Eterm b1, b2; + elapsed_time_both(&u1,&dummy,&u2,&dummy); + b1 = erts_make_integer(u1,BIF_P); + b2 = erts_make_integer(u2,BIF_P); + hp = HAlloc(BIF_P,3); + res = TUPLE2(hp, b1, b2); + BIF_RET(res); + } else if (BIF_ARG_1 == am_run_queue) { + res = erts_run_queues_len(NULL); + BIF_RET(make_small(res)); + } else if (BIF_ARG_1 == am_wall_clock) { + Uint w1, w2; + Eterm b1, b2; + wall_clock_elapsed_time_both(&w1, &w2); + b1 = erts_make_integer(w1,BIF_P); + b2 = erts_make_integer(w2,BIF_P); + hp = HAlloc(BIF_P,3); + res = TUPLE2(hp, b1, b2); + BIF_RET(res); + } else if (BIF_ARG_1 == am_io) { + Eterm r1, r2; + Eterm in, out; + Uint hsz = 9; + Uint bytes_in = (Uint) erts_smp_atomic_read(&erts_bytes_in); + Uint bytes_out = (Uint) erts_smp_atomic_read(&erts_bytes_out); + + (void) erts_bld_uint(NULL, &hsz, bytes_in); + (void) erts_bld_uint(NULL, &hsz, bytes_out); + hp = HAlloc(BIF_P, hsz); + in = erts_bld_uint(&hp, NULL, bytes_in); + out = erts_bld_uint(&hp, NULL, bytes_out); + + r1 = TUPLE2(hp, am_input, in); + hp += 3; + r2 = TUPLE2(hp, am_output, out); + hp += 3; + BIF_RET(TUPLE2(hp, r1, r2)); + } + else if (ERTS_IS_ATOM_STR("run_queues", BIF_ARG_1)) { + Eterm res, *hp, **hpp; + Uint sz, *szp; + int no_qs = erts_no_run_queues; + Uint *qszs = erts_alloc(ERTS_ALC_T_TMP,sizeof(Uint)*no_qs*2); + (void) erts_run_queues_len(qszs); + sz = 0; + szp = &sz; + hpp = NULL; + while (1) { + int i; + for (i = 0; i < no_qs; i++) + qszs[no_qs+i] = erts_bld_uint(hpp, szp, qszs[i]); + res = erts_bld_tuplev(hpp, szp, no_qs, &qszs[no_qs]); + if (hpp) { + erts_free(ERTS_ALC_T_TMP, qszs); + BIF_RET(res); + } + hp = HAlloc(BIF_P, sz); + szp = NULL; + hpp = &hp; + } + } + BIF_ERROR(BIF_P, BADARG); +} + +BIF_RETTYPE memory_0(BIF_ALIST_0) +{ + BIF_RETTYPE res = erts_memory(NULL, NULL, BIF_P, THE_NON_VALUE); + switch (res) { + case am_badarg: BIF_ERROR(BIF_P, EXC_INTERNAL_ERROR); /* never... */ + case am_notsup: BIF_ERROR(BIF_P, EXC_NOTSUP); + default: BIF_RET(res); + } +} + +BIF_RETTYPE memory_1(BIF_ALIST_1) +{ + BIF_RETTYPE res = erts_memory(NULL, NULL, BIF_P, BIF_ARG_1); + switch (res) { + case am_badarg: BIF_ERROR(BIF_P, BADARG); + case am_notsup: BIF_ERROR(BIF_P, EXC_NOTSUP); + default: BIF_RET(res); + } +} + +BIF_RETTYPE error_logger_warning_map_0(BIF_ALIST_0) +{ + BIF_RET(erts_error_logger_warnings); +} + +static erts_smp_atomic_t available_internal_state; + +BIF_RETTYPE erts_debug_get_internal_state_1(BIF_ALIST_1) +{ + /* + * NOTE: Only supposed to be used for testing, and debugging. + */ + + if (!erts_smp_atomic_read(&available_internal_state)) { + BIF_ERROR(BIF_P, EXC_UNDEF); + } + + if (is_atom(BIF_ARG_1)) { + if (ERTS_IS_ATOM_STR("reds_left", BIF_ARG_1)) { + /* Used by (emulator) */ + BIF_RET(make_small((Uint) ERTS_BIF_REDS_LEFT(BIF_P))); + } + else if (ERTS_IS_ATOM_STR("node_and_dist_references", BIF_ARG_1)) { + /* Used by node_container_SUITE (emulator) */ + Eterm res = erts_get_node_and_dist_references(BIF_P); + BIF_RET(res); + } + else if (ERTS_IS_ATOM_STR("monitoring_nodes", BIF_ARG_1)) { + BIF_RET(erts_processes_monitoring_nodes(BIF_P)); + } + else if (ERTS_IS_ATOM_STR("next_pid", BIF_ARG_1) + || ERTS_IS_ATOM_STR("next_port", BIF_ARG_1)) { + /* Used by node_container_SUITE (emulator) */ + Eterm res; + if (ERTS_IS_ATOM_STR("next_pid", BIF_ARG_1)) + res = erts_test_next_pid(0, 0); + else { + res = erts_test_next_port(0, 0); + } + if (res < 0) + BIF_RET(am_false); + BIF_RET(erts_make_integer(res, BIF_P)); + } + else if (ERTS_IS_ATOM_STR("DbTable_words", BIF_ARG_1)) { + /* Used by ets_SUITE (stdlib) */ + size_t words = (sizeof(DbTable) + sizeof(Uint) - 1)/sizeof(Uint); + BIF_RET(make_small((Uint) words)); + } + else if (ERTS_IS_ATOM_STR("check_io_debug", BIF_ARG_1)) { + /* Used by (emulator) */ + int res; +#ifdef HAVE_ERTS_CHECK_IO_DEBUG + erts_smp_proc_unlock(BIF_P,ERTS_PROC_LOCK_MAIN); + res = erts_check_io_debug(); + erts_smp_proc_lock(BIF_P,ERTS_PROC_LOCK_MAIN); +#else + res = 0; +#endif + ASSERT(res >= 0); + BIF_RET(erts_make_integer((Uint) res, BIF_P)); + } + else if (ERTS_IS_ATOM_STR("process_info_args", BIF_ARG_1)) { + /* Used by process_SUITE (emulator) */ + int i; + Eterm res = NIL; + Uint *hp = HAlloc(BIF_P, 2*ERTS_PI_ARGS); + for (i = ERTS_PI_ARGS-1; i >= 0; i--) { + res = CONS(hp, pi_args[i], res); + hp += 2; + } + BIF_RET(res); + } + else if (ERTS_IS_ATOM_STR("processes", BIF_ARG_1)) { + /* Used by process_SUITE (emulator) */ + BIF_RET(erts_debug_processes(BIF_P)); + } + else if (ERTS_IS_ATOM_STR("processes_bif_info", BIF_ARG_1)) { + /* Used by process_SUITE (emulator) */ + BIF_RET(erts_debug_processes_bif_info(BIF_P)); + } + else if (ERTS_IS_ATOM_STR("max_atom_out_cache_index", BIF_ARG_1)) { + /* Used by distribution_SUITE (emulator) */ + BIF_RET(make_small((Uint) erts_debug_max_atom_out_cache_index())); + } + else if (ERTS_IS_ATOM_STR("nbalance", BIF_ARG_1)) { + Uint n; + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN); + n = erts_debug_nbalance(); + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_MAIN); + BIF_RET(erts_make_integer(n, BIF_P)); + } + else if (ERTS_IS_ATOM_STR("available_internal_state", BIF_ARG_1)) { + BIF_RET(am_true); + } + } + else if (is_tuple(BIF_ARG_1)) { + Eterm* tp = tuple_val(BIF_ARG_1); + switch (arityval(tp[0])) { + case 2: { + if (ERTS_IS_ATOM_STR("process_status", tp[1])) { + /* Used by timer process_SUITE, timer_bif_SUITE, and + node_container_SUITE (emulator) */ + if (is_internal_pid(tp[2])) { + BIF_RET(erts_process_status(BIF_P, + ERTS_PROC_LOCK_MAIN, + NULL, + tp[2])); + } + } + else if (ERTS_IS_ATOM_STR("link_list", tp[1])) { + /* Used by erl_link_SUITE (emulator) */ + if(is_internal_pid(tp[2])) { + Eterm res; + Process *p; + + p = erts_pid2proc(BIF_P, + ERTS_PROC_LOCK_MAIN, + tp[2], + ERTS_PROC_LOCK_LINK); + if (!p) { + ERTS_SMP_ASSERT_IS_NOT_EXITING(BIF_P); + BIF_RET(am_undefined); + } + res = make_link_list(BIF_P, p->nlinks, NIL); + erts_smp_proc_unlock(p, ERTS_PROC_LOCK_LINK); + BIF_RET(res); + } + else if(is_internal_port(tp[2])) { + Eterm res; + Port *p = erts_id2port(tp[2], BIF_P, ERTS_PROC_LOCK_MAIN); + if(!p) + BIF_RET(am_undefined); + res = make_link_list(BIF_P, p->nlinks, NIL); + erts_smp_port_unlock(p); + BIF_RET(res); + } + else if(is_node_name_atom(tp[2])) { + DistEntry *dep = erts_find_dist_entry(tp[2]); + if(dep) { + Eterm subres; + erts_smp_de_links_lock(dep); + subres = make_link_list(BIF_P, dep->nlinks, NIL); + subres = make_link_list(BIF_P, dep->node_links, subres); + erts_smp_de_links_unlock(dep); + erts_deref_dist_entry(dep); + BIF_RET(subres); + } else { + BIF_RET(am_undefined); + } + } + } + else if (ERTS_IS_ATOM_STR("monitor_list", tp[1])) { + /* Used by erl_link_SUITE (emulator) */ + if(is_internal_pid(tp[2])) { + Process *p; + Eterm res; + + p = erts_pid2proc(BIF_P, + ERTS_PROC_LOCK_MAIN, + tp[2], + ERTS_PROC_LOCK_LINK); + if (!p) { + ERTS_SMP_ASSERT_IS_NOT_EXITING(BIF_P); + BIF_RET(am_undefined); + } + res = make_monitor_list(BIF_P, p->monitors); + erts_smp_proc_unlock(p, ERTS_PROC_LOCK_LINK); + BIF_RET(res); + } else if(is_node_name_atom(tp[2])) { + DistEntry *dep = erts_find_dist_entry(tp[2]); + if(dep) { + Eterm ml; + erts_smp_de_links_lock(dep); + ml = make_monitor_list(BIF_P, dep->monitors); + erts_smp_de_links_unlock(dep); + erts_deref_dist_entry(dep); + BIF_RET(ml); + } else { + BIF_RET(am_undefined); + } + } + } + else if (ERTS_IS_ATOM_STR("channel_number", tp[1])) { + Eterm res; + DistEntry *dep = erts_find_dist_entry(tp[2]); + if (!dep) + res = am_undefined; + else { + Uint cno = dist_entry_channel_no(dep); + res = make_small(cno); + erts_deref_dist_entry(dep); + } + BIF_RET(res); + } + else if (ERTS_IS_ATOM_STR("have_pending_exit", tp[1])) { + Process *rp = erts_pid2proc(BIF_P, ERTS_PROC_LOCK_MAIN, + tp[2], ERTS_PROC_LOCK_STATUS); + if (!rp) { + BIF_RET(am_undefined); + } + else { + Eterm res = ERTS_PROC_PENDING_EXIT(rp) ? am_true : am_false; + erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_STATUS); + BIF_RET(res); + } + } + else if (ERTS_IS_ATOM_STR("binary_info", tp[1])) { + Eterm bin = tp[2]; + if (is_binary(bin)) { + Eterm real_bin = bin; + Eterm res = am_true; + ErlSubBin* sb = (ErlSubBin *) binary_val(real_bin); + + if (sb->thing_word == HEADER_SUB_BIN) { + real_bin = sb->orig; + } + if (*binary_val(real_bin) == HEADER_PROC_BIN) { + ProcBin* pb; + Binary* val; + Eterm SzTerm; + Uint hsz = 3 + 5; + Eterm* hp; + DECL_AM(refc_binary); + + pb = (ProcBin *) binary_val(real_bin); + val = pb->val; + (void) erts_bld_uint(NULL, &hsz, pb->size); + (void) erts_bld_uint(NULL, &hsz, val->orig_size); + hp = HAlloc(BIF_P, hsz); + + /* Info about the Binary* object */ + SzTerm = erts_bld_uint(&hp, NULL, val->orig_size); + res = TUPLE2(hp, am_binary, SzTerm); + hp += 3; + + /* Info about the ProcBin* object */ + SzTerm = erts_bld_uint(&hp, NULL, pb->size); + res = TUPLE4(hp, AM_refc_binary, SzTerm, + res, make_small(pb->flags)); + } else { /* heap binary */ + DECL_AM(heap_binary); + res = AM_heap_binary; + } + BIF_RET(res); + } + } + else if (ERTS_IS_ATOM_STR("term_to_binary_no_funs", tp[1])) { + Uint dflags = (DFLAG_EXTENDED_REFERENCES | + DFLAG_EXTENDED_PIDS_PORTS | + DFLAG_BIT_BINARIES); + BIF_RET(erts_term_to_binary(BIF_P, tp[2], 0, dflags)); + } + else if (ERTS_IS_ATOM_STR("dist_port", tp[1])) { + Eterm res = am_undefined; + DistEntry *dep = erts_sysname_to_connected_dist_entry(tp[2]); + if (dep) { + erts_smp_de_rlock(dep); + if (is_internal_port(dep->cid)) + res = dep->cid; + erts_smp_de_runlock(dep); + erts_deref_dist_entry(dep); + } + BIF_RET(res); + } + else if (ERTS_IS_ATOM_STR("atom_out_cache_index", tp[1])) { + /* Used by distribution_SUITE (emulator) */ + if (is_atom(tp[2])) { + BIF_RET(make_small( + (Uint) + erts_debug_atom_to_out_cache_index(tp[2]))); + } + } + else if (ERTS_IS_ATOM_STR("fake_scheduler_bindings", tp[1])) { + return erts_fake_scheduler_bindings(BIF_P, tp[2]); + } + break; + } + default: + break; + } + } + BIF_ERROR(BIF_P, BADARG); +} + +static erts_smp_atomic_t hipe_test_reschedule_flag; + +BIF_RETTYPE erts_debug_set_internal_state_2(BIF_ALIST_2) +{ + /* + * NOTE: Only supposed to be used for testing, and debugging. + */ + if (ERTS_IS_ATOM_STR("available_internal_state", BIF_ARG_1) + && (BIF_ARG_2 == am_true || BIF_ARG_2 == am_false)) { + long on = (long) (BIF_ARG_2 == am_true); + long prev_on = erts_smp_atomic_xchg(&available_internal_state, on); + if (on) { + erts_dsprintf_buf_t *dsbufp = erts_create_logger_dsbuf(); + erts_dsprintf(dsbufp, "Process %T ", BIF_P->id); + if (erts_is_alive) + erts_dsprintf(dsbufp, "on node %T ", erts_this_node->sysname); + erts_dsprintf(dsbufp, + "enabled access to the emulator internal state.\n"); + erts_dsprintf(dsbufp, + "NOTE: This is an erts internal test feature and " + "should *only* be used by OTP test-suites.\n"); + erts_send_warning_to_logger(BIF_P->group_leader, dsbufp); + } + BIF_RET(prev_on ? am_true : am_false); + } + + if (!erts_smp_atomic_read(&available_internal_state)) { + BIF_ERROR(BIF_P, EXC_UNDEF); + } + + if (is_atom(BIF_ARG_1)) { + + if (ERTS_IS_ATOM_STR("reds_left", BIF_ARG_1)) { + Sint reds; + if (term_to_Sint(BIF_ARG_2, &reds) != 0) { + if (0 <= reds && reds <= CONTEXT_REDS) { + if (!ERTS_PROC_GET_SAVED_CALLS_BUF(BIF_P)) + BIF_P->fcalls = reds; + else + BIF_P->fcalls = reds - CONTEXT_REDS; + } + BIF_RET(am_true); + } + } + else if (ERTS_IS_ATOM_STR("block", BIF_ARG_1) + || ERTS_IS_ATOM_STR("sleep", BIF_ARG_1)) { + int block = ERTS_IS_ATOM_STR("block", BIF_ARG_1); + Sint ms; + if (term_to_Sint(BIF_ARG_2, &ms) != 0) { + if (ms > 0) { + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN); + if (block) + erts_smp_block_system(0); + while (erts_milli_sleep((long) ms) != 0); + if (block) + erts_smp_release_system(); + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_MAIN); + } + BIF_RET(am_true); + } + } + else if (ERTS_IS_ATOM_STR("block_scheduler", BIF_ARG_1)) { + Sint ms; + if (term_to_Sint(BIF_ARG_2, &ms) != 0) { + if (ms > 0) { + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN); + while (erts_milli_sleep((long) ms) != 0); + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_MAIN); + } + BIF_RET(am_true); + } + } + else if (ERTS_IS_ATOM_STR("next_pid", BIF_ARG_1) + || ERTS_IS_ATOM_STR("next_port", BIF_ARG_1)) { + /* Used by node_container_SUITE (emulator) */ + Uint next; + + if (term_to_Uint(BIF_ARG_2, &next) != 0) { + Eterm res; + + if (ERTS_IS_ATOM_STR("next_pid", BIF_ARG_1)) + res = erts_test_next_pid(1, next); + else { + res = erts_test_next_port(1, next); + } + if (res < 0) + BIF_RET(am_false); + BIF_RET(erts_make_integer(res, BIF_P)); + } + } + else if (ERTS_IS_ATOM_STR("force_gc", BIF_ARG_1)) { + /* Used by signal_SUITE (emulator) */ + Process *rp = erts_pid2proc(BIF_P, ERTS_PROC_LOCK_MAIN, + BIF_ARG_2, ERTS_PROC_LOCK_MAIN); + if (!rp) { + BIF_RET(am_false); + } + else { + FLAGS(rp) |= F_FORCE_GC; + if (BIF_P != rp) + erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_MAIN); + BIF_RET(am_true); + } + } + else if (ERTS_IS_ATOM_STR("send_fake_exit_signal", BIF_ARG_1)) { + /* Used by signal_SUITE (emulator) */ + + /* Testcases depend on the exit being received via + a pending exit when the receiver is the same as + the caller. */ + if (is_tuple(BIF_ARG_2)) { + Eterm* tp = tuple_val(BIF_ARG_2); + if (arityval(tp[0]) == 3 + && (is_pid(tp[1]) || is_port(tp[1])) + && is_internal_pid(tp[2])) { + int xres; + ErtsProcLocks rp_locks = ERTS_PROC_LOCKS_XSIG_SEND; + Process *rp = erts_pid2proc_opt(BIF_P, ERTS_PROC_LOCK_MAIN, + tp[2], rp_locks, + ERTS_P2P_FLG_SMP_INC_REFC); + if (!rp) { + DECL_AM(dead); + BIF_RET(AM_dead); + } + +#ifdef ERTS_SMP + if (BIF_P == rp) + rp_locks |= ERTS_PROC_LOCK_MAIN; +#endif + xres = erts_send_exit_signal(NULL, /* NULL in order to + force a pending exit + when we send to our + selves. */ + tp[1], + rp, + &rp_locks, + tp[3], + NIL, + NULL, + 0); +#ifdef ERTS_SMP + if (BIF_P == rp) + rp_locks &= ~ERTS_PROC_LOCK_MAIN; +#endif + erts_smp_proc_unlock(rp, rp_locks); + erts_smp_proc_dec_refc(rp); + if (xres > 1) { + DECL_AM(message); + BIF_RET(AM_message); + } + else if (xres == 0) { + DECL_AM(unaffected); + BIF_RET(AM_unaffected); + } + else { + DECL_AM(exit); + BIF_RET(AM_exit); + } + } + } + } + else if (ERTS_IS_ATOM_STR("colliding_names", BIF_ARG_1)) { + /* Used by ets_SUITE (stdlib) */ + if (is_tuple(BIF_ARG_2)) { + Eterm* tpl = tuple_val(BIF_ARG_2); + Uint cnt; + if (arityval(tpl[0]) == 2 && is_atom(tpl[1]) && + term_to_Uint(tpl[2], &cnt)) { + BIF_RET(erts_ets_colliding_names(BIF_P,tpl[1],cnt)); + } + } + } + else if (ERTS_IS_ATOM_STR("re_loop_limit", BIF_ARG_1)) { + /* Used by re_SUITE (stdlib) */ + Uint max_loops; + if (is_atom(BIF_ARG_2) && ERTS_IS_ATOM_STR("default", BIF_ARG_2)) { + max_loops = erts_re_set_loop_limit(-1); + BIF_RET(make_small(max_loops)); + } else if (term_to_Uint(BIF_ARG_2, &max_loops) != 0) { + max_loops = erts_re_set_loop_limit(max_loops); + BIF_RET(make_small(max_loops)); + } + } + else if (ERTS_IS_ATOM_STR("unicode_loop_limit", BIF_ARG_1)) { + /* Used by unicode_SUITE (stdlib) */ + Uint max_loops; + if (is_atom(BIF_ARG_2) && ERTS_IS_ATOM_STR("default", BIF_ARG_2)) { + max_loops = erts_unicode_set_loop_limit(-1); + BIF_RET(make_small(max_loops)); + } else if (term_to_Uint(BIF_ARG_2, &max_loops) != 0) { + max_loops = erts_unicode_set_loop_limit(max_loops); + BIF_RET(make_small(max_loops)); + } + } + else if (ERTS_IS_ATOM_STR("hipe_test_reschedule_suspend", BIF_ARG_1)) { + /* Used by hipe test suites */ + long flag = erts_smp_atomic_read(&hipe_test_reschedule_flag); + if (!flag && BIF_ARG_2 != am_false) { + erts_smp_atomic_set(&hipe_test_reschedule_flag, 1); + erts_suspend(BIF_P, ERTS_PROC_LOCK_MAIN, NULL); + ERTS_BIF_YIELD2(bif_export[BIF_erts_debug_set_internal_state_2], + BIF_P, BIF_ARG_1, BIF_ARG_2); + } + erts_smp_atomic_set(&hipe_test_reschedule_flag, !flag); + BIF_RET(NIL); + } + else if (ERTS_IS_ATOM_STR("hipe_test_reschedule_resume", BIF_ARG_1)) { + /* Used by hipe test suites */ + Eterm res = am_false; + Process *rp = erts_pid2proc(BIF_P, ERTS_PROC_LOCK_MAIN, + BIF_ARG_2, ERTS_PROC_LOCK_STATUS); + if (rp) { + erts_resume(rp, ERTS_PROC_LOCK_STATUS); + res = am_true; + erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_STATUS); + } + BIF_RET(res); + } + else if (ERTS_IS_ATOM_STR("test_long_gc_sleep", BIF_ARG_1)) { + if (term_to_Uint(BIF_ARG_2, &erts_test_long_gc_sleep) > 0) + BIF_RET(am_true); + } + else if (ERTS_IS_ATOM_STR("abort", BIF_ARG_1)) { + erl_exit(ERTS_ABORT_EXIT, "%T\n", BIF_ARG_2); + } + else if (ERTS_IS_ATOM_STR("kill_dist_connection", BIF_ARG_1)) { + DistEntry *dep = erts_sysname_to_connected_dist_entry(BIF_ARG_2); + if (!dep) + BIF_RET(am_false); + else { + Uint32 con_id; + erts_smp_de_rlock(dep); + con_id = dep->connection_id; + erts_smp_de_runlock(dep); + erts_kill_dist_connection(dep, con_id); + erts_deref_dist_entry(dep); + BIF_RET(am_true); + } + } + else if (ERTS_IS_ATOM_STR("not_running_optimization", BIF_ARG_1)) { +#ifdef ERTS_SMP + int old_use_opt, use_opt; + switch (BIF_ARG_2) { + case am_true: + use_opt = 1; + break; + case am_false: + use_opt = 0; + break; + default: + BIF_ERROR(BIF_P, BADARG); + } + + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN); + erts_smp_block_system(0); + old_use_opt = !erts_disable_proc_not_running_opt; + erts_disable_proc_not_running_opt = !use_opt; + erts_smp_release_system(); + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_MAIN); + BIF_RET(old_use_opt ? am_true : am_false); +#else + BIF_ERROR(BIF_P, EXC_NOTSUP); +#endif + } + } + + BIF_ERROR(BIF_P, BADARG); +} + +#ifdef ERTS_ENABLE_LOCK_COUNT +static Eterm lcnt_build_lock_stats_term(Eterm **hpp, Uint *szp, erts_lcnt_lock_stats_t *stats, Eterm res) { + unsigned long tries = 0, colls = 0; + unsigned long timer_s = 0, timer_ns = 0, timer_n = 0; + unsigned int line = 0; + + Eterm af, uil; + Eterm uit, uic; + Eterm uits, uitns, uitn; + Eterm tt, tstat, tloc, t; + + /* term: + * [{{file, line}, {tries, colls, {seconds, nanoseconds, n_blocks}}}] + */ + + ethr_atomic_read(&stats->tries, (long *)&tries); + ethr_atomic_read(&stats->colls, (long *)&colls); + + line = stats->line; + timer_s = stats->timer.s; + timer_ns = stats->timer.ns; + timer_n = stats->timer_n; + + af = am_atom_put(stats->file, strlen(stats->file)); + uil = erts_bld_uint( hpp, szp, line); + tloc = erts_bld_tuple(hpp, szp, 2, af, uil); + + uit = erts_bld_uint( hpp, szp, tries); + uic = erts_bld_uint( hpp, szp, colls); + + uits = erts_bld_uint( hpp, szp, timer_s); + uitns = erts_bld_uint( hpp, szp, timer_ns); + uitn = erts_bld_uint( hpp, szp, timer_n); + tt = erts_bld_tuple(hpp, szp, 3, uits, uitns, uitn); + + tstat = erts_bld_tuple(hpp, szp, 3, uit, uic, tt); + + t = erts_bld_tuple(hpp, szp, 2, tloc, tstat); + + res = erts_bld_cons( hpp, szp, t, res); + + return res; +} + +static Eterm lcnt_build_lock_term(Eterm **hpp, Uint *szp, erts_lcnt_lock_t *lock, Eterm res) { + Eterm name, type, id, stats = NIL, t; + Process *proc = NULL; + char *ltype; + int i; + + /* term: + * [{name, id, type, stats()}] + */ + + ASSERT(lock->name); + + ltype = erts_lcnt_lock_type(lock->flag); + + ASSERT(ltype); + + type = am_atom_put(ltype, strlen(ltype)); + + name = am_atom_put(lock->name, strlen(lock->name)); + + if (lock->flag & ERTS_LCNT_LT_ALLOC) { + /* use allocator types names as id's for allocator locks */ + ltype = ERTS_ALC_A2AD(signed_val(lock->id)); + id = am_atom_put(ltype, strlen(ltype)); + } else if (lock->flag & ERTS_LCNT_LT_PROCLOCK) { + /* use registered names as id's for process locks if available */ + proc = erts_pid2proc_unlocked(lock->id); + if (proc && proc->reg) { + id = proc->reg->name; + } else { + /* otherwise use process id */ + id = lock->id; + } + } else { + id = lock->id; + } + + for (i = 0; i < lock->n_stats; i++) { + stats = lcnt_build_lock_stats_term(hpp, szp, &(lock->stats[i]), stats); + } + + t = erts_bld_tuple(hpp, szp, 4, name, id, type, stats); + + res = erts_bld_cons( hpp, szp, t, res); + + return res; +} + +static Eterm lcnt_build_result_term(Eterm **hpp, Uint *szp, erts_lcnt_data_t *data, Eterm res) { + Eterm dts, dtns, tdt, adur, tdur, aloc, lloc = NIL, tloc; + erts_lcnt_lock_t *lock = NULL; + char *str_duration = "duration"; + char *str_locks = "locks"; + + /* term: + * [{'duration', {seconds, nanoseconds}}, {'locks', locks()}] + */ + + /* duration tuple */ + dts = erts_bld_uint( hpp, szp, data->duration.s); + dtns = erts_bld_uint( hpp, szp, data->duration.ns); + tdt = erts_bld_tuple(hpp, szp, 2, dts, dtns); + + adur = am_atom_put(str_duration, strlen(str_duration)); + tdur = erts_bld_tuple(hpp, szp, 2, adur, tdt); + + /* lock tuple */ + + aloc = am_atom_put(str_locks, strlen(str_locks)); + + for (lock = data->current_locks->head; lock != NULL ; lock = lock->next ) { + lloc = lcnt_build_lock_term(hpp, szp, lock, lloc); + } + + for (lock = data->deleted_locks->head; lock != NULL ; lock = lock->next ) { + lloc = lcnt_build_lock_term(hpp, szp, lock, lloc); + } + + tloc = erts_bld_tuple(hpp, szp, 2, aloc, lloc); + + res = erts_bld_cons( hpp, szp, tloc, res); + res = erts_bld_cons( hpp, szp, tdur, res); + + return res; +} +#endif + +BIF_RETTYPE erts_debug_lock_counters_1(BIF_ALIST_1) +{ +#ifdef ERTS_ENABLE_LOCK_COUNT + Eterm res = NIL; + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN); + erts_smp_block_system(0); + + if (BIF_ARG_1 == am_info) { + erts_lcnt_data_t *data; + Uint hsize = 0; + Uint *szp; + Eterm* hp; + + erts_lcnt_set_rt_opt(ERTS_LCNT_OPT_SUSPEND); + + data = erts_lcnt_get_data(); + + /* calculate size */ + + szp = &hsize; + lcnt_build_result_term(NULL, szp, data, NIL); + + /* alloc and build */ + + hp = HAlloc(BIF_P, hsize); + + res = lcnt_build_result_term(&hp, NULL, data, res); + + erts_lcnt_clear_rt_opt(ERTS_LCNT_OPT_SUSPEND); + + goto done; + } else if (BIF_ARG_1 == am_clear) { + erts_lcnt_clear_counters(); + res = am_ok; + goto done; + } else if (is_tuple(BIF_ARG_1)) { + Uint prev = 0; + Eterm* tp = tuple_val(BIF_ARG_1); + switch (arityval(tp[0])) { + case 2: + if (ERTS_IS_ATOM_STR("process_locks", tp[1])) { + if (tp[2] == am_true) { + prev = erts_lcnt_set_rt_opt(ERTS_LCNT_OPT_PROCLOCK); + if (prev) res = am_true; + else res = am_false; + goto done; + } else if (tp[2] == am_false) { + prev = erts_lcnt_clear_rt_opt(ERTS_LCNT_OPT_PROCLOCK); + if (prev) res = am_true; + else res = am_false; + goto done; + } + } + break; + + default: + break; + } + } + + erts_smp_release_system(); + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_MAIN); +#endif + BIF_ERROR(BIF_P, BADARG); +#ifdef ERTS_ENABLE_LOCK_COUNT +done: + erts_smp_release_system(); + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_MAIN); + BIF_RET(res); +#endif +} + +void +erts_bif_info_init(void) +{ + erts_smp_atomic_init(&available_internal_state, 0); + erts_smp_atomic_init(&hipe_test_reschedule_flag, 0); + + process_info_init(); +} diff --git a/erts/emulator/beam/erl_bif_lists.c b/erts/emulator/beam/erl_bif_lists.c new file mode 100644 index 0000000000..a9e8dd86f7 --- /dev/null +++ b/erts/emulator/beam/erl_bif_lists.c @@ -0,0 +1,392 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1999-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* + * BIFs logically belonging to the lists module. + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "erl_process.h" +#include "error.h" +#include "bif.h" + +static Eterm keyfind(int Bif, Process* p, Eterm Key, Eterm Pos, Eterm List); + +/* + * erlang:'++'/2 + */ + +Eterm +ebif_plusplus_2(Process* p, Eterm A, Eterm B) +{ + return append_2(p, A, B); +} + +/* + * erlang:'--'/2 + */ + +Eterm +ebif_minusminus_2(Process* p, Eterm A, Eterm B) +{ + return subtract_2(p, A, B); +} + +BIF_RETTYPE append_2(BIF_ALIST_2) +{ + Eterm list; + Eterm copy; + Eterm last; + size_t need; + Eterm* hp; + int i; + + if ((i = list_length(BIF_ARG_1)) < 0) { + BIF_ERROR(BIF_P, BADARG); + } + if (i == 0) { + BIF_RET(BIF_ARG_2); + } else if (is_nil(BIF_ARG_2)) { + BIF_RET(BIF_ARG_1); + } + + need = 2*i; + hp = HAlloc(BIF_P, need); + list = BIF_ARG_1; + copy = last = CONS(hp, CAR(list_val(list)), make_list(hp+2)); + list = CDR(list_val(list)); + hp += 2; + i--; + while(i--) { + Eterm* listp = list_val(list); + last = CONS(hp, CAR(listp), make_list(hp+2)); + list = CDR(listp); + hp += 2; + } + CDR(list_val(last)) = BIF_ARG_2; + BIF_RET(copy); +} + +BIF_RETTYPE subtract_2(BIF_ALIST_2) +{ + Eterm list; + Eterm* hp; + Uint need; + Eterm res; + Eterm small_vec[10]; /* Preallocated memory for small lists */ + Eterm* vec_p; + Eterm* vp; + int i; + int n; + int m; + + if ((n = list_length(BIF_ARG_1)) < 0) { + BIF_ERROR(BIF_P, BADARG); + } + if ((m = list_length(BIF_ARG_2)) < 0) { + BIF_ERROR(BIF_P, BADARG); + } + + if (n == 0) + BIF_RET(NIL); + if (m == 0) + BIF_RET(BIF_ARG_1); + + /* allocate element vector */ + if (n <= sizeof(small_vec)/sizeof(small_vec[0])) + vec_p = small_vec; + else + vec_p = (Eterm*) erts_alloc(ERTS_ALC_T_TMP, n * sizeof(Eterm)); + + /* PUT ALL ELEMENTS IN VP */ + vp = vec_p; + list = BIF_ARG_1; + i = n; + while(i--) { + Eterm* listp = list_val(list); + *vp++ = CAR(listp); + list = CDR(listp); + } + + /* UNMARK ALL DELETED CELLS */ + list = BIF_ARG_2; + m = 0; /* number of deleted elements */ + while(is_list(list)) { + Eterm* listp = list_val(list); + Eterm elem = CAR(listp); + i = n; + vp = vec_p; + while(i--) { + if (is_value(*vp) && eq(*vp, elem)) { + *vp = THE_NON_VALUE; + m++; + break; + } + vp++; + } + list = CDR(listp); + } + + if (m == n) /* All deleted ? */ + res = NIL; + else if (m == 0) /* None deleted ? */ + res = BIF_ARG_1; + else { /* REBUILD LIST */ + res = NIL; + need = 2*(n - m); + hp = HAlloc(BIF_P, need); + vp = vec_p + n - 1; + while(vp >= vec_p) { + if (is_value(*vp)) { + res = CONS(hp, *vp, res); + hp += 2; + } + vp--; + } + } + if (vec_p != small_vec) + erts_free(ERTS_ALC_T_TMP, (void *) vec_p); + BIF_RET(res); +} + +BIF_RETTYPE lists_member_2(BIF_ALIST_2) +{ + Eterm term; + Eterm list; + Eterm item; + int non_immed_key; + int max_iter = 10 * CONTEXT_REDS; + + if (is_nil(BIF_ARG_2)) { + BIF_RET(am_false); + } else if (is_not_list(BIF_ARG_2)) { + BIF_ERROR(BIF_P, BADARG); + } + + term = BIF_ARG_1; + non_immed_key = is_not_immed(term); + list = BIF_ARG_2; + while (is_list(list)) { + if (--max_iter < 0) { + BUMP_ALL_REDS(BIF_P); + BIF_TRAP2(bif_export[BIF_lists_member_2], BIF_P, term, list); + } + item = CAR(list_val(list)); + if ((item == term) || (non_immed_key && eq(item, term))) { + BIF_RET2(am_true, CONTEXT_REDS - max_iter/10); + } + list = CDR(list_val(list)); + } + if (is_not_nil(list)) { + BIF_ERROR(BIF_P, BADARG); + } + BIF_RET2(am_false, CONTEXT_REDS - max_iter/10); +} + +BIF_RETTYPE lists_reverse_2(BIF_ALIST_2) +{ + Eterm list; + Eterm tmp_list; + Eterm result; + Eterm* hp; + Uint n; + int max_iter; + + /* + * Handle legal and illegal non-lists quickly. + */ + if (is_nil(BIF_ARG_1)) { + BIF_RET(BIF_ARG_2); + } else if (is_not_list(BIF_ARG_1)) { + error: + BIF_ERROR(BIF_P, BADARG); + } + + /* + * First use the rest of the remaning heap space. + */ + list = BIF_ARG_1; + result = BIF_ARG_2; + hp = HEAP_TOP(BIF_P); + n = HeapWordsLeft(BIF_P) / 2; + while (n != 0 && is_list(list)) { + Eterm* pair = list_val(list); + result = CONS(hp, CAR(pair), result); + list = CDR(pair); + hp += 2; + n--; + } + HEAP_TOP(BIF_P) = hp; + if (is_nil(list)) { + BIF_RET(result); + } + + /* + * Calculate length of remaining list (up to a suitable limit). + */ + max_iter = CONTEXT_REDS * 40; + n = 0; + tmp_list = list; + while (max_iter-- > 0 && is_list(tmp_list)) { + tmp_list = CDR(list_val(tmp_list)); + n++; + } + if (is_not_nil(tmp_list) && is_not_list(tmp_list)) { + goto error; + } + + /* + * Now do one HAlloc() and continue reversing. + */ + hp = HAlloc(BIF_P, 2*n); + while (n != 0 && is_list(list)) { + Eterm* pair = list_val(list); + result = CONS(hp, CAR(pair), result); + list = CDR(pair); + hp += 2; + n--; + } + if (is_nil(list)) { + BIF_RET(result); + } else { + BUMP_ALL_REDS(BIF_P); + BIF_TRAP2(bif_export[BIF_lists_reverse_2], BIF_P, list, result); + } +} + +BIF_RETTYPE +lists_keymember_3(Process* p, Eterm Key, Eterm Pos, Eterm List) +{ + Eterm res; + + res = keyfind(BIF_lists_keymember_3, p, Key, Pos, List); + if (is_value(res) && is_tuple(res)) { + return am_true; + } else { + return res; + } +} + +BIF_RETTYPE +lists_keysearch_3(Process* p, Eterm Key, Eterm Pos, Eterm List) +{ + Eterm res; + + res = keyfind(BIF_lists_keysearch_3, p, Key, Pos, List); + if (is_non_value(res) || is_not_tuple(res)) { + return res; + } else { /* Tuple */ + Eterm* hp = HAlloc(p, 3); + return TUPLE2(hp, am_value, res); + } +} + +BIF_RETTYPE +lists_keyfind_3(Process* p, Eterm Key, Eterm Pos, Eterm List) +{ + return keyfind(BIF_lists_keyfind_3, p, Key, Pos, List); +} + +static Eterm +keyfind(int Bif, Process* p, Eterm Key, Eterm Pos, Eterm List) +{ + int max_iter = 10 * CONTEXT_REDS; + Sint pos; + Eterm term; + + if (!is_small(Pos) || (pos = signed_val(Pos)) < 1) { + BIF_ERROR(p, BADARG); + } + + if (is_small(Key)) { + double float_key = (double) signed_val(Key); + + while (is_list(List)) { + if (--max_iter < 0) { + BUMP_ALL_REDS(p); + BIF_TRAP3(bif_export[Bif], p, Key, Pos, List); + } + term = CAR(list_val(List)); + List = CDR(list_val(List)); + if (is_tuple(term)) { + Eterm *tuple_ptr = tuple_val(term); + if (pos <= arityval(*tuple_ptr)) { + Eterm element = tuple_ptr[pos]; + if (Key == element) { + return term; + } else if (is_float(element)) { + FloatDef f; + + GET_DOUBLE(element, f); + if (f.fd == float_key) { + return term; + } + } + } + } + } + } else if (is_immed(Key)) { + while (is_list(List)) { + if (--max_iter < 0) { + BUMP_ALL_REDS(p); + BIF_TRAP3(bif_export[Bif], p, Key, Pos, List); + } + term = CAR(list_val(List)); + List = CDR(list_val(List)); + if (is_tuple(term)) { + Eterm *tuple_ptr = tuple_val(term); + if (pos <= arityval(*tuple_ptr)) { + Eterm element = tuple_ptr[pos]; + if (Key == element) { + return term; + } + } + } + } + } else { + while (is_list(List)) { + if (--max_iter < 0) { + BUMP_ALL_REDS(p); + BIF_TRAP3(bif_export[Bif], p, Key, Pos, List); + } + term = CAR(list_val(List)); + List = CDR(list_val(List)); + if (is_tuple(term)) { + Eterm *tuple_ptr = tuple_val(term); + if (pos <= arityval(*tuple_ptr)) { + Eterm element = tuple_ptr[pos]; + if (cmp(Key, element) == 0) { + return term; + } + } + } + } + } + + if (is_not_nil(List)) { + BIF_ERROR(p, BADARG); + } + return am_false; +} diff --git a/erts/emulator/beam/erl_bif_op.c b/erts/emulator/beam/erl_bif_op.c new file mode 100644 index 0000000000..6da72dcef9 --- /dev/null +++ b/erts/emulator/beam/erl_bif_op.c @@ -0,0 +1,327 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1999-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* + * Operator BIFs. + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "erl_process.h" +#include "error.h" +#include "erl_driver.h" +#include "bif.h" +#include "big.h" +#include "dist.h" +#include "erl_version.h" +#include "erl_binary.h" + +BIF_RETTYPE and_2(BIF_ALIST_2) +{ + if (BIF_ARG_1 == am_true && BIF_ARG_2 == am_true) + BIF_RET(am_true); + else if (BIF_ARG_1 == am_true && BIF_ARG_2 == am_false) + BIF_RET(am_false); + else if (BIF_ARG_1 == am_false && BIF_ARG_2 == am_true) + BIF_RET(am_false); + else if (BIF_ARG_1 == am_false && BIF_ARG_2 == am_false) + BIF_RET(am_false); + BIF_ERROR(BIF_P, BADARG); +} + +BIF_RETTYPE or_2(BIF_ALIST_2) +{ + if (BIF_ARG_1 == am_true && BIF_ARG_2 == am_true) + BIF_RET(am_true); + else if (BIF_ARG_1 == am_true && BIF_ARG_2 == am_false) + BIF_RET(am_true); + else if (BIF_ARG_1 == am_false && BIF_ARG_2 == am_true) + BIF_RET(am_true); + else if (BIF_ARG_1 == am_false && BIF_ARG_2 == am_false) + BIF_RET(am_false); + BIF_ERROR(BIF_P, BADARG); +} + +BIF_RETTYPE xor_2(BIF_ALIST_2) +{ + if (BIF_ARG_1 == am_true && BIF_ARG_2 == am_true) + BIF_RET(am_false); + else if (BIF_ARG_1 == am_true && BIF_ARG_2 == am_false) + BIF_RET(am_true); + else if (BIF_ARG_1 == am_false && BIF_ARG_2 == am_true) + BIF_RET(am_true); + else if (BIF_ARG_1 == am_false && BIF_ARG_2 == am_false) + BIF_RET(am_false); + BIF_ERROR(BIF_P, BADARG); +} + +BIF_RETTYPE not_1(BIF_ALIST_1) +{ + if (BIF_ARG_1 == am_true) + BIF_RET(am_false); + else if (BIF_ARG_1 == am_false) + BIF_RET(am_true); + BIF_ERROR(BIF_P, BADARG); +} + +BIF_RETTYPE sgt_2(BIF_ALIST_2) +{ + BIF_RET(cmp_gt(BIF_ARG_1, BIF_ARG_2) ? am_true : am_false); +} + +BIF_RETTYPE sge_2(BIF_ALIST_2) +{ + BIF_RET(cmp_ge(BIF_ARG_1, BIF_ARG_2) ? am_true : am_false); +} + +BIF_RETTYPE slt_2(BIF_ALIST_2) +{ + BIF_RET(cmp_lt(BIF_ARG_1, BIF_ARG_2) ? am_true : am_false); +} + +BIF_RETTYPE sle_2(BIF_ALIST_2) +{ + BIF_RET(cmp_le(BIF_ARG_1, BIF_ARG_2) ? am_true : am_false); +} + +BIF_RETTYPE seq_2(BIF_ALIST_2) +{ + BIF_RET(eq(BIF_ARG_1, BIF_ARG_2) ? am_true : am_false); +} + +BIF_RETTYPE seqeq_2(BIF_ALIST_2) +{ + BIF_RET(cmp_eq(BIF_ARG_1, BIF_ARG_2) ? am_true : am_false); +} + +BIF_RETTYPE sneq_2(BIF_ALIST_2) +{ + BIF_RET(eq(BIF_ARG_1, BIF_ARG_2) ? am_false : am_true); +} + +BIF_RETTYPE sneqeq_2(BIF_ALIST_2) +{ + BIF_RET(cmp_ne(BIF_ARG_1, BIF_ARG_2) ? am_true : am_false); +} + +BIF_RETTYPE is_atom_1(BIF_ALIST_1) +{ + if (is_atom(BIF_ARG_1)) { + BIF_RET(am_true); + } + BIF_RET(am_false); +} + +BIF_RETTYPE is_float_1(BIF_ALIST_1) +{ + if (is_float(BIF_ARG_1)) { + BIF_RET(am_true); + } + BIF_RET(am_false); +} + +BIF_RETTYPE is_integer_1(BIF_ALIST_1) +{ + if (is_integer(BIF_ARG_1)) { + BIF_RET(am_true); + } + BIF_RET(am_false); +} + +BIF_RETTYPE is_list_1(BIF_ALIST_1) +{ + if (is_list(BIF_ARG_1) || is_nil(BIF_ARG_1)) { + BIF_RET(am_true); + } + BIF_RET(am_false); +} + +BIF_RETTYPE is_number_1(BIF_ALIST_1) +{ + if (is_number(BIF_ARG_1)) { + BIF_RET(am_true); + } + BIF_RET(am_false); +} + + +BIF_RETTYPE is_pid_1(BIF_ALIST_1) +{ + if (is_pid(BIF_ARG_1)) { + BIF_RET(am_true); + } + BIF_RET(am_false); +} + +BIF_RETTYPE is_port_1(BIF_ALIST_1) +{ + if (is_port(BIF_ARG_1)) { + BIF_RET(am_true); + } + BIF_RET(am_false); +} + +BIF_RETTYPE is_reference_1(BIF_ALIST_1) +{ + if (is_ref(BIF_ARG_1)) { + BIF_RET(am_true); + } + BIF_RET(am_false); +} + +BIF_RETTYPE is_tuple_1(BIF_ALIST_1) +{ + if (is_tuple(BIF_ARG_1)) { + BIF_RET(am_true); + } + BIF_RET(am_false); +} + +BIF_RETTYPE is_binary_1(BIF_ALIST_1) +{ + if (is_binary(BIF_ARG_1) && binary_bitsize(BIF_ARG_1) == 0) { + BIF_RET(am_true); + } + BIF_RET(am_false); +} + +BIF_RETTYPE is_bitstring_1(BIF_ALIST_1) +{ + if (is_binary(BIF_ARG_1)) { + BIF_RET(am_true); + } + BIF_RET(am_false); +} + +BIF_RETTYPE is_function_1(BIF_ALIST_1) +{ + if (is_any_fun(BIF_ARG_1)) { + BIF_RET(am_true); + } else { + BIF_RET(am_false); + } +} + +BIF_RETTYPE is_function_2(BIF_ALIST_2) +{ + Sint arity; + + /* + * Verify argument 2 (arity); arity must be >= 0. + */ + if (is_small(BIF_ARG_2)) { + arity = signed_val(BIF_ARG_2); + if (arity < 0) { + error: + BIF_ERROR(BIF_P, BADARG); + } + } else if (is_big(BIF_ARG_2) && !bignum_header_is_neg(*big_val(BIF_ARG_2))) { + /* A positive bignum is OK, but can't possibly match. */ + arity = -1; + } else { + /* Everything else (including negative bignum) is an error. */ + goto error; + } + + if (is_fun(BIF_ARG_1)) { + ErlFunThing* funp = (ErlFunThing *) fun_val(BIF_ARG_1); + + if (funp->arity == (Uint) arity) { + BIF_RET(am_true); + } + } else if (is_export(BIF_ARG_1)) { + Export* exp = (Export *) (export_val(BIF_ARG_1))[1]; + + if (exp->code[2] == (Uint) arity) { + BIF_RET(am_true); + } + } else if (is_tuple(BIF_ARG_1)) { + Eterm* tp = tuple_val(BIF_ARG_1); + if (tp[0] == make_arityval(2) && is_atom(tp[1]) && is_atom(tp[2])) { + BIF_RET(am_true); + } + } + BIF_RET(am_false); +} + +BIF_RETTYPE is_boolean_1(BIF_ALIST_1) +{ + if (BIF_ARG_1 == am_true || BIF_ARG_1 == am_false) { + BIF_RET(am_true); + } else { + BIF_RET(am_false); + } +} + + + +/* + * The compiler usually translates calls to is_record/2 to more primitive + * operations. In some cases this is not possible. We'll need to implement + * a weak version of is_record/2 as BIF (the size of the record cannot + * be verified). + */ +BIF_RETTYPE is_record_2(BIF_ALIST_2) +{ + Eterm *t; + + if (is_not_atom(BIF_ARG_2)) { + BIF_ERROR(BIF_P, BADARG); + } + + if (is_tuple(BIF_ARG_1) && + arityval(*(t = tuple_val(BIF_ARG_1))) >= 1 && + t[1] == BIF_ARG_2) { + BIF_RET(am_true); + } + BIF_RET(am_false); +} + + +/* + * Record test cannot actually be a bif. The epp processor is involved in + * the real guard test, we have to add one more parameter, the + * return value of record_info(size, Rec), which is the arity of the TUPLE. + * his may seem awkward when applied from the shell, where the plain + * tuple test is more understandable, I think... + */ +BIF_RETTYPE is_record_3(BIF_ALIST_3) +{ + Eterm *t; + if (is_not_atom(BIF_ARG_2) || is_not_small(BIF_ARG_3)) { + BIF_ERROR(BIF_P, BADARG); + } + + if (is_tuple(BIF_ARG_1) && + arityval(*(t = tuple_val(BIF_ARG_1))) == signed_val(BIF_ARG_3) + && t[1] == BIF_ARG_2) { + BIF_RET(am_true); + } + BIF_RET(am_false); +} + + + + + diff --git a/erts/emulator/beam/erl_bif_os.c b/erts/emulator/beam/erl_bif_os.c new file mode 100644 index 0000000000..954b1f9729 --- /dev/null +++ b/erts/emulator/beam/erl_bif_os.c @@ -0,0 +1,190 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1999-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* + * BIFs belonging to the 'os' module. + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "erl_process.h" +#include "error.h" +#include "erl_driver.h" +#include "bif.h" +#include "big.h" +#include "dist.h" +#include "erl_version.h" + +/* + * Return the pid for the Erlang process in the host OS. + */ + + /* return a timestamp */ +BIF_RETTYPE os_timestamp_0(BIF_ALIST_0) +{ + Uint megasec, sec, microsec; + Eterm* hp; + + get_sys_now(&megasec, &sec, µsec); + hp = HAlloc(BIF_P, 4); + BIF_RET(TUPLE3(hp, make_small(megasec), make_small(sec), + make_small(microsec))); +} + + +Eterm +os_getpid_0(Process* p) +{ + char pid_string[21]; /* enough for a 64 bit number */ + int n; + Eterm* hp; + sys_get_pid(pid_string); /* In sys.c */ + n = sys_strlen(pid_string); + hp = HAlloc(p, n*2); + BIF_RET(buf_to_intlist(&hp, pid_string, n, NIL)); +} + +Eterm +os_getenv_0(Process* p) +{ + GETENV_STATE state; + char *cp; + Eterm* hp; + Eterm ret; + Eterm str; + int len; + + init_getenv_state(&state); + + ret = NIL; + while ((cp = getenv_string(&state)) != NULL) { + len = strlen(cp); + hp = HAlloc(p, len*2+2); + str = buf_to_intlist(&hp, cp, len, NIL); + ret = CONS(hp, str, ret); + } + + fini_getenv_state(&state); + + return ret; +} + +Eterm +os_getenv_1(Process* p, Eterm key) +{ + Eterm str; + int len, res; + char *key_str, *val; + char buf[1024]; + size_t val_size = sizeof(buf); + + len = is_string(key); + if (!len) { + BIF_ERROR(p, BADARG); + } + /* Leave at least one byte in buf for value */ + key_str = len < sizeof(buf)-2 ? &buf[0] : erts_alloc(ERTS_ALC_T_TMP, len+1); + if (intlist_to_buf(key, key_str, len) != len) + erl_exit(1, "%s:%d: Internal error\n", __FILE__, __LINE__); + key_str[len] = '\0'; + + if (key_str != &buf[0]) + val = &buf[0]; + else { + val_size -= len + 1; + val = &buf[len + 1]; + } + res = erts_sys_getenv(key_str, val, &val_size); + + if (res < 0) { + no_var: + str = am_false; + } else { + Eterm* hp; + if (res > 0) { + val = erts_alloc(ERTS_ALC_T_TMP, val_size); + while (1) { + res = erts_sys_getenv(key_str, val, &val_size); + if (res == 0) + break; + else if (res < 0) + goto no_var; + else + val = erts_realloc(ERTS_ALC_T_TMP, val, val_size); + } + } + if (val_size) + hp = HAlloc(p, val_size*2); + str = buf_to_intlist(&hp, val, val_size, NIL); + } + if (key_str != &buf[0]) + erts_free(ERTS_ALC_T_TMP, key_str); + if (val < &buf[0] || &buf[sizeof(buf)-1] < val) + erts_free(ERTS_ALC_T_TMP, val); + BIF_RET(str); +} + +Eterm +os_putenv_2(Process* p, Eterm key, Eterm value) +{ + char def_buf[1024]; + char *buf = NULL; + int sep_ix, i, key_len, value_len, tot_len; + key_len = is_string(key); + if (!key_len) { + error: + if (buf) + erts_free(ERTS_ALC_T_TMP, (void *) buf); + BIF_ERROR(p, BADARG); + } + if (is_nil(value)) + value_len = 0; + else { + value_len = is_string(value); + if (!value_len) + goto error; + } + tot_len = key_len + 1 + value_len + 1; + if (tot_len <= sizeof(def_buf)) + buf = &def_buf[0]; + else + buf = erts_alloc(ERTS_ALC_T_TMP, tot_len); + i = intlist_to_buf(key, buf, key_len); + if (i != key_len) + erl_exit(1, "%s:%d: Internal error\n", __FILE__, __LINE__); + sep_ix = i; + buf[i++] = '='; + if (is_not_nil(value)) + i += intlist_to_buf(value, &buf[i], value_len); + if (i != key_len + 1 + value_len) + erl_exit(1, "%s:%d: Internal error\n", __FILE__, __LINE__); + buf[i] = '\0'; + if (erts_sys_putenv(buf, sep_ix)) { + goto error; + } + if (buf != &def_buf[0]) + erts_free(ERTS_ALC_T_TMP, (void *) buf); + BIF_RET(am_true); +} + diff --git a/erts/emulator/beam/erl_bif_port.c b/erts/emulator/beam/erl_bif_port.c new file mode 100644 index 0000000000..f454f2e12d --- /dev/null +++ b/erts/emulator/beam/erl_bif_port.c @@ -0,0 +1,1476 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2001-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#ifdef _OSE_ +# include "ose.h" +#endif + +#include + +#define ERTS_WANT_EXTERNAL_TAGS +#include "sys.h" +#include "erl_vm.h" +#include "erl_sys_driver.h" +#include "global.h" +#include "erl_process.h" +#include "error.h" +#include "bif.h" +#include "big.h" +#include "dist.h" +#include "erl_version.h" +#include "erl_binary.h" +#include "erl_db_util.h" +#include "register.h" +#include "external.h" +#include "packet_parser.h" +#include "erl_bits.h" + +static int open_port(Process* p, Eterm name, Eterm settings, int *err_nump); +static byte* convert_environment(Process* p, Eterm env); +static char **convert_args(Eterm); +static void free_args(char **); + +char *erts_default_arg0 = "default"; + +BIF_RETTYPE open_port_2(BIF_ALIST_2) +{ + int port_num; + Eterm port_val; + char *str; + int err_num; + + if ((port_num = open_port(BIF_P, BIF_ARG_1, BIF_ARG_2, &err_num)) < 0) { + if (port_num == -3) { + ASSERT(err_num == BADARG || err_num == SYSTEM_LIMIT); + BIF_ERROR(BIF_P, err_num); + } else if (port_num == -2) { + str = erl_errno_id(err_num); + } else { + str = "einval"; + } + BIF_P->fvalue = am_atom_put(str, strlen(str)); + BIF_ERROR(BIF_P, EXC_ERROR); + } + + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_LINK); + + port_val = erts_port[port_num].id; + erts_add_link(&(erts_port[port_num].nlinks), LINK_PID, BIF_P->id); + erts_add_link(&(BIF_P->nlinks), LINK_PID, port_val); + + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_LINK); + + erts_port_release(&erts_port[port_num]); + + BIF_RET(port_val); +} + +/**************************************************************************** + + PORT BIFS: + + port_command/2 -- replace Port ! {..., {command, Data}} + port_command(Port, Data) -> true + when port(Port), io-list(Data) + + port_control/3 -- new port_control(Port, Ctl, Data) -> Reply + port_control(Port, Ctl, Data) -> Reply + where integer(Ctl), io-list(Data), io-list(Reply) + + port_close/1 -- replace Port ! {..., close} + port_close(Port) -> true + when port(Port) + + port_connect/2 -- replace Port ! {..., {connect, Pid}} + port_connect(Port, Pid) + when port(Port), pid(Pid) + + ***************************************************************************/ + +static Port* +id_or_name2port(Process *c_p, Eterm id) +{ + Port *port; + if (is_not_atom(id)) + port = erts_id2port(id, c_p, ERTS_PROC_LOCK_MAIN); + else + erts_whereis_name(c_p, ERTS_PROC_LOCK_MAIN, id, NULL, 0, 0, &port); + return port; +} + +#define ERTS_PORT_COMMAND_FLAG_FORCE (((Uint32) 1) << 0) +#define ERTS_PORT_COMMAND_FLAG_NOSUSPEND (((Uint32) 1) << 1) + +static BIF_RETTYPE do_port_command(Process *BIF_P, + Eterm BIF_ARG_1, + Eterm BIF_ARG_2, + Eterm BIF_ARG_3, + Uint32 flags) +{ + BIF_RETTYPE res; + Port *p; + + /* Trace sched out before lock check wait */ + if (IS_TRACED_FL(BIF_P, F_TRACE_SCHED_PROCS)) { + trace_virtual_sched(BIF_P, am_out); + } + + if (erts_system_profile_flags.runnable_procs && erts_system_profile_flags.exclusive) { + profile_runnable_proc(BIF_P, am_inactive); + } + + p = id_or_name2port(BIF_P, BIF_ARG_1); + if (!p) { + if (IS_TRACED_FL(BIF_P, F_TRACE_SCHED_PROCS)) { + trace_virtual_sched(BIF_P, am_in); + } + if (erts_system_profile_flags.runnable_procs && erts_system_profile_flags.exclusive) { + profile_runnable_proc(BIF_P, am_active); + } + BIF_ERROR(BIF_P, BADARG); + } + + /* Trace port in, id_or_name2port causes wait */ + + if (IS_TRACED_FL(p, F_TRACE_SCHED_PORTS)) { + trace_sched_ports_where(p, am_in, am_command); + } + if (erts_system_profile_flags.runnable_ports && !erts_port_is_scheduled(p)) { + profile_runnable_port(p, am_active); + } + + ERTS_BIF_PREP_RET(res, am_true); + + if ((flags & ERTS_PORT_COMMAND_FLAG_FORCE) + && !(p->drv_ptr->flags & ERL_DRV_FLAG_SOFT_BUSY)) { + ERTS_BIF_PREP_ERROR(res, BIF_P, EXC_NOTSUP); + } + else if (!(flags & ERTS_PORT_COMMAND_FLAG_FORCE) + && p->status & ERTS_PORT_SFLG_PORT_BUSY) { + if (flags & ERTS_PORT_COMMAND_FLAG_NOSUSPEND) { + ERTS_BIF_PREP_RET(res, am_false); + } + else { + erts_suspend(BIF_P, ERTS_PROC_LOCK_MAIN, p); + if (erts_system_monitor_flags.busy_port) { + monitor_generic(BIF_P, am_busy_port, p->id); + } + ERTS_BIF_PREP_YIELD3(res, bif_export[BIF_port_command_3], BIF_P, + BIF_ARG_1, BIF_ARG_2, BIF_ARG_3); + } + } else { + int wres; + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN); + ERTS_SMP_CHK_NO_PROC_LOCKS; + wres = erts_write_to_port(BIF_P->id, p, BIF_ARG_2); + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_MAIN); + if (wres != 0) { + ERTS_BIF_PREP_ERROR(res, BIF_P, BADARG); + } + } + + if (IS_TRACED_FL(p, F_TRACE_SCHED_PORTS)) { + trace_sched_ports_where(p, am_out, am_command); + } + if (erts_system_profile_flags.runnable_ports && !erts_port_is_scheduled(p)) { + profile_runnable_port(p, am_inactive); + } + + erts_port_release(p); + /* Trace sched in after port release */ + if (IS_TRACED_FL(BIF_P, F_TRACE_SCHED_PROCS)) { + trace_virtual_sched(BIF_P, am_in); + } + if (erts_system_profile_flags.runnable_procs && erts_system_profile_flags.exclusive) { + profile_runnable_proc(BIF_P, am_active); + } + + if (ERTS_PROC_IS_EXITING(BIF_P)) { + KILL_CATCHES(BIF_P); /* Must exit */ + ERTS_BIF_PREP_ERROR(res, BIF_P, EXC_ERROR); + } + return res; +} + +BIF_RETTYPE port_command_2(BIF_ALIST_2) +{ + return do_port_command(BIF_P, BIF_ARG_1, BIF_ARG_2, NIL, 0); +} + +BIF_RETTYPE port_command_3(BIF_ALIST_3) +{ + Eterm l = BIF_ARG_3; + Uint32 flags = 0; + while (is_list(l)) { + Eterm* cons = list_val(l); + Eterm car = CAR(cons); + if (car == am_force) { + flags |= ERTS_PORT_COMMAND_FLAG_FORCE; + } else if (car == am_nosuspend) { + flags |= ERTS_PORT_COMMAND_FLAG_NOSUSPEND; + } else { + BIF_ERROR(BIF_P, BADARG); + } + l = CDR(cons); + } + if(!is_nil(l)) { + BIF_ERROR(BIF_P, BADARG); + } + return do_port_command(BIF_P, BIF_ARG_1, BIF_ARG_2, BIF_ARG_3, flags); +} + +BIF_RETTYPE port_call_2(BIF_ALIST_2) +{ + return port_call_3(BIF_P,BIF_ARG_1,make_small(0),BIF_ARG_2); +} + +BIF_RETTYPE port_call_3(BIF_ALIST_3) +{ + Uint op; + Port *p; + Uint size; + byte *bytes; + byte *endp; + size_t real_size; + erts_driver_t *drv; + byte port_input[256]; /* Default input buffer to encode in */ + byte port_result[256]; /* Buffer for result from port. */ + byte* port_resp; /* Pointer to result buffer. */ + char *prc; + int ret; + Eterm res; + Sint result_size; + Eterm *hp; + Eterm *hp_end; /* To satisfy hybrid heap architecture */ + unsigned ret_flags = 0U; + int fpe_was_unmasked; + + bytes = &port_input[0]; + port_resp = port_result; + /* trace of port scheduling with virtual process descheduling + * lock wait + */ + if (IS_TRACED_FL(BIF_P, F_TRACE_SCHED_PROCS)) { + trace_virtual_sched(BIF_P, am_out); + } + + if (erts_system_profile_flags.runnable_procs && erts_system_profile_flags.exclusive) { + profile_runnable_proc(BIF_P, am_inactive); + } + + p = id_or_name2port(BIF_P, BIF_ARG_1); + if (!p) { + error: + if (port_resp != port_result && + !(ret_flags & DRIVER_CALL_KEEP_BUFFER)) { + driver_free(port_resp); + } + if (bytes != &port_input[0]) + erts_free(ERTS_ALC_T_PORT_CALL_BUF, bytes); + /* Need to virtual schedule in the process if there + * was an error. + */ + if (IS_TRACED_FL(BIF_P, F_TRACE_SCHED_PROCS)) { + trace_virtual_sched(BIF_P, am_in); + } + + if (erts_system_profile_flags.runnable_procs && erts_system_profile_flags.exclusive) { + profile_runnable_proc(BIF_P, am_active); + } + + if (p) + erts_port_release(p); +#ifdef ERTS_SMP + ERTS_SMP_BIF_CHK_PENDING_EXIT(BIF_P, ERTS_PROC_LOCK_MAIN); +#else + ERTS_BIF_CHK_EXITED(BIF_P); +#endif + BIF_ERROR(BIF_P, BADARG); + } + + if ((drv = p->drv_ptr) == NULL) { + goto error; + } + if (drv->call == NULL) { + goto error; + } + if (!term_to_Uint(BIF_ARG_2, &op)) { + goto error; + } + p->caller = BIF_P->id; + + /* Lock taken, virtual schedule of port */ + if (IS_TRACED_FL(p, F_TRACE_SCHED_PORTS)) { + trace_sched_ports_where(p, am_in, am_call); + } + + if (erts_system_profile_flags.runnable_ports && !erts_port_is_scheduled(p)) { + profile_runnable_port(p, am_active); + } + size = erts_encode_ext_size(BIF_ARG_3); + if (size > sizeof(port_input)) + bytes = erts_alloc(ERTS_ALC_T_PORT_CALL_BUF, size); + + endp = bytes; + erts_encode_ext(BIF_ARG_3, &endp); + + real_size = endp - bytes; + if (real_size > size) { + erl_exit(1, "%s, line %d: buffer overflow: %d word(s)\n", + __FILE__, __LINE__, endp - (bytes + size)); + } + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN); + prc = (char *) port_resp; + fpe_was_unmasked = erts_block_fpe(); + ret = drv->call((ErlDrvData)p->drv_data, + (unsigned) op, + (char *) bytes, + (int) real_size, + &prc, + (int) sizeof(port_result), + &ret_flags); + erts_unblock_fpe(fpe_was_unmasked); + if (IS_TRACED_FL(p, F_TRACE_SCHED_PORTS)) { + trace_sched_ports_where(p, am_out, am_call); + } + + if (erts_system_profile_flags.runnable_ports && !erts_port_is_scheduled(p)) { + profile_runnable_port(p, am_inactive); + } + + port_resp = (byte *) prc; + p->caller = NIL; + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_MAIN); +#ifdef HARDDEBUG + { + int z; + printf("real_size = %ld,%d, ret = %d\r\n",real_size, + (int) real_size, ret); + printf("["); + for(z = 0; z < real_size; ++z) { + printf("%d, ",(int) bytes[z]); + } + printf("]\r\n"); + printf("["); + for(z = 0; z < ret; ++z) { + printf("%d, ",(int) port_resp[z]); + } + printf("]\r\n"); + } +#endif + if (ret <= 0 || port_resp[0] != VERSION_MAGIC) { + /* Error or a binary without magic/ with wrong magic */ + goto error; + } + result_size = erts_decode_ext_size(port_resp, ret, 0); + if (result_size < 0) { + goto error; + } + hp = HAlloc(BIF_P, result_size); + hp_end = hp + result_size; + endp = port_resp; + res = erts_decode_ext(&hp, &MSO(BIF_P), &endp); + if (res == THE_NON_VALUE) { + goto error; + } + HRelease(BIF_P, hp_end, hp); + if (port_resp != port_result && !(ret_flags & DRIVER_CALL_KEEP_BUFFER)) { + driver_free(port_resp); + } + if (bytes != &port_input[0]) + erts_free(ERTS_ALC_T_PORT_CALL_BUF, bytes); + if (p) + erts_port_release(p); +#ifdef ERTS_SMP + ERTS_SMP_BIF_CHK_PENDING_EXIT(BIF_P, ERTS_PROC_LOCK_MAIN); +#else + ERTS_BIF_CHK_EXITED(BIF_P); +#endif + if (IS_TRACED_FL(BIF_P, F_TRACE_SCHED_PROCS)) { + trace_virtual_sched(BIF_P, am_in); + } + + if (erts_system_profile_flags.runnable_procs && erts_system_profile_flags.exclusive) { + profile_runnable_proc(BIF_P, am_active); + } + + return res; +} + +BIF_RETTYPE port_control_3(BIF_ALIST_3) +{ + Port* p; + Uint op; + Eterm res = THE_NON_VALUE; + + /* Virtual schedule out calling process before lock wait */ + if (IS_TRACED_FL(BIF_P, F_TRACE_SCHED_PROCS)) { + trace_virtual_sched(BIF_P, am_out); + } + + if (erts_system_profile_flags.runnable_procs && erts_system_profile_flags.exclusive) { + profile_runnable_proc(BIF_P, am_inactive); + } + + p = id_or_name2port(BIF_P, BIF_ARG_1); + if (!p) { + /* Schedule the process before exiting */ + if (IS_TRACED_FL(BIF_P, F_TRACE_SCHED_PROCS)) { + trace_virtual_sched(BIF_P, am_in); + } + + if (erts_system_profile_flags.runnable_procs && erts_system_profile_flags.exclusive) { + profile_runnable_proc(BIF_P, am_active); + } + + BIF_ERROR(BIF_P, BADARG); + } + + /* Trace the port for scheduling in */ + if (IS_TRACED_FL(p, F_TRACE_SCHED_PORTS)) { + trace_sched_ports_where(p, am_in, am_control); + } + + if (erts_system_profile_flags.runnable_ports && !erts_port_is_scheduled(p)) { + profile_runnable_port(p, am_active); + } + + if (term_to_Uint(BIF_ARG_2, &op)) + res = erts_port_control(BIF_P, p, op, BIF_ARG_3); + + /* Trace the port for scheduling out */ + if (IS_TRACED_FL(p, F_TRACE_SCHED_PORTS)) { + trace_sched_ports_where(p, am_out, am_control); + } + + if (erts_system_profile_flags.runnable_ports && !erts_port_is_scheduled(p)) { + profile_runnable_port(p, am_inactive); + } + + erts_port_release(p); +#ifdef ERTS_SMP + ERTS_SMP_BIF_CHK_PENDING_EXIT(BIF_P, ERTS_PROC_LOCK_MAIN); +#else + ERTS_BIF_CHK_EXITED(BIF_P); +#endif + + if (IS_TRACED_FL(BIF_P, F_TRACE_SCHED_PROCS)) { + trace_virtual_sched(BIF_P, am_in); + } + + if (erts_system_profile_flags.runnable_procs && erts_system_profile_flags.exclusive) { + profile_runnable_proc(BIF_P, am_active); + } + + if (is_non_value(res)) { + BIF_ERROR(BIF_P, BADARG); + } + BIF_RET(res); +} + +BIF_RETTYPE port_close_1(BIF_ALIST_1) +{ + Port* p; + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN); + p = id_or_name2port(NULL, BIF_ARG_1); + if (!p) { + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_MAIN); + BIF_ERROR(BIF_P, BADARG); + } + erts_do_exit_port(p, p->connected, am_normal); + /* if !ERTS_SMP: since we terminate port with reason normal + we SHOULD never get an exit signal ourselves + */ + erts_port_release(p); + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_MAIN); + BIF_RET(am_true); +} + +BIF_RETTYPE port_connect_2(BIF_ALIST_2) +{ + Port* prt; + Process* rp; + Eterm pid = BIF_ARG_2; + + if (is_not_internal_pid(pid)) { + error: + BIF_ERROR(BIF_P, BADARG); + } + prt = id_or_name2port(BIF_P, BIF_ARG_1); + if (!prt) { + goto error; + } + + rp = erts_pid2proc(BIF_P, ERTS_PROC_LOCK_MAIN, + pid, ERTS_PROC_LOCK_LINK); + if (!rp) { + erts_smp_port_unlock(prt); + ERTS_SMP_ASSERT_IS_NOT_EXITING(BIF_P); + goto error; + } + + erts_add_link(&(rp->nlinks), LINK_PID, prt->id); + erts_add_link(&(prt->nlinks), LINK_PID, pid); + + erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_LINK); + + prt->connected = pid; /* internal pid */ + erts_smp_port_unlock(prt); + BIF_RET(am_true); +} + +BIF_RETTYPE port_set_data_2(BIF_ALIST_2) +{ + Port* prt; + Eterm portid = BIF_ARG_1; + Eterm data = BIF_ARG_2; + + prt = id_or_name2port(BIF_P, portid); + if (!prt) { + BIF_ERROR(BIF_P, BADARG); + } + if (prt->bp != NULL) { + free_message_buffer(prt->bp); + prt->bp = NULL; + } + if (IS_CONST(data)) { + prt->data = data; + } else { + Uint size; + ErlHeapFragment* bp; + Eterm* hp; + + size = size_object(data); + prt->bp = bp = new_message_buffer(size); + hp = bp->mem; + prt->data = copy_struct(data, size, &hp, &bp->off_heap); + } + erts_smp_port_unlock(prt); + BIF_RET(am_true); +} + + +BIF_RETTYPE port_get_data_1(BIF_ALIST_1) +{ + BIF_RETTYPE res; + Port* prt; + Eterm portid = BIF_ARG_1; + + prt = id_or_name2port(BIF_P, portid); + if (!prt) { + BIF_ERROR(BIF_P, BADARG); + } + if (prt->bp == NULL) { /* MUST be CONST! */ + res = prt->data; + } else { + Eterm* hp = HAlloc(BIF_P, prt->bp->size); + res = copy_struct(prt->data, prt->bp->size, &hp, &MSO(BIF_P)); + } + erts_smp_port_unlock(prt); + BIF_RET(res); +} + +/* + * Open a port. Most of the work is not done here but rather in + * the file io.c. + * Error returns: -1 or -2 returned from open_driver (-2 implies + * that *err_nump contains the error code; -1 means we don't really know what happened), + * -3 if argument parsing failed or we are out of ports (*err_nump should contain + * either BADARG or SYSTEM_LIMIT). + */ + +static int +open_port(Process* p, Eterm name, Eterm settings, int *err_nump) +{ +#define OPEN_PORT_ERROR(VAL) do { port_num = (VAL); goto do_return; } while (0) + int i, port_num; + Eterm option; + Uint arity; + Eterm* tp; + Uint* nargs; + erts_driver_t* driver; + char* name_buf = NULL; + SysDriverOpts opts; + int binary_io; + int soft_eof; + Sint linebuf; + byte dir[MAXPATHLEN]; + + /* These are the defaults */ + opts.packet_bytes = 0; + opts.use_stdio = 1; + opts.redir_stderr = 0; + opts.read_write = 0; + opts.hide_window = 0; + opts.wd = NULL; + opts.envir = NULL; + opts.exit_status = 0; + opts.overlapped_io = 0; + opts.spawn_type = ERTS_SPAWN_ANY; + opts.argv = NULL; + binary_io = 0; + soft_eof = 0; + linebuf = 0; + + *err_nump = 0; + + if (is_not_list(settings) && is_not_nil(settings)) { + goto badarg; + } + /* + * Parse the settings. + */ + + if (is_not_nil(settings)) { + nargs = list_val(settings); + while (1) { + if (is_tuple_arity(*nargs, 2)) { + tp = tuple_val(*nargs); + arity = *tp++; + option = *tp++; + if (option == am_packet) { + if (is_not_small(*tp)) { + goto badarg; + } + opts.packet_bytes = signed_val(*tp); + switch (opts.packet_bytes) { + case 1: + case 2: + case 4: + break; + default: + goto badarg; + } + } else if (option == am_line) { + if (is_not_small(*tp)) { + goto badarg; + } + linebuf = signed_val(*tp); + if (linebuf <= 0) { + goto badarg; + } + } else if (option == am_env) { + byte* bytes; + if ((bytes = convert_environment(p, *tp)) == NULL) { + goto badarg; + } + opts.envir = (char *) bytes; + } else if (option == am_args) { + char **av; + char **oav = opts.argv; + if ((av = convert_args(*tp)) == NULL) { + goto badarg; + } + opts.argv = av; + if (oav) { + opts.argv[0] = oav[0]; + oav[0] = erts_default_arg0; + free_args(oav); + } + + } else if (option == am_arg0) { + char *a0; + int n; + if (is_nil(*tp)) { + n = 0; + } else if( (n = is_string(*tp)) == 0) { + goto badarg; + } + a0 = (char *) erts_alloc(ERTS_ALC_T_TMP, + (n + 1) * sizeof(byte)); + if (intlist_to_buf(*tp, a0, n) != n) { + erl_exit(1, "%s:%d: Internal error\n", + __FILE__, __LINE__); + } + a0[n] = '\0'; + if (opts.argv == NULL) { + opts.argv = erts_alloc(ERTS_ALC_T_TMP, + 2 * sizeof(char **)); + opts.argv[0] = a0; + opts.argv[1] = NULL; + } else { + if (opts.argv[0] != erts_default_arg0) { + erts_free(ERTS_ALC_T_TMP, opts.argv[0]); + } + opts.argv[0] = a0; + } + } else if (option == am_cd) { + Eterm iolist; + Eterm heap[4]; + int r; + + heap[0] = *tp; + heap[1] = make_list(heap+2); + heap[2] = make_small(0); + heap[3] = NIL; + iolist = make_list(heap); + r = io_list_to_buf(iolist, (char*) dir, MAXPATHLEN); + if (r < 0) { + goto badarg; + } + opts.wd = (char *) dir; + } else { + goto badarg; + } + } else if (*nargs == am_stream) { + opts.packet_bytes = 0; + } else if (*nargs == am_use_stdio) { + opts.use_stdio = 1; + } else if (*nargs == am_stderr_to_stdout) { + opts.redir_stderr = 1; + } else if (*nargs == am_line) { + linebuf = 512; + } else if (*nargs == am_nouse_stdio) { + opts.use_stdio = 0; + } else if (*nargs == am_binary) { + binary_io = 1; + } else if (*nargs == am_in) { + opts.read_write |= DO_READ; + } else if (*nargs == am_out) { + opts.read_write |= DO_WRITE; + } else if (*nargs == am_eof) { + soft_eof = 1; + } else if (*nargs == am_hide) { + opts.hide_window = 1; + } else if (*nargs == am_exit_status) { + opts.exit_status = 1; + } else if (*nargs == am_overlapped_io) { + opts.overlapped_io = 1; + } else { + goto badarg; + } + if (is_nil(*++nargs)) + break; + if (is_not_list(*nargs)) { + goto badarg; + } + nargs = list_val(*nargs); + } + } + if (opts.read_write == 0) /* implement default */ + opts.read_write = DO_READ|DO_WRITE; + + /* Mutually exclusive arguments. */ + if((linebuf && opts.packet_bytes) || + (opts.redir_stderr && !opts.use_stdio)) { + goto badarg; + } + + /* + * Parse the first argument and start the appropriate driver. + */ + + if (is_atom(name) || (i = is_string(name))) { + /* a vanilla port */ + if (is_atom(name)) { + name_buf = (char *) erts_alloc(ERTS_ALC_T_TMP, + atom_tab(atom_val(name))->len+1); + sys_memcpy((void *) name_buf, + (void *) atom_tab(atom_val(name))->name, + atom_tab(atom_val(name))->len); + name_buf[atom_tab(atom_val(name))->len] = '\0'; + } else { + name_buf = (char *) erts_alloc(ERTS_ALC_T_TMP, i + 1); + if (intlist_to_buf(name, name_buf, i) != i) + erl_exit(1, "%s:%d: Internal error\n", __FILE__, __LINE__); + name_buf[i] = '\0'; + } + driver = &vanilla_driver; + } else { + if (is_not_tuple(name)) { + goto badarg; /* Not a process or fd port */ + } + tp = tuple_val(name); + arity = *tp++; + + if (arity == make_arityval(0)) { + goto badarg; + } + + if (*tp == am_spawn || *tp == am_spawn_driver) { /* A process port */ + if (arity != make_arityval(2)) { + goto badarg; + } + name = tp[1]; + if (is_atom(name)) { + name_buf = (char *) erts_alloc(ERTS_ALC_T_TMP, + atom_tab(atom_val(name))->len+1); + sys_memcpy((void *) name_buf, + (void *) atom_tab(atom_val(name))->name, + atom_tab(atom_val(name))->len); + name_buf[atom_tab(atom_val(name))->len] = '\0'; + } else if ((i = is_string(name))) { + name_buf = (char *) erts_alloc(ERTS_ALC_T_TMP, i + 1); + if (intlist_to_buf(name, name_buf, i) != i) + erl_exit(1, "%s:%d: Internal error\n", __FILE__, __LINE__); + name_buf[i] = '\0'; + } else { + goto badarg; + } + if (*tp == am_spawn_driver) { + opts.spawn_type = ERTS_SPAWN_DRIVER; + } + driver = &spawn_driver; + } else if (*tp == am_spawn_executable) { /* A program */ + /* + * {spawn_executable,Progname} + */ + + if (arity != make_arityval(2)) { + goto badarg; + } + name = tp[1]; + if (is_atom(name)) { + name_buf = (char *) erts_alloc(ERTS_ALC_T_TMP, + atom_tab(atom_val(name))->len+1); + sys_memcpy((void *) name_buf, + (void *) atom_tab(atom_val(name))->name, + atom_tab(atom_val(name))->len); + name_buf[atom_tab(atom_val(name))->len] = '\0'; + } else if ((i = is_string(name))) { + name_buf = (char *) erts_alloc(ERTS_ALC_T_TMP, i + 1); + if (intlist_to_buf(name, name_buf, i) != i) + erl_exit(1, "%s:%d: Internal error\n", __FILE__, __LINE__); + name_buf[i] = '\0'; + } else { + goto badarg; + } + opts.spawn_type = ERTS_SPAWN_EXECUTABLE; + driver = &spawn_driver; + } else if (*tp == am_fd) { /* An fd port */ + int n; + struct Sint_buf sbuf; + char* p; + + if (arity != make_arityval(3)) { + goto badarg; + } + if (is_not_small(tp[1]) || is_not_small(tp[2])) { + goto badarg; + } + opts.ifd = unsigned_val(tp[1]); + opts.ofd = unsigned_val(tp[2]); + + /* Syntesize name from input and output descriptor. */ + name_buf = erts_alloc(ERTS_ALC_T_TMP, + 2*sizeof(struct Sint_buf) + 2); + p = Sint_to_buf(opts.ifd, &sbuf); + n = sys_strlen(p); + sys_strncpy(name_buf, p, n); + name_buf[n] = '/'; + p = Sint_to_buf(opts.ofd, &sbuf); + sys_strcpy(name_buf+n+1, p); + + driver = &fd_driver; + } else { + goto badarg; + } + } + + if ((driver != &spawn_driver && opts.argv != NULL) || + (driver == &spawn_driver && + opts.spawn_type != ERTS_SPAWN_EXECUTABLE && + opts.argv != NULL)) { + /* Argument vector only if explicit spawn_executable */ + goto badarg; + } + + + if (driver != &spawn_driver && opts.exit_status) { + goto badarg; + } + + if (IS_TRACED_FL(p, F_TRACE_SCHED_PROCS)) { + trace_virtual_sched(p, am_out); + } + + + erts_smp_proc_unlock(p, ERTS_PROC_LOCK_MAIN); + + port_num = erts_open_driver(driver, p->id, name_buf, &opts, err_nump); + + erts_smp_proc_lock(p, ERTS_PROC_LOCK_MAIN); + + if (port_num < 0) { + DEBUGF(("open_driver returned %d(%d)\n", port_num, *err_nump)); + if (IS_TRACED_FL(p, F_TRACE_SCHED_PROCS)) { + trace_virtual_sched(p, am_in); + } + OPEN_PORT_ERROR(port_num); + } + + if (IS_TRACED_FL(p, F_TRACE_SCHED_PROCS)) { + trace_virtual_sched(p, am_in); + } + + if (binary_io) { + erts_port_status_bor_set(&erts_port[port_num], + ERTS_PORT_SFLG_BINARY_IO); + } + if (soft_eof) { + erts_port_status_bor_set(&erts_port[port_num], + ERTS_PORT_SFLG_SOFT_EOF); + } + if (linebuf && erts_port[port_num].linebuf == NULL){ + erts_port[port_num].linebuf = allocate_linebuf(linebuf); + erts_port_status_bor_set(&erts_port[port_num], + ERTS_PORT_SFLG_LINEBUF_IO); + } + + do_return: + if (name_buf) + erts_free(ERTS_ALC_T_TMP, (void *) name_buf); + if (opts.argv) { + free_args(opts.argv); + } + return port_num; + + badarg: + *err_nump = BADARG; + OPEN_PORT_ERROR(-3); + goto do_return; +#undef OPEN_PORT_ERROR +} + +static char **convert_args(Eterm l) +{ + char **pp; + char *b; + int n; + int i = 0; + Eterm str; + /* We require at least one element in list (argv[0]) */ + if (is_not_list(l) && is_not_nil(l)) { + return NULL; + } + n = list_length(l); + pp = erts_alloc(ERTS_ALC_T_TMP, (n + 2) * sizeof(char **)); + pp[i++] = erts_default_arg0; + while (is_list(l)) { + str = CAR(list_val(l)); + + if (is_nil(str)) { + n = 0; + } else if( (n = is_string(str)) == 0) { + /* Not a string... */ + int j; + for (j = 1; j < i; ++j) + erts_free(ERTS_ALC_T_TMP, pp[j]); + erts_free(ERTS_ALC_T_TMP, pp); + return NULL; + } + b = (char *) erts_alloc(ERTS_ALC_T_TMP, (n + 1) * sizeof(byte)); + pp[i++] = (char *) b; + if (intlist_to_buf(str, b, n) != n) + erl_exit(1, "%s:%d: Internal error\n", __FILE__, __LINE__); + b[n] = '\0'; + l = CDR(list_val(l)); + } + pp[i] = NULL; + return pp; +} + +static void free_args(char **av) +{ + int i; + if (av == NULL) + return; + for (i = 0; av[i] != NULL; ++i) { + if (av[i] != erts_default_arg0) { + erts_free(ERTS_ALC_T_TMP, av[i]); + } + } + erts_free(ERTS_ALC_T_TMP, av); +} + + +static byte* convert_environment(Process* p, Eterm env) +{ + Eterm all; + Eterm* temp_heap; + Eterm* hp; + Uint heap_size; + int n; + byte* bytes; + + if ((n = list_length(env)) < 0) { + return NULL; + } + heap_size = 2*(5*n+1); + temp_heap = hp = (Eterm *) erts_alloc(ERTS_ALC_T_TMP, heap_size*sizeof(Eterm)); + bytes = NULL; /* Indicating error */ + + /* + * All errors below are handled by jumping to 'done', to ensure that the memory + * gets deallocated. Do NOT return directly from this function. + */ + + all = CONS(hp, make_small(0), NIL); + hp += 2; + + while(is_list(env)) { + Eterm tmp; + Eterm* tp; + + tmp = CAR(list_val(env)); + if (is_not_tuple_arity(tmp, 2)) { + goto done; + } + tp = tuple_val(tmp); + tmp = CONS(hp, make_small(0), NIL); + hp += 2; + if (tp[2] != am_false) { + tmp = CONS(hp, tp[2], tmp); + hp += 2; + } + tmp = CONS(hp, make_small('='), tmp); + hp += 2; + tmp = CONS(hp, tp[1], tmp); + hp += 2; + all = CONS(hp, tmp, all); + hp += 2; + env = CDR(list_val(env)); + } + if (is_not_nil(env)) { + goto done; + } + if ((n = io_list_len(all)) < 0) { + goto done; + } + + /* + * Put the result in a binary (no risk for a memory leak that way). + */ + (void) erts_new_heap_binary(p, NULL, n, &bytes); + io_list_to_buf(all, (char*)bytes, n); + + done: + erts_free(ERTS_ALC_T_TMP, temp_heap); + return bytes; +} + +/* ------------ decode_packet() and friends: */ + +struct packet_callback_args +{ + Process* p; /* In */ + Eterm res; /* Out */ + int string_as_bin; /* return strings as binaries (http_bin): */ + byte* aligned_ptr; + Eterm orig; + Uint bin_offs; + byte bin_bitoffs; +}; + +static Eterm +http_bld_string(struct packet_callback_args* pca, Uint **hpp, Uint *szp, + const char *str, Sint len) +{ + Eterm res = THE_NON_VALUE; + Uint size; + + if (pca->string_as_bin) { + size = heap_bin_size(len); + + if (szp) { + *szp += (size > ERL_SUB_BIN_SIZE) ? ERL_SUB_BIN_SIZE : size; + } + if (hpp) { + res = make_binary(*hpp); + if (size > ERL_SUB_BIN_SIZE) { + ErlSubBin* bin = (ErlSubBin*) *hpp; + bin->thing_word = HEADER_SUB_BIN; + bin->size = len; + bin->offs = pca->bin_offs + ((byte*)str - pca->aligned_ptr); + bin->orig = pca->orig; + bin->bitoffs = pca->bin_bitoffs; + bin->bitsize = 0; + bin->is_writable = 0; + *hpp += ERL_SUB_BIN_SIZE; + } + else { + ErlHeapBin* bin = (ErlHeapBin*) *hpp; + bin->thing_word = header_heap_bin(len); + bin->size = len; + memcpy(bin->data, str, len); + *hpp += size; + } + } + } + else { + res = erts_bld_string_n(hpp, szp, str, len); + } + return res; +} + +static int http_response_erl(void *arg, int major, int minor, + int status, const char* phrase, int phrase_len) +{ + /* {http_response,{Major,Minor},Status,"Phrase"} */ + struct packet_callback_args* pca = (struct packet_callback_args*) arg; + Eterm phrase_term, ver; + Uint hsize = 3 + 5; + Eterm* hp; +#ifdef DEBUG + Eterm* hend; +#endif + + http_bld_string(pca, NULL, &hsize, phrase, phrase_len); + hp = HAlloc(pca->p, hsize); +#ifdef DEBUG + hend = hp + hsize; +#endif + phrase_term = http_bld_string(pca, &hp, NULL, phrase, phrase_len); + ver = TUPLE2(hp, make_small(major), make_small(minor)); + hp += 3; + pca->res = TUPLE4(hp, am_http_response, ver, make_small(status), phrase_term); + ASSERT(hp+5==hend); + return 1; +} + +static Eterm http_bld_uri(struct packet_callback_args* pca, + Eterm** hpp, Uint* szp, const PacketHttpURI* uri) +{ + Eterm s1, s2; + if (uri->type == URI_STAR) { + return am_Times; /* '*' */ + } + + s1 = http_bld_string(pca, hpp, szp, uri->s1_ptr, uri->s1_len); + + switch (uri->type) { + case URI_ABS_PATH: + return erts_bld_tuple(hpp, szp, 2, am_abs_path, s1); + case URI_HTTP: + case URI_HTTPS: + s2 = http_bld_string(pca, hpp, szp, uri->s2_ptr, uri->s2_len); + return erts_bld_tuple + (hpp, szp, 5, am_absoluteURI, + ((uri->type==URI_HTTP) ? am_http : am_https), + s1, + ((uri->port==0) ? am_undefined : make_small(uri->port)), + s2); + + case URI_STRING: + return s1; + case URI_SCHEME: + s2 = http_bld_string(pca, hpp, szp, uri->s2_ptr, uri->s2_len); + return erts_bld_tuple(hpp, szp, 3, am_scheme, s1, s2); + + default: + erl_exit(1, "%s, line %d: type=%u\n", __FILE__, __LINE__, uri->type); + } +} + +static int http_request_erl(void* arg, const http_atom_t* meth, + const char* meth_ptr, int meth_len, + const PacketHttpURI* uri, int major, int minor) +{ + struct packet_callback_args* pca = (struct packet_callback_args*) arg; + Eterm meth_term, uri_term, ver_term; + Uint sz = 0; + Uint* szp = &sz; + Eterm* hp; + Eterm** hpp = NULL; + + /* {http_request,Meth,Uri,Version} */ + + for (;;) { + meth_term = (meth!=NULL) ? meth->atom : + http_bld_string(pca, hpp, szp, meth_ptr, meth_len); + uri_term = http_bld_uri(pca, hpp, szp, uri); + ver_term = erts_bld_tuple(hpp, szp, 2, + make_small(major), make_small(minor)); + pca->res = erts_bld_tuple(hpp, szp, 4, am_http_request, meth_term, + uri_term, ver_term); + if (hpp != NULL) break; + hpp = &hp; + hp = HAlloc(pca->p, sz); + szp = NULL; + } + return 1; +} + +static int +http_header_erl(void* arg, const http_atom_t* name, const char* name_ptr, + int name_len, const char* value_ptr, int value_len) +{ + struct packet_callback_args* pca = (struct packet_callback_args*) arg; + Eterm bit_term, name_term, val_term; + Uint sz = 6; + Eterm* hp; +#ifdef DEBUG + Eterm* hend; +#endif + + /* {http_header,Bit,Name,IValue,Value} */ + + if (name == NULL) { + http_bld_string(pca, NULL, &sz, name_ptr, name_len); + } + http_bld_string(pca, NULL, &sz, value_ptr, value_len); + + hp = HAlloc(pca->p, sz); +#ifdef DEBUG + hend = hp + sz; +#endif + + if (name != NULL) { + bit_term = make_small(name->index+1); + name_term = name->atom; + } + else { + bit_term = make_small(0); + name_term = http_bld_string(pca, &hp,NULL,name_ptr,name_len); + } + + val_term = http_bld_string(pca, &hp, NULL, value_ptr, value_len); + pca->res = TUPLE5(hp, am_http_header, bit_term, name_term, am_undefined, val_term); + ASSERT(hp+6==hend); + return 1; +} + +static int http_eoh_erl(void* arg) +{ + /* http_eoh */ + struct packet_callback_args* pca = (struct packet_callback_args*) arg; + pca->res = am_http_eoh; + return 1; +} + +static int http_error_erl(void* arg, const char* buf, int len) +{ + /* {http_error,Line} */ + struct packet_callback_args* pca = (struct packet_callback_args*) arg; + Uint sz = 3; + Eterm* hp; +#ifdef DEBUG + Eterm* hend; +#endif + + http_bld_string(pca, NULL, &sz, buf, len); + + hp = HAlloc(pca->p, sz); +#ifdef DEBUG + hend = hp + sz; +#endif + pca->res = erts_bld_tuple(&hp, NULL, 2, am_http_error, + http_bld_string(pca, &hp, NULL, buf, len)); + ASSERT(hp==hend); + return 1; +} + +static +int ssl_tls_erl(void* arg, unsigned type, unsigned major, unsigned minor, + const char* buf, int len, const char* prefix, int plen) +{ + struct packet_callback_args* pca = (struct packet_callback_args*) arg; + Eterm* hp; + Eterm ver; + Eterm bin = new_binary(pca->p, NULL, plen+len); + byte* bin_ptr = binary_bytes(bin); + + memcpy(bin_ptr+plen, buf, len); + if (plen) { + memcpy(bin_ptr, prefix, plen); + } + + /* {ssl_tls,NIL,ContentType,{Major,Minor},Bin} */ + hp = HAlloc(pca->p, 3+6); + ver = TUPLE2(hp, make_small(major), make_small(minor)); + hp += 3; + pca->res = TUPLE5(hp, am_ssl_tls, NIL, make_small(type), ver, bin); + return 1; +} + + +PacketCallbacks packet_callbacks_erl = { + http_response_erl, + http_request_erl, + http_eoh_erl, + http_header_erl, + http_error_erl, + ssl_tls_erl +}; + +/* + decode_packet(Type,Bin,Options) + Returns: + {ok, PacketBodyBin, RestBin} + {more, PacketSz | undefined} + {error, invalid} +*/ +BIF_RETTYPE decode_packet_3(BIF_ALIST_3) +{ + unsigned max_plen = 0; /* Packet max length, 0=no limit */ + unsigned trunc_len = 0; /* Truncate lines if longer, 0=no limit */ + int http_state = 0; /* 0=request/response 1=header */ + int packet_sz; /*-------Binaries involved: ------------------*/ + byte* bin_ptr; /*| orig: original binary */ + byte bin_bitsz; /*| bin: BIF_ARG_2, may be sub-binary of orig */ + Uint bin_sz; /*| packet: prefix of bin */ + char* body_ptr; /*| body: part of packet to return */ + int body_sz; /*| rest: bin without packet */ + struct packet_callback_args pca; + enum PacketParseType type; + Eterm* hp; + Eterm* hend; + ErlSubBin* rest; + Eterm res; + Eterm options; + int code; + + if (!is_binary(BIF_ARG_2) || + (!is_list(BIF_ARG_3) && !is_nil(BIF_ARG_3))) { + BIF_ERROR(BIF_P, BADARG); + } + switch (BIF_ARG_1) { + case make_small(0): case am_raw: type = TCP_PB_RAW; break; + case make_small(1): type = TCP_PB_1; break; + case make_small(2): type = TCP_PB_2; break; + case make_small(4): type = TCP_PB_4; break; + case am_asn1: type = TCP_PB_ASN1; break; + case am_sunrm: type = TCP_PB_RM; break; + case am_cdr: type = TCP_PB_CDR; break; + case am_fcgi: type = TCP_PB_FCGI; break; + case am_line: type = TCP_PB_LINE_LF; break; + case am_tpkt: type = TCP_PB_TPKT; break; + case am_http: type = TCP_PB_HTTP; break; + case am_httph: type = TCP_PB_HTTPH; break; + case am_http_bin: type = TCP_PB_HTTP_BIN; break; + case am_httph_bin: type = TCP_PB_HTTPH_BIN; break; + case am_ssl_tls: type = TCP_PB_SSL_TLS; break; + default: + BIF_ERROR(BIF_P, BADARG); + } + + options = BIF_ARG_3; + while (!is_nil(options)) { + Eterm* cons = list_val(options); + if (is_tuple(CAR(cons))) { + Eterm* tpl = tuple_val(CAR(cons)); + Uint val; + if (tpl[0] == make_arityval(2) && + term_to_Uint(tpl[2],&val) && val <= UINT_MAX) { + switch (tpl[1]) { + case am_packet_size: + max_plen = val; + goto next_option; + case am_line_length: + trunc_len = val; + goto next_option; + } + } + } + BIF_ERROR(BIF_P, BADARG); + + next_option: + options = CDR(cons); + } + + + bin_sz = binary_size(BIF_ARG_2); + ERTS_GET_BINARY_BYTES(BIF_ARG_2, bin_ptr, pca.bin_bitoffs, bin_bitsz); + if (pca.bin_bitoffs != 0) { + pca.aligned_ptr = erts_alloc(ERTS_ALC_T_TMP, bin_sz); + erts_copy_bits(bin_ptr, pca.bin_bitoffs, 1, pca.aligned_ptr, 0, 1, bin_sz*8); + } + else { + pca.aligned_ptr = bin_ptr; + } + packet_sz = packet_get_length(type, (char*)pca.aligned_ptr, bin_sz, + max_plen, trunc_len, &http_state); + if (!(packet_sz > 0 && packet_sz <= bin_sz)) { + if (packet_sz < 0) { + goto error; + } + else { /* not enough data */ + Eterm plen = (packet_sz==0) ? am_undefined : + erts_make_integer(packet_sz, BIF_P); + Eterm* hp = HAlloc(BIF_P,3); + res = TUPLE2(hp, am_more, plen); + goto done; + } + } + /* We got a whole packet */ + + body_ptr = (char*) pca.aligned_ptr; + body_sz = packet_sz; + packet_get_body(type, (const char**) &body_ptr, &body_sz); + + ERTS_GET_REAL_BIN(BIF_ARG_2, pca.orig, pca.bin_offs, pca.bin_bitoffs, bin_bitsz); + pca.p = BIF_P; + pca.res = THE_NON_VALUE; + pca.string_as_bin = (type == TCP_PB_HTTP_BIN || type == TCP_PB_HTTPH_BIN); + code = packet_parse(type, (char*)pca.aligned_ptr, packet_sz, &http_state, + &packet_callbacks_erl, &pca); + if (code == 0) { /* no special packet parsing, make plain binary */ + ErlSubBin* body; + Uint hsz = 2*ERL_SUB_BIN_SIZE + 4; + hp = HAlloc(BIF_P, hsz); + hend = hp + hsz; + + body = (ErlSubBin *) hp; + body->thing_word = HEADER_SUB_BIN; + body->size = body_sz; + body->offs = pca.bin_offs + (body_ptr - (char*)pca.aligned_ptr); + body->orig = pca.orig; + body->bitoffs = pca.bin_bitoffs; + body->bitsize = 0; + body->is_writable = 0; + hp += ERL_SUB_BIN_SIZE; + pca.res = make_binary(body); + } + else if (code > 0) { + Uint hsz = ERL_SUB_BIN_SIZE + 4; + ASSERT(pca.res != THE_NON_VALUE); + hp = HAlloc(BIF_P, hsz); + hend = hp + hsz; + } + else { +error: + hp = HAlloc(BIF_P,3); + res = TUPLE2(hp, am_error, am_invalid); + goto done; + } + + rest = (ErlSubBin *) hp; + rest->thing_word = HEADER_SUB_BIN; + rest->size = bin_sz - packet_sz; + rest->offs = pca.bin_offs + packet_sz; + rest->orig = pca.orig; + rest->bitoffs = pca.bin_bitoffs; + rest->bitsize = bin_bitsz; /* The extra bits go into the rest. */ + rest->is_writable = 0; + hp += ERL_SUB_BIN_SIZE; + res = TUPLE3(hp, am_ok, pca.res, make_binary(rest)); + hp += 4; + ASSERT(hp==hend); (void)hend; + +done: + if (pca.aligned_ptr != bin_ptr) { + erts_free(ERTS_ALC_T_TMP, pca.aligned_ptr); + } + BIF_RET(res); +} + diff --git a/erts/emulator/beam/erl_bif_re.c b/erts/emulator/beam/erl_bif_re.c new file mode 100644 index 0000000000..16abab65b0 --- /dev/null +++ b/erts/emulator/beam/erl_bif_re.c @@ -0,0 +1,1142 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2008-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "erl_process.h" +#include "error.h" +#include "bif.h" +#include "erl_binary.h" +#include "big.h" +#define ERLANG_INTEGRATION 1 +#define PCRE_STATIC +#include "pcre.h" + +#define PCRE_DEFAULT_COMPILE_OPTS 0 +#define PCRE_DEFAULT_EXEC_OPTS 0 +#define LOOP_FACTOR 10 + + +static const unsigned char *default_table; +static Uint max_loop_limit; +static Export re_exec_trap_export; +static Export *grun_trap_exportp = NULL; +static Export *urun_trap_exportp = NULL; +static Export *ucompile_trap_exportp = NULL; + +static BIF_RETTYPE re_exec_trap(BIF_ALIST_3); + +static void *erts_erts_pcre_malloc(size_t size) { + return erts_alloc(ERTS_ALC_T_RE_HEAP,size); +} + +static void erts_erts_pcre_free(void *ptr) { + erts_free(ERTS_ALC_T_RE_HEAP,ptr); +} + +static void *erts_erts_pcre_stack_malloc(size_t size) { + return erts_alloc(ERTS_ALC_T_RE_STACK,size); +} + +static void erts_erts_pcre_stack_free(void *ptr) { + erts_free(ERTS_ALC_T_RE_STACK,ptr); +} + +void erts_init_bif_re(void) +{ + erts_pcre_malloc = &erts_erts_pcre_malloc; + erts_pcre_free = &erts_erts_pcre_free; + erts_pcre_stack_malloc = &erts_erts_pcre_stack_malloc; + erts_pcre_stack_free = &erts_erts_pcre_stack_free; + default_table = NULL; /* ISO8859-1 default, forced into pcre */ + max_loop_limit = CONTEXT_REDS * LOOP_FACTOR; + + sys_memset((void *) &re_exec_trap_export, 0, sizeof(Export)); + re_exec_trap_export.address = &re_exec_trap_export.code[3]; + re_exec_trap_export.code[0] = am_erlang; + re_exec_trap_export.code[1] = am_re_run_trap; + re_exec_trap_export.code[2] = 3; + re_exec_trap_export.code[3] = (Eterm) em_apply_bif; + re_exec_trap_export.code[4] = (Eterm) &re_exec_trap; + + grun_trap_exportp = erts_export_put(am_re,am_grun,3); + urun_trap_exportp = erts_export_put(am_re,am_urun,3); + ucompile_trap_exportp = erts_export_put(am_re,am_ucompile,2); + + return; +} + +Sint erts_re_set_loop_limit(Sint limit) +{ + Sint save = (Sint) max_loop_limit; + if (limit <= 0) { + max_loop_limit = CONTEXT_REDS * LOOP_FACTOR; + } else { + max_loop_limit = (Uint) limit; + } + return save; +} + +/* + * Deal with plain int's and so on for the library interface + */ + +static int term_to_int(Eterm term, int *sp) +{ +#ifdef ARCH_64 + + if (is_small(term)) { + Uint x = signed_val(term); + if (x > INT_MAX) { + return 0; + } + *sp = (int) x; + return 1; + } + return 0; + +#else + + if (is_small(term)) { + *sp = signed_val(term); + return 1; + } else if (is_big(term)) { + ErtsDigit* xr = big_v(term); + dsize_t xl = big_size(term); + int sign = big_sign(term); + unsigned uval = 0; + int n = 0; + + if (xl*D_EXP > sizeof(unsigned)*8) { + return 0; + } + while (xl-- > 0) { + uval |= ((unsigned)(*xr++)) << n; + n += D_EXP; + } + if (sign) { + uval = -uval; + if ((int)uval > 0) + return 0; + } else { + if ((int)uval < 0) + return 0; + } + *sp = uval; + return 1; + } else { + return 0; + } + +#endif + +} + +static Eterm make_signed_integer(int x, Process *p) +{ +#ifdef ARCH_64 + return make_small(x); +#else + Eterm* hp; + if (IS_SSMALL(x)) + return make_small(x); + else { + hp = HAlloc(p, BIG_UINT_HEAP_SIZE); + if (x >= 0) { + *hp = make_pos_bignum_header(1); + } else { + x = -x; + *hp = make_neg_bignum_header(1); + } + BIG_DIGIT(hp, 0) = x; + return make_big(hp); + } +#endif +} + +/* + * Parse option lists + */ + +#define PARSE_FLAG_UNIQUE_COMPILE_OPT 1 +#define PARSE_FLAG_UNIQUE_EXEC_OPT 2 +#define PARSE_FLAG_UNICODE 4 +#define PARSE_FLAG_STARTOFFSET 8 +#define PARSE_FLAG_CAPTURE_OPT 16 +#define PARSE_FLAG_GLOBAL 32 + +#define CAPSPEC_VALUES 0 +#define CAPSPEC_TYPE 1 +#define CAPSPEC_SIZE 2 + +static int /* 0 == ok, < 0 == error */ +parse_options(Eterm listp, /* in */ + int *compile_options, /* out */ + int *exec_options, /* out */ + int *flags,/* out */ + int *startoffset, /* out */ + Eterm *capture_spec) /* capture_spec[CAPSPEC_SIZE] */ /* out */ +{ + int copt,eopt,fl; + Eterm item; + + if (listp == NIL) { + copt = PCRE_DEFAULT_COMPILE_OPTS; + eopt = PCRE_DEFAULT_EXEC_OPTS; + fl = 0; + } else { + copt = 0; + eopt = 0; + fl = 0; + for (;is_list(listp); listp = CDR(list_val(listp))) { + item = CAR(list_val(listp)); + if (is_tuple(item)) { + Eterm *tp = tuple_val(item); + if (arityval(*tp) != 2 || is_not_atom(tp[1])) { + if (arityval(*tp) == 3 && tp[1] == am_capture) { + if (capture_spec != NULL) { + capture_spec[CAPSPEC_VALUES] = tp[2]; + capture_spec[CAPSPEC_TYPE] = tp[3]; + } + fl |= (PARSE_FLAG_CAPTURE_OPT | + PARSE_FLAG_UNIQUE_EXEC_OPT); + continue; + } else { + return -1; + } + } + switch(tp[1]) { + case am_capture: + if (capture_spec != NULL) { + capture_spec[CAPSPEC_VALUES] = tp[2]; + capture_spec[CAPSPEC_TYPE] = am_index; + } + fl |= (PARSE_FLAG_CAPTURE_OPT | + PARSE_FLAG_UNIQUE_EXEC_OPT); + break; + case am_offset: + { + int tmp; + if (!term_to_int(tp[2],&tmp)) { + return -1; + } + if (startoffset != NULL) { + *startoffset = tmp; + } + } + fl |= (PARSE_FLAG_UNIQUE_EXEC_OPT|PARSE_FLAG_STARTOFFSET); + break; + case am_newline: + if (!is_atom(tp[2])) { + return -1; + } + switch (tp[2]) { + case am_cr: + copt |= PCRE_NEWLINE_CR; + eopt |= PCRE_NEWLINE_CR; + break; + case am_crlf: + copt |= PCRE_NEWLINE_CRLF; + eopt |= PCRE_NEWLINE_CRLF; + break; + case am_lf: + copt |= PCRE_NEWLINE_LF; + eopt |= PCRE_NEWLINE_LF; + break; + case am_anycrlf: + copt |= PCRE_NEWLINE_ANYCRLF; + eopt |= PCRE_NEWLINE_ANYCRLF; + break; + case am_any: + eopt |= PCRE_NEWLINE_ANY; + copt |= PCRE_NEWLINE_ANY; + break; + default: + return -1; + break; + } + break; + default: + return -1; + } + }else if (is_not_atom(item)) { + return -1; + } else { + switch(item) { + case am_anchored: + copt |= PCRE_ANCHORED; + eopt |= PCRE_ANCHORED; + break; + case am_notempty: + eopt |= PCRE_NOTEMPTY; + fl |= PARSE_FLAG_UNIQUE_EXEC_OPT; + break; + case am_notbol: + eopt |= PCRE_NOTBOL; + fl |= PARSE_FLAG_UNIQUE_EXEC_OPT; + break; + case am_noteol: + eopt |= PCRE_NOTEOL; + fl |= PARSE_FLAG_UNIQUE_EXEC_OPT; + break; + case am_caseless: + copt |= PCRE_CASELESS; + fl |= PARSE_FLAG_UNIQUE_COMPILE_OPT; + break; + case am_dollar_endonly: + copt |= PCRE_DOLLAR_ENDONLY; + fl |= PARSE_FLAG_UNIQUE_COMPILE_OPT; + break; + case am_dotall: + copt |= PCRE_DOTALL; + fl |= PARSE_FLAG_UNIQUE_COMPILE_OPT; + break; + case am_extended: + copt |= PCRE_EXTENDED; + fl |= PARSE_FLAG_UNIQUE_COMPILE_OPT; + break; + case am_firstline: + copt |= PCRE_FIRSTLINE; + fl |= PARSE_FLAG_UNIQUE_COMPILE_OPT; + break; + case am_multiline: + copt |= PCRE_MULTILINE; + fl |= PARSE_FLAG_UNIQUE_COMPILE_OPT; + break; + case am_no_auto_capture: + copt |= PCRE_NO_AUTO_CAPTURE; + fl |= PARSE_FLAG_UNIQUE_COMPILE_OPT; + break; + case am_dupnames: + copt |= PCRE_DUPNAMES; + fl |= PARSE_FLAG_UNIQUE_COMPILE_OPT; + break; + case am_ungreedy: + copt |= PCRE_UNGREEDY; + fl |= PARSE_FLAG_UNIQUE_COMPILE_OPT; + break; + case am_unicode: + copt |= PCRE_UTF8; + fl |= (PARSE_FLAG_UNIQUE_COMPILE_OPT | PARSE_FLAG_UNICODE); + break; + case am_global: + fl |= (PARSE_FLAG_UNIQUE_EXEC_OPT | PARSE_FLAG_GLOBAL); + break; + case am_bsr_anycrlf: + eopt |= PCRE_BSR_ANYCRLF; + copt |= PCRE_BSR_ANYCRLF; + break; + case am_bsr_unicode: + eopt |= PCRE_BSR_UNICODE; + copt |= PCRE_BSR_UNICODE; + break; + default: + return -1; + } + } + } + if (is_not_nil(listp)) { + return -1; + } + } + if (compile_options != NULL) { + *compile_options = copt; + } + if (exec_options != NULL) { + *exec_options = eopt; + } + if (flags != NULL) { + *flags = fl; + } + return 0; +} + +/* + * Build Erlang term result from compilation + */ + +static Eterm +build_compile_result(Process *p, Eterm error_tag, pcre *result, int errcode, const char *errstr, int errofset, int unicode, int with_ok) +{ + Eterm *hp; + Eterm ret; + size_t pattern_size; + int capture_count; + if (!result) { + /* Return {error_tag, {Code, String, Offset}} */ + int elen = sys_strlen(errstr); + int need = 3 /* tuple of 2 */ + + 3 /* tuple of 2 */ + + (2 * elen) /* The error string list */; + hp = HAlloc(p, need); + ret = buf_to_intlist(&hp, (char *) errstr, elen, NIL); + ret = TUPLE2(hp, ret, make_small(errofset)); + hp += 3; + ret = TUPLE2(hp, error_tag, ret); + } else { + erts_pcre_fullinfo(result, NULL, PCRE_INFO_SIZE, &pattern_size); + erts_pcre_fullinfo(result, NULL, PCRE_INFO_CAPTURECOUNT, &capture_count); + /* XXX: Optimize - keep in offheap binary to allow this to + be kept across traps w/o need of copying */ + ret = new_binary(p, (byte *) result, pattern_size); + erts_pcre_free(result); + hp = HAlloc(p, (with_ok) ? (3+5) : 5); + ret = TUPLE4(hp,am_re_pattern, make_small(capture_count), make_small(unicode),ret); + if (with_ok) { + hp += 5; + ret = TUPLE2(hp,am_ok,ret); + } + } + return ret; +} + +/* + * Compile BIFs + */ + +BIF_RETTYPE +re_compile_2(BIF_ALIST_2) +{ + int slen; + char *expr; + pcre *result; + int errcode = 0; + const char *errstr = ""; + int errofset = 0; + Eterm ret; + int options = 0; + int pflags = 0; + int unicode = 0; + + + if (parse_options(BIF_ARG_2,&options,NULL,&pflags,NULL,NULL) + < 0) { + BIF_ERROR(BIF_P,BADARG); + } + + if (pflags & PARSE_FLAG_UNIQUE_EXEC_OPT) { + BIF_ERROR(BIF_P,BADARG); + } + + unicode = (pflags & PARSE_FLAG_UNICODE) ? 1 : 0; + + if (pflags & PARSE_FLAG_UNICODE && !is_binary(BIF_ARG_1)) { + BIF_TRAP2(ucompile_trap_exportp, BIF_P, BIF_ARG_1, BIF_ARG_2); + } + + if ((slen = io_list_len(BIF_ARG_1)) < 0) { + BIF_ERROR(BIF_P,BADARG); + } + expr = erts_alloc(ERTS_ALC_T_RE_TMP_BUF, slen + 1); + if (io_list_to_buf(BIF_ARG_1, expr, slen) != 0) { + erts_free(ERTS_ALC_T_RE_TMP_BUF, expr); + BIF_ERROR(BIF_P,BADARG); + } + expr[slen]='\0'; + result = erts_pcre_compile2(expr, options, &errcode, + &errstr, &errofset, default_table); + + ret = build_compile_result(BIF_P, am_error, result, errcode, + errstr, errofset, unicode, 1); + erts_free(ERTS_ALC_T_RE_TMP_BUF, expr); + BIF_RET(ret); +} + +BIF_RETTYPE +re_compile_1(BIF_ALIST_1) +{ + return re_compile_2(BIF_P,BIF_ARG_1,NIL); +} + +/* + * Restart contexts for the re:run bif + */ + +/* + * When erts_pcre_exec is restarted, only the actual extra-structure with + * it's restart-data need to be kept. The match is then called with + * watever is saved. The code is pointed out by this and cannot be + * reallocated or GC'ed, why it's passed along as a off-heap-binary, + * but not actually passed in the erts_pcre_exec restart calls. + */ + +typedef enum { RetIndex, RetString, RetBin, RetNone } ReturnType; + +typedef struct _return_info { + ReturnType type; + int num_spec; /* 0 == all, -1 == all_but first, > 0 specified in vector */ + int v[1]; +} ReturnInfo; + +typedef struct _restart_context { + pcre_extra extra; + void *restart_data; + Uint32 flags; + char *subject; /* to be able to free it when done */ + pcre *code; /* Keep a copy */ + int *ovector; /* Keep until done */ + ReturnInfo *ret_info; +} RestartContext; + +#define RESTART_FLAG_SUBJECT_IN_BINARY 0x1 + +static void cleanup_restart_context(RestartContext *rc) +{ + if (rc->restart_data != NULL) { + erts_pcre_free_restart_data(rc->restart_data); + rc->restart_data = NULL; + } + if (rc->ovector != NULL) { + erts_free(ERTS_ALC_T_RE_SUBJECT, rc->ovector); + rc->ovector = NULL; + } + if (rc->subject != NULL && !(rc->flags & RESTART_FLAG_SUBJECT_IN_BINARY)) { + erts_free(ERTS_ALC_T_RE_SUBJECT, rc->subject); + } + rc->subject = NULL; + if (rc->code != NULL) { + erts_free(ERTS_ALC_T_RE_SUBJECT, rc->code); + rc->code = NULL; + } + if (rc->ret_info != NULL) { + erts_free(ERTS_ALC_T_RE_SUBJECT, rc->ret_info); + rc->ret_info = NULL; + } +} + +static void cleanup_restart_context_bin(Binary *bp) +{ + RestartContext *rc = ERTS_MAGIC_BIN_DATA(bp); + cleanup_restart_context(rc); +} + +/* + * Build the return value for Erlang from result and restart context + */ + +static Eterm build_exec_return(Process *p, int rc, RestartContext *restartp, Eterm orig_subject) +{ + Eterm res; + Eterm *hp; + if (rc <= 0) { + res = am_nomatch; + } else { + ReturnInfo *ri = restartp->ret_info; + ReturnInfo defri = {RetIndex,0,{0}}; + if (ri == NULL) { + ri = &defri; + } + if (ri->type == RetNone) { + res = am_match; + } else if (ri->type == RetIndex){ + Eterm *tmp_vect; + Eterm tpl; + int i; + if (ri->num_spec <= 0) { + tmp_vect = erts_alloc(ERTS_ALC_T_RE_TMP_BUF, + rc * 2 * sizeof(Eterm)); + for(i = -(ri->num_spec) ;i < rc; ++i) { + tmp_vect[i*2] = make_signed_integer(restartp->ovector[i*2],p); + tmp_vect[i*2+1] = make_signed_integer(restartp->ovector[i*2+1] - restartp->ovector[i*2],p); + } + hp = HAlloc(p, 3+(3+2)*(rc + ri->num_spec)); + res = NIL; + for(i = rc-1 ;i >= -(ri->num_spec); --i) { + tpl = TUPLE2(hp,tmp_vect[i*2],tmp_vect[i*2+1]); + hp += 3; + res = CONS(hp,tpl,res); + hp += 2; + } + } else { + int n = 0; + int x; + tmp_vect = erts_alloc(ERTS_ALC_T_RE_TMP_BUF, + ri->num_spec * 2 * sizeof(Eterm)); + for (i = 0; i < ri->num_spec; ++i) { + x = ri->v[i]; + if (x < rc && x >= 0) { + tmp_vect[n*2] = make_signed_integer(restartp->ovector[x*2],p); + tmp_vect[n*2+1] = make_signed_integer(restartp->ovector[x*2+1]-restartp->ovector[x*2],p); + } else { + tmp_vect[n*2] = make_small(-1); + tmp_vect[n*2+1] = make_small(0); + } + ++n; + } + hp = HAlloc(p, 3+(3+2)*n); + res = NIL; + for(i = n-1 ;i >= 0; --i) { + tpl = TUPLE2(hp,tmp_vect[i*2],tmp_vect[i*2+1]); + hp += 3; + res = CONS(hp,tpl,res); + hp += 2; + } + } + res = TUPLE2(hp,am_match,res); + erts_free(ERTS_ALC_T_RE_TMP_BUF, tmp_vect); + } else { + Eterm *tmp_vect; + int i; + Eterm orig = NIL; + Uint offset = 0; + Uint bitoffs = 0; + Uint bitsize = 0; + if (restartp->flags & RESTART_FLAG_SUBJECT_IN_BINARY) { + ERTS_GET_REAL_BIN(orig_subject, orig, offset, bitoffs, bitsize); + } + if (ri->num_spec <= 0) { + tmp_vect = erts_alloc(ERTS_ALC_T_RE_TMP_BUF, + rc * sizeof(Eterm)); + for(i = -(ri->num_spec) ;i < rc; ++i) { /* XXX: Unicode */ + char *cp; + int len; + if (restartp->ovector[i*2] < 0) { + cp = restartp->subject; + len = 0; + } else { + cp = restartp->subject + restartp->ovector[i*2]; + len = restartp->ovector[i*2+1] - restartp->ovector[i*2]; + } + if (ri->type == RetBin) { + if (restartp->flags & RESTART_FLAG_SUBJECT_IN_BINARY) { + /* Optimized - if subject was binary to begin + with, we can make sub-binaries. */ + ErlSubBin *sb; + Uint virtual_offset = cp - restartp->subject; + hp = HAlloc(p, ERL_SUB_BIN_SIZE); + sb = (ErlSubBin *) hp; + sb->thing_word = HEADER_SUB_BIN; + sb->size = len; + sb->offs = offset + virtual_offset; + sb->orig = orig; + sb->bitoffs = bitoffs; + sb->bitsize = bitsize; + sb->is_writable = 0; + tmp_vect[i] = make_binary(sb); + } else { + tmp_vect[i] = new_binary(p, (byte *) cp, len); + } + } else { + Eterm *hp2; + hp2 = HAlloc(p,(2*len)); + tmp_vect[i] = buf_to_intlist(&hp2, cp, len, NIL); + } + } + hp = HAlloc(p, 3+2*(rc + ri->num_spec)); + res = NIL; + for(i = rc-1 ;i >= -(ri->num_spec); --i) { + res = CONS(hp,tmp_vect[i],res); + hp += 2; + } + } else { + int n = 0; + int x; + tmp_vect = erts_alloc(ERTS_ALC_T_RE_TMP_BUF, + ri->num_spec * sizeof(Eterm)); + for (i = 0; i < ri->num_spec; ++i) { + x = ri->v[i]; + if (x < rc && x >= 0) { + char *cp; + int len; + if (restartp->ovector[x*2] < 0) { + cp = restartp->subject; + len = 0; + } else { + cp = restartp->subject + restartp->ovector[x*2]; + len = restartp->ovector[x*2+1] - restartp->ovector[x*2]; + } + if (ri->type == RetBin) { + if (restartp->flags & RESTART_FLAG_SUBJECT_IN_BINARY) { + /* Optimized - if subject was binary to begin + with, we could make sub-binaries. */ + ErlSubBin *sb; + Uint virtual_offset = cp - restartp->subject; + hp = HAlloc(p, ERL_SUB_BIN_SIZE); + sb = (ErlSubBin *) hp; + sb->thing_word = HEADER_SUB_BIN; + sb->size = len; + sb->offs = offset + virtual_offset; + sb->orig = orig; + sb->bitoffs = bitoffs; + sb->bitsize = bitsize; + sb->is_writable = 0; + tmp_vect[n] = make_binary(sb); + } else { + tmp_vect[n] = new_binary(p, (byte *) cp, len); + } + } else { + Eterm *hp2; + hp2 = HAlloc(p,(2*len)); + tmp_vect[n] = buf_to_intlist(&hp2, cp, len, NIL); + } + } else { + if (ri->type == RetBin) { + tmp_vect[n] = new_binary(p, (byte *) "", 0); + } else { + tmp_vect[n] = NIL; + } + } + ++n; + } + hp = HAlloc(p, 3+2*n); + res = NIL; + for(i = n-1 ;i >= 0; --i) { + res = CONS(hp,tmp_vect[i],res); + hp += 2; + } + + } + res = TUPLE2(hp,am_match,res); + erts_free(ERTS_ALC_T_RE_TMP_BUF, tmp_vect); + } + } + return res; +} + +/* + * Extra parsing function, build the ReturnInfo structure from + * a capture specification in the option list + */ + +#define RINFO_SIZ(Num) (sizeof(ReturnInfo) + (sizeof(int) * (Num - 1))) + +static ReturnInfo * +build_capture(Eterm capture_spec[CAPSPEC_SIZE], const pcre *code) +{ + ReturnInfo *ri = erts_alloc(ERTS_ALC_T_RE_SUBJECT, RINFO_SIZ(0)); + int sallocated = 0; + char *tmpb = NULL; + int tmpbsiz = 0; + Eterm l; + + ri->type = RetIndex; + ri->num_spec = 0; + + + switch(capture_spec[CAPSPEC_TYPE]) { + case am_index: + ri->type = RetIndex; + break; + case am_list: + ri->type = RetString; + break; + case am_binary: + ri->type = RetBin; + break; + default: + goto error; + } + + switch(capture_spec[CAPSPEC_VALUES]) { + case am_all: + ri->num_spec = 0; + break; + case am_none: + case NIL: + ri->num_spec = 0; + ri->type = RetNone; + break; + case am_all_but_first: + ri->num_spec = -1; + break; + case am_first: + ri->num_spec = 1; + if(ri->num_spec > sallocated) { + sallocated = ri->num_spec; + ri = erts_realloc(ERTS_ALC_T_RE_SUBJECT, ri, RINFO_SIZ(sallocated)); + } + ri->v[ri->num_spec - 1] = 0; + break; + default: + if (is_list(capture_spec[CAPSPEC_VALUES])) { + for(l=capture_spec[CAPSPEC_VALUES];is_list(l);l = CDR(list_val(l))) { + int x; + Eterm val = CAR(list_val(l)); + if (ri->num_spec < 0) + ri->num_spec = 0; + ++(ri->num_spec); + if(ri->num_spec > sallocated) { + sallocated += 10; + ri = erts_realloc(ERTS_ALC_T_RE_SUBJECT, ri, RINFO_SIZ(sallocated)); + } + if (term_to_int(val,&x)) { + ri->v[ri->num_spec - 1] = x; + } else if (is_atom(val) || is_binary(val) || is_list(val)) { + if (is_atom(val)) { + Atom *ap = atom_tab(atom_val(val)); + if ((ap->len + 1) > tmpbsiz) { + if (!tmpbsiz) { + tmpb = erts_alloc(ERTS_ALC_T_RE_TMP_BUF,(tmpbsiz = ap->len + 1)); + } else { + tmpb = erts_realloc(ERTS_ALC_T_RE_TMP_BUF,tmpb, + (tmpbsiz = ap->len + 1)); + } + } + memcpy(tmpb,ap->name,ap->len); + tmpb[ap->len] = '\0'; + } else { + int slen = io_list_len(val); + if (slen < 0) { + goto error; + } + if ((slen + 1) > tmpbsiz) { + if (!tmpbsiz) { + tmpb = erts_alloc(ERTS_ALC_T_RE_TMP_BUF,(tmpbsiz = slen + 1)); + } else { + tmpb = erts_realloc(ERTS_ALC_T_RE_TMP_BUF,tmpb, + (tmpbsiz = slen + 1)); + } + } + if (io_list_to_buf(val, tmpb, slen) != 0) { + goto error; + } + tmpb[slen] = '\0'; + } + if ((ri->v[ri->num_spec - 1] = erts_pcre_get_stringnumber(code,tmpb)) == + PCRE_ERROR_NOSUBSTRING) { + ri->v[ri->num_spec - 1] = -1; + } + } else { + goto error; + } + } + if (l != NIL) { + goto error; + } + } else { + goto error; + } + break; + } + + if(tmpb != NULL) { + erts_free(ERTS_ALC_T_RE_TMP_BUF,tmpb); + } + return ri; + error: + if(tmpb != NULL) { + erts_free(ERTS_ALC_T_RE_TMP_BUF,tmpb); + } + erts_free(ERTS_ALC_T_RE_SUBJECT, ri); + return NULL; +} + + +/* + * The actual re:run/2,3 BIFs + */ +BIF_RETTYPE +re_run_3(BIF_ALIST_3) +{ + const pcre *code_tmp; + RestartContext restart; + byte *temp_alloc = NULL; + int slength; + int startoffset = 0; + int options = 0, comp_options = 0; + int ovsize; + int pflags; + Eterm *tp; + int rc; + Eterm res; + size_t code_size; + Uint loop_limit_tmp; + unsigned long loop_count; + Eterm capture[CAPSPEC_SIZE]; + int is_list_cap; + + if (parse_options(BIF_ARG_3,&comp_options,&options,&pflags,&startoffset,capture) + < 0) { + BIF_ERROR(BIF_P,BADARG); + } + is_list_cap = ((pflags & PARSE_FLAG_CAPTURE_OPT) && + (capture[CAPSPEC_TYPE] == am_list)); + + if (is_not_tuple(BIF_ARG_2) || (arityval(*tuple_val(BIF_ARG_2)) != 4)) { + if (is_binary(BIF_ARG_2) || is_list(BIF_ARG_2) || is_nil(BIF_ARG_2)) { + /* Compile from textual RE */ + int slen; + char *expr; + pcre *result; + int errcode = 0; + const char *errstr = ""; + int errofset = 0; + int capture_count; + + if (pflags & PARSE_FLAG_UNICODE && + (!is_binary(BIF_ARG_1) || + (is_list_cap && !(pflags & PARSE_FLAG_GLOBAL)))) { + BIF_TRAP3(urun_trap_exportp, BIF_P, BIF_ARG_1, BIF_ARG_2, BIF_ARG_3); + } + + if ((slen = io_list_len(BIF_ARG_2)) < 0) { + BIF_ERROR(BIF_P,BADARG); + } + + expr = erts_alloc(ERTS_ALC_T_RE_TMP_BUF, slen + 1); + if (io_list_to_buf(BIF_ARG_2, expr, slen) != 0) { + erts_free(ERTS_ALC_T_RE_TMP_BUF, expr); + BIF_ERROR(BIF_P,BADARG); + } + expr[slen]='\0'; + result = erts_pcre_compile2(expr, comp_options, &errcode, + &errstr, &errofset, default_table); + if (!result) { + erts_free(ERTS_ALC_T_RE_TMP_BUF, expr); + /* Compilation error gives badarg except in the compile + function */ + BIF_ERROR(BIF_P,BADARG); + } + if (pflags & PARSE_FLAG_GLOBAL) { + Eterm precompiled = + build_compile_result(BIF_P, am_error, + result, errcode, + errstr, errofset, + (pflags & + PARSE_FLAG_UNICODE) ? 1 : 0, + 0); + Eterm *hp,r; + erts_free(ERTS_ALC_T_RE_TMP_BUF, expr); + hp = HAlloc(BIF_P,4); + /* BIF_ARG_2 is in the tuple just to make exceptions right */ + r = TUPLE3(hp,BIF_ARG_3, + ((pflags & PARSE_FLAG_UNIQUE_COMPILE_OPT) ? + am_true : + am_false), BIF_ARG_2); + BIF_TRAP3(grun_trap_exportp, BIF_P, BIF_ARG_1, precompiled, r); + } + + erts_pcre_fullinfo(result, NULL, PCRE_INFO_SIZE, &code_size); + erts_pcre_fullinfo(result, NULL, PCRE_INFO_CAPTURECOUNT, &capture_count); + ovsize = 3*(capture_count+1); + restart.code = erts_alloc(ERTS_ALC_T_RE_SUBJECT, code_size); + memcpy(restart.code, result, code_size); + erts_pcre_free(result); + erts_free(ERTS_ALC_T_RE_TMP_BUF, expr); + /*unicode = (pflags & PARSE_FLAG_UNICODE) ? 1 : 0;*/ + } else { + BIF_ERROR(BIF_P,BADARG); + } + } else { + if (pflags & PARSE_FLAG_UNIQUE_COMPILE_OPT) { + BIF_ERROR(BIF_P,BADARG); + } + + tp = tuple_val(BIF_ARG_2); + if (tp[1] != am_re_pattern || is_not_small(tp[2]) || + is_not_small(tp[3]) || is_not_binary(tp[4])) { + BIF_ERROR(BIF_P,BADARG); + } + + if (unsigned_val(tp[3]) && + (!is_binary(BIF_ARG_1) || + (is_list_cap && !(pflags & PARSE_FLAG_GLOBAL)))) { /* unicode */ + BIF_TRAP3(urun_trap_exportp, BIF_P, BIF_ARG_1, BIF_ARG_2, + BIF_ARG_3); + } + + if (pflags & PARSE_FLAG_GLOBAL) { + Eterm *hp,r; + hp = HAlloc(BIF_P,3); + r = TUPLE2(hp,BIF_ARG_3,am_false); + BIF_TRAP3(grun_trap_exportp, BIF_P, BIF_ARG_1, BIF_ARG_2, + r); + } + + ovsize = 3*(unsigned_val(tp[2])+1); + code_size = binary_size(tp[4]); + if ((code_tmp = (const pcre *) + erts_get_aligned_binary_bytes(tp[4], &temp_alloc)) == NULL) { + erts_free_aligned_binary_bytes(temp_alloc); + BIF_ERROR(BIF_P, BADARG); + } + restart.code = erts_alloc(ERTS_ALC_T_RE_SUBJECT, code_size); + memcpy(restart.code, code_tmp, code_size); + erts_free_aligned_binary_bytes(temp_alloc); + + } + + + restart.ovector = erts_alloc(ERTS_ALC_T_RE_SUBJECT, ovsize * sizeof(int)); + restart.extra.flags = PCRE_EXTRA_TABLES | PCRE_EXTRA_LOOP_LIMIT; + restart.extra.tables = default_table; + restart.extra.loop_limit = ERTS_BIF_REDS_LEFT(BIF_P) * LOOP_FACTOR; + loop_limit_tmp = max_loop_limit; /* To lesser probability of race in debug + situation (erts_debug) */ + if (restart.extra.loop_limit > loop_limit_tmp) { + restart.extra.loop_limit = loop_limit_tmp; + } + restart.restart_data = NULL; + restart.extra.restart_data = &restart.restart_data; + restart.extra.restart_flags = 0; + restart.extra.loop_counter_return = &loop_count; + restart.ret_info = NULL; + + if (pflags & PARSE_FLAG_CAPTURE_OPT) { + if ((restart.ret_info = build_capture(capture,restart.code)) == NULL) { + erts_free(ERTS_ALC_T_RE_SUBJECT, restart.ovector); + erts_free(ERTS_ALC_T_RE_SUBJECT, restart.code); + BIF_ERROR(BIF_P,BADARG); + } + } + + /* Optimized - if already in binary off heap, keep that and avoid + copying, also binary returns can be sub binaries in that case */ + + restart.flags = 0; + if (is_binary(BIF_ARG_1)) { + Eterm real_bin; + Uint offset; + Eterm* bptr; + int bitoffs; + int bitsize; + ProcBin* pb; + + ERTS_GET_REAL_BIN(BIF_ARG_1, real_bin, offset, bitoffs, bitsize); + + slength = binary_size(BIF_ARG_1); + bptr = binary_val(real_bin); + if (bitsize != 0 || bitoffs != 0 || (*bptr != HEADER_PROC_BIN)) { + goto handle_iolist; + } + pb = (ProcBin *) bptr; + restart.subject = (char *) (pb->bytes+offset); + restart.flags |= RESTART_FLAG_SUBJECT_IN_BINARY; + } else { +handle_iolist: + if ((slength = io_list_len(BIF_ARG_1)) < 0) { + erts_free(ERTS_ALC_T_RE_SUBJECT, restart.ovector); + erts_free(ERTS_ALC_T_RE_SUBJECT, restart.code); + if (restart.ret_info != NULL) { + erts_free(ERTS_ALC_T_RE_SUBJECT, restart.ret_info); + } + BIF_ERROR(BIF_P,BADARG); + } + restart.subject = erts_alloc(ERTS_ALC_T_RE_SUBJECT, slength); + + if (io_list_to_buf(BIF_ARG_1, restart.subject, slength) != 0) { + erts_free(ERTS_ALC_T_RE_SUBJECT, restart.ovector); + erts_free(ERTS_ALC_T_RE_SUBJECT, restart.code); + erts_free(ERTS_ALC_T_RE_SUBJECT, restart.subject); + if (restart.ret_info != NULL) { + erts_free(ERTS_ALC_T_RE_SUBJECT, restart.ret_info); + } + BIF_ERROR(BIF_P,BADARG); + } + } + + +#ifdef DEBUG + loop_count = 0xFFFFFFFF; +#endif + + rc = erts_pcre_exec(restart.code, &(restart.extra), restart.subject, slength, startoffset, + options, restart.ovector, ovsize); + ASSERT(loop_count != 0xFFFFFFFF); + BUMP_REDS(BIF_P, loop_count / LOOP_FACTOR); + if (rc == PCRE_ERROR_LOOP_LIMIT) { + /* Trap */ + Binary *mbp = erts_create_magic_binary(sizeof(RestartContext), + cleanup_restart_context_bin); + RestartContext *restartp = ERTS_MAGIC_BIN_DATA(mbp); + Eterm magic_bin; + Eterm *hp; + memcpy(restartp,&restart,sizeof(RestartContext)); + BUMP_ALL_REDS(BIF_P); + hp = HAlloc(BIF_P, PROC_BIN_SIZE); + magic_bin = erts_mk_magic_binary_term(&hp, &MSO(BIF_P), mbp); + BIF_TRAP3(&re_exec_trap_export, + BIF_P, + BIF_ARG_1, + BIF_ARG_2 /* To avoid GC of precompiled code, XXX: not utilized yet */, + magic_bin); + } + + res = build_exec_return(BIF_P, rc, &restart, BIF_ARG_1); + + cleanup_restart_context(&restart); + + BIF_RET(res); +} + +BIF_RETTYPE +re_run_2(BIF_ALIST_2) +{ + return re_run_3(BIF_P,BIF_ARG_1, BIF_ARG_2, NIL); +} + +/* + * The "magic" trap target, continue a re:run + */ + +static BIF_RETTYPE re_exec_trap(BIF_ALIST_3) + /* XXX: Optimize - arg 1 and 2 to be utilized for keeping binary + code and subject */ +{ + Binary *mbp; + RestartContext *restartp; + int rc; + unsigned long loop_count; + Uint loop_limit_tmp; + Eterm res; + + ASSERT(ERTS_TERM_IS_MAGIC_BINARY(BIF_ARG_3)); + + mbp = ((ProcBin *) binary_val(BIF_ARG_3))->val; + + ASSERT(ERTS_MAGIC_BIN_DESTRUCTOR(mbp) + == cleanup_restart_context_bin); + + restartp = (RestartContext *) ERTS_MAGIC_BIN_DATA(mbp); + + restartp->extra.loop_limit = ERTS_BIF_REDS_LEFT(BIF_P) * LOOP_FACTOR; + loop_limit_tmp = max_loop_limit; /* To lesser probability of race in debug + situation (erts_debug) */ + if (restartp->extra.loop_limit > loop_limit_tmp) { + restartp->extra.loop_limit = loop_limit_tmp; + } + restartp->extra.loop_counter_return = &loop_count; + restartp->extra.restart_data = &restartp->restart_data; + restartp->extra.restart_flags = 0; + +#ifdef DEBUG + loop_count = 0xFFFFFFFF; +#endif + rc = erts_pcre_exec(NULL, &(restartp->extra), NULL, 0, 0, 0, NULL, 0); + ASSERT(loop_count != 0xFFFFFFFF); + BUMP_REDS(BIF_P, loop_count / LOOP_FACTOR); + if (rc == PCRE_ERROR_LOOP_LIMIT) { + /* Trap */ + BUMP_ALL_REDS(BIF_P); + BIF_TRAP3(&re_exec_trap_export, BIF_P, BIF_ARG_1, BIF_ARG_2, BIF_ARG_3); + } + res = build_exec_return(BIF_P, rc, restartp, BIF_ARG_1); + + cleanup_restart_context(restartp); + + BIF_RET(res); +} + + + + diff --git a/erts/emulator/beam/erl_bif_timer.c b/erts/emulator/beam/erl_bif_timer.c new file mode 100644 index 0000000000..172bb37952 --- /dev/null +++ b/erts/emulator/beam/erl_bif_timer.c @@ -0,0 +1,701 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2005-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "erl_bif_timer.h" +#include "global.h" +#include "bif.h" +#include "error.h" +#include "big.h" + +/**************************************************************************** +** BIF Timer support +****************************************************************************/ + +#define BTM_FLG_SL_TIMER (((Uint32) 1) << 0) +#define BTM_FLG_CANCELED (((Uint32) 1) << 1) +#define BTM_FLG_HEAD (((Uint32) 1) << 2) +#define BTM_FLG_BYNAME (((Uint32) 1) << 3) +#define BTM_FLG_WRAP (((Uint32) 1) << 4) + +struct ErtsBifTimer_ { + struct { + union { + ErtsBifTimer **head; + ErtsBifTimer *prev; + } u; + ErtsBifTimer *next; + } tab; + union { + Eterm name; + struct { + ErtsBifTimer *prev; + ErtsBifTimer *next; + Process *ess; + } proc; + } receiver; + ErlTimer tm; + ErlHeapFragment* bp; + Uint32 flags; + Eterm message; + Uint32 ref_numbers[ERTS_REF_NUMBERS]; +}; + +#ifdef SMALL_MEMORY +#define TIMER_HASH_VEC_SZ 3331 +#define BTM_PREALC_SZ 10 +#else +#define TIMER_HASH_VEC_SZ 10007 +#define BTM_PREALC_SZ 100 +#endif +static ErtsBifTimer **bif_timer_tab; +static Uint no_bif_timers; + + +static erts_smp_rwmtx_t bif_timer_lock; + +#define erts_smp_safe_btm_rwlock(P, L) \ + safe_btm_lock((P), (L), 1) +#define erts_smp_safe_btm_rlock(P, L) \ + safe_btm_lock((P), (L), 0) +#define erts_smp_btm_rwlock() \ + erts_smp_rwmtx_rwlock(&bif_timer_lock) +#define erts_smp_btm_tryrwlock() \ + erts_smp_rwmtx_tryrwlock(&bif_timer_lock) +#define erts_smp_btm_rwunlock() \ + erts_smp_rwmtx_rwunlock(&bif_timer_lock) +#define erts_smp_btm_rlock() \ + erts_smp_rwmtx_rlock(&bif_timer_lock) +#define erts_smp_btm_tryrlock() \ + erts_smp_rwmtx_tryrlock(&bif_timer_lock) +#define erts_smp_btm_runlock() \ + erts_smp_rwmtx_runlock(&bif_timer_lock) +#define erts_smp_btm_lock_init() \ + erts_smp_rwmtx_init(&bif_timer_lock, "bif_timers") + + +static ERTS_INLINE int +safe_btm_lock(Process *c_p, ErtsProcLocks c_p_locks, int rw_lock) +{ + ASSERT(c_p && c_p_locks); +#ifdef ERTS_SMP + if ((rw_lock ? erts_smp_btm_tryrwlock() : erts_smp_btm_tryrlock()) != EBUSY) + return 0; + erts_smp_proc_unlock(c_p, c_p_locks); + if (rw_lock) + erts_smp_btm_rwlock(); + else + erts_smp_btm_rlock(); + erts_smp_proc_lock(c_p, c_p_locks); + if (ERTS_PROC_IS_EXITING(c_p)) { + if (rw_lock) + erts_smp_btm_rwunlock(); + else + erts_smp_btm_runlock(); + return 1; + } +#endif + return 0; +} + +ERTS_SCHED_PREF_PALLOC_IMPL(btm_pre, ErtsBifTimer, BTM_PREALC_SZ) + +static ERTS_INLINE int +get_index(Uint32 *ref_numbers, Uint32 len) +{ + Uint32 hash; + /* len can potentially be larger than ERTS_REF_NUMBERS + if it has visited another node... */ + if (len > ERTS_REF_NUMBERS) + len = ERTS_REF_NUMBERS; + +#if ERTS_REF_NUMBERS != 3 +#error "ERTS_REF_NUMBERS changed. Update me..." +#endif + switch (len) { + case 3: if (!ref_numbers[2]) len = 2; + case 2: if (!ref_numbers[1]) len = 1; + default: break; + } + + ASSERT(1 <= len && len <= ERTS_REF_NUMBERS); + + hash = block_hash((byte *) ref_numbers, len * sizeof(Uint32), 0x08d12e65); + return (int) (hash % ((Uint32) TIMER_HASH_VEC_SZ)); +} + +static Eterm +create_ref(Uint *hp, Uint32 *ref_numbers, Uint32 len) +{ + Uint32 *datap; + int i; + + + if (len > ERTS_MAX_REF_NUMBERS) { + /* Such large refs should no be able to appear in the emulator */ + erl_exit(1, "%s:%d: Internal error\n", __FILE__, __LINE__); + } + +#ifdef ARCH_64 + hp[0] = make_ref_thing_header(len/2 + 1); + datap = (Uint32 *) &hp[1]; + *(datap++) = len; +#else + hp[0] = make_ref_thing_header(len); + datap = (Uint32 *) &hp[1]; +#endif + + for (i = 0; i < len; i++) + datap[i] = ref_numbers[i]; + + return make_internal_ref(hp); +} + +static int +eq_non_standard_ref_numbers(Uint32 *rn1, Uint32 len1, Uint32 *rn2, Uint32 len2) +{ +#ifdef ARCH_64 +#define MAX_REF_HEAP_SZ (1+(ERTS_MAX_REF_NUMBERS/2+1)) +#else +#define MAX_REF_HEAP_SZ (1+ERTS_MAX_REF_NUMBERS) +#endif + Uint r1_hp[MAX_REF_HEAP_SZ]; + Uint r2_hp[MAX_REF_HEAP_SZ]; + + return eq(create_ref(r1_hp, rn1, len1), create_ref(r2_hp, rn2, len2)); +#undef MAX_REF_HEAP_SZ +} + +static ERTS_INLINE int +eq_ref_numbers(Uint32 *rn1, Uint32 len1, Uint32 *rn2, Uint32 len2) +{ + int res; + if (len1 != ERTS_REF_NUMBERS || len2 != ERTS_REF_NUMBERS) { + /* Can potentially happen, but will never... */ + return eq_non_standard_ref_numbers(rn1, len1, rn2, len2); + } + +#if ERTS_REF_NUMBERS != 3 +#error "ERTS_REF_NUMBERS changed. Update me..." +#endif + res = rn1[0] == rn2[0] && rn1[1] == rn2[1] && rn1[2] == rn2[2]; + + ASSERT(res + ? eq_non_standard_ref_numbers(rn1, len1, rn2, len2) + : !eq_non_standard_ref_numbers(rn1, len1, rn2, len2)); + + return res; +} + +static ERTS_INLINE ErtsBifTimer * +tab_find(Eterm ref) +{ + Uint32 *ref_numbers = internal_ref_numbers(ref); + Uint32 ref_numbers_len = internal_ref_no_of_numbers(ref); + int ix = get_index(ref_numbers, ref_numbers_len); + ErtsBifTimer* btm; + + for (btm = bif_timer_tab[ix]; btm; btm = btm->tab.next) + if (eq_ref_numbers(ref_numbers, ref_numbers_len, + btm->ref_numbers, ERTS_REF_NUMBERS)) + return btm; + return NULL; +} + +static ERTS_INLINE void +tab_remove(ErtsBifTimer* btm) +{ + if (btm->flags & BTM_FLG_HEAD) { + *btm->tab.u.head = btm->tab.next; + if (btm->tab.next) { + btm->tab.next->flags |= BTM_FLG_HEAD; + btm->tab.next->tab.u.head = btm->tab.u.head; + } + } + else { + btm->tab.u.prev->tab.next = btm->tab.next; + if (btm->tab.next) + btm->tab.next->tab.u.prev = btm->tab.u.prev; + } + btm->flags |= BTM_FLG_CANCELED; + ASSERT(no_bif_timers > 0); + no_bif_timers--; +} + +static ERTS_INLINE void +tab_insert(ErtsBifTimer* btm) +{ + int ix = get_index(btm->ref_numbers, ERTS_REF_NUMBERS); + ErtsBifTimer* btm_list = bif_timer_tab[ix]; + + if (btm_list) { + btm_list->flags &= ~BTM_FLG_HEAD; + btm_list->tab.u.prev = btm; + } + + btm->flags |= BTM_FLG_HEAD; + btm->tab.u.head = &bif_timer_tab[ix]; + btm->tab.next = btm_list; + bif_timer_tab[ix] = btm; + no_bif_timers++; +} + +static ERTS_INLINE void +link_proc(Process *p, ErtsBifTimer* btm) +{ + btm->receiver.proc.ess = p; + btm->receiver.proc.prev = NULL; + btm->receiver.proc.next = p->bif_timers; + if (p->bif_timers) + p->bif_timers->receiver.proc.prev = btm; + p->bif_timers = btm; +} + +static ERTS_INLINE void +unlink_proc(ErtsBifTimer* btm) +{ + if (btm->receiver.proc.prev) + btm->receiver.proc.prev->receiver.proc.next = btm->receiver.proc.next; + else + btm->receiver.proc.ess->bif_timers = btm->receiver.proc.next; + if (btm->receiver.proc.next) + btm->receiver.proc.next->receiver.proc.prev = btm->receiver.proc.prev; +} + +static void +bif_timer_cleanup(ErtsBifTimer* btm) +{ + ASSERT(btm); + + if (btm->bp) + free_message_buffer(btm->bp); + + if (!btm_pre_free(btm)) { + if (btm->flags & BTM_FLG_SL_TIMER) + erts_free(ERTS_ALC_T_SL_BIF_TIMER, (void *) btm); + else + erts_free(ERTS_ALC_T_LL_BIF_TIMER, (void *) btm); + } +} + +static void +bif_timer_timeout(ErtsBifTimer* btm) +{ + ASSERT(btm); + + + erts_smp_btm_rwlock(); + + if (btm->flags & BTM_FLG_CANCELED) { + /* + * A concurrent cancel is ongoing. Do not send the timeout message, + * but cleanup here since the cancel call-back won't be called. + */ +#ifndef ERTS_SMP + ASSERT(0); +#endif + } + else { + ErtsProcLocks rp_locks = 0; + Process* rp; + + tab_remove(btm); + + ASSERT(!erts_get_current_process()); + + if (btm->flags & BTM_FLG_BYNAME) + rp = erts_whereis_process(NULL,0,btm->receiver.name,0,ERTS_P2P_FLG_SMP_INC_REFC); + else { + rp = btm->receiver.proc.ess; + erts_smp_proc_inc_refc(rp); + unlink_proc(btm); + } + + if (rp) { + Eterm message; + ErlHeapFragment *bp; + + bp = btm->bp; + btm->bp = NULL; /* Prevent cleanup of message buffer... */ + + if (!(btm->flags & BTM_FLG_WRAP)) + message = btm->message; + else { +#if ERTS_REF_NUMBERS != 3 +#error "ERTS_REF_NUMBERS changed. Update me..." +#endif + Eterm ref; + Uint *hp; + Uint wrap_size = REF_THING_SIZE + 4; + message = btm->message; + + if (!bp) { + ErlOffHeap *ohp; + ASSERT(is_immed(message)); + hp = erts_alloc_message_heap(wrap_size, + &bp, + &ohp, + rp, + &rp_locks); + } else { + Eterm old_size = bp->size; + bp = erts_resize_message_buffer(bp, old_size + wrap_size, + &message, 1); + hp = &bp->mem[0] + old_size; + } + + write_ref_thing(hp, + btm->ref_numbers[0], + btm->ref_numbers[1], + btm->ref_numbers[2]); + ref = make_internal_ref(hp); + hp += REF_THING_SIZE; + message = TUPLE3(hp, am_timeout, ref, message); + } + + erts_queue_message(rp, &rp_locks, bp, message, NIL); + erts_smp_proc_unlock(rp, rp_locks); + erts_smp_proc_dec_refc(rp); + } + } + + erts_smp_btm_rwunlock(); + + bif_timer_cleanup(btm); +} + +static Eterm +setup_bif_timer(Uint32 xflags, + Process *c_p, + Eterm time, + Eterm receiver, + Eterm message) +{ + Process *rp; + ErtsBifTimer* btm; + Uint timeout; + Eterm ref; + Uint32 *ref_numbers; + + if (!term_to_Uint(time, &timeout)) + return THE_NON_VALUE; +#ifdef ARCH_64 + if ((timeout >> 32) != 0) + return THE_NON_VALUE; +#endif + if (is_not_internal_pid(receiver) && is_not_atom(receiver)) + return THE_NON_VALUE; + + ref = erts_make_ref(c_p); + + if (is_atom(receiver)) + rp = NULL; + else { + rp = erts_pid2proc(c_p, ERTS_PROC_LOCK_MAIN, + receiver, ERTS_PROC_LOCK_MSGQ); + if (!rp) + return ref; + } + + if (timeout < ERTS_ALC_MIN_LONG_LIVED_TIME) { + if (timeout < 1000) { + btm = btm_pre_alloc(); + if (!btm) + goto sl_timer_alloc; + btm->flags = 0; + } + else { + sl_timer_alloc: + btm = (ErtsBifTimer *) erts_alloc(ERTS_ALC_T_SL_BIF_TIMER, + sizeof(ErtsBifTimer)); + btm->flags = BTM_FLG_SL_TIMER; + } + } + else { + btm = (ErtsBifTimer *) erts_alloc(ERTS_ALC_T_LL_BIF_TIMER, + sizeof(ErtsBifTimer)); + btm->flags = 0; + } + + if (rp) { + link_proc(rp, btm); + erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_MSGQ); + } + else { + ASSERT(is_atom(receiver)); + btm->receiver.name = receiver; + btm->flags |= BTM_FLG_BYNAME; + } + + btm->flags |= xflags; + + ref_numbers = internal_ref_numbers(ref); + ASSERT(internal_ref_no_of_numbers(ref) == 3); +#if ERTS_REF_NUMBERS != 3 +#error "ERTS_REF_NUMBERS changed. Update me..." +#endif + btm->ref_numbers[0] = ref_numbers[0]; + btm->ref_numbers[1] = ref_numbers[1]; + btm->ref_numbers[2] = ref_numbers[2]; + + ASSERT(eq_ref_numbers(btm->ref_numbers, ERTS_REF_NUMBERS, + ref_numbers, ERTS_REF_NUMBERS)); + + if (is_immed(message)) { + btm->bp = NULL; + btm->message = message; + } + else { + ErlHeapFragment* bp; + Eterm* hp; + Uint size; + + size = size_object(message); + btm->bp = bp = new_message_buffer(size); + hp = bp->mem; + btm->message = copy_struct(message, size, &hp, &bp->off_heap); + } + + tab_insert(btm); + ASSERT(btm == tab_find(ref)); + btm->tm.active = 0; /* MUST be initalized */ + erl_set_timer(&btm->tm, + (ErlTimeoutProc) bif_timer_timeout, + (ErlCancelProc) bif_timer_cleanup, + (void *) btm, + timeout); + return ref; +} + +/* send_after(Time, Pid, Message) -> Ref */ +BIF_RETTYPE send_after_3(BIF_ALIST_3) +{ + Eterm res; + + if (erts_smp_safe_btm_rwlock(BIF_P, ERTS_PROC_LOCK_MAIN)) + ERTS_BIF_EXITED(BIF_P); + + res = setup_bif_timer(0, BIF_P, BIF_ARG_1, BIF_ARG_2, BIF_ARG_3); + + erts_smp_btm_rwunlock(); + + if (is_non_value(res)) { + BIF_ERROR(BIF_P, BADARG); + } + else { + ASSERT(is_internal_ref(res)); + BIF_RET(res); + } +} + +/* start_timer(Time, Pid, Message) -> Ref */ +BIF_RETTYPE start_timer_3(BIF_ALIST_3) +{ + Eterm res; + + if (erts_smp_safe_btm_rwlock(BIF_P, ERTS_PROC_LOCK_MAIN)) + ERTS_BIF_EXITED(BIF_P); + + res = setup_bif_timer(BTM_FLG_WRAP, BIF_P, BIF_ARG_1, BIF_ARG_2, BIF_ARG_3); + + erts_smp_btm_rwunlock(); + + if (is_non_value(res)) { + BIF_ERROR(BIF_P, BADARG); + } + else { + ASSERT(is_internal_ref(res)); + BIF_RET(res); + } +} + +/* cancel_timer(Ref) -> false | RemainingTime */ +BIF_RETTYPE cancel_timer_1(BIF_ALIST_1) +{ + Eterm res; + ErtsBifTimer *btm; + + if (is_not_internal_ref(BIF_ARG_1)) { + if (is_ref(BIF_ARG_1)) { + BIF_RET(am_false); + } + BIF_ERROR(BIF_P, BADARG); + } + + if (erts_smp_safe_btm_rwlock(BIF_P, ERTS_PROC_LOCK_MAIN)) + ERTS_BIF_EXITED(BIF_P); + + btm = tab_find(BIF_ARG_1); + if (!btm || btm->flags & BTM_FLG_CANCELED) { + erts_smp_btm_rwunlock(); + res = am_false; + } + else { + Uint left = time_left(&btm->tm); + if (!(btm->flags & BTM_FLG_BYNAME)) { + erts_smp_proc_lock(btm->receiver.proc.ess, ERTS_PROC_LOCK_MSGQ); + unlink_proc(btm); + erts_smp_proc_unlock(btm->receiver.proc.ess, ERTS_PROC_LOCK_MSGQ); + } + tab_remove(btm); + ASSERT(!tab_find(BIF_ARG_1)); + erl_cancel_timer(&btm->tm); + erts_smp_btm_rwunlock(); + res = erts_make_integer(left, BIF_P); + } + + BIF_RET(res); +} + +/* read_timer(Ref) -> false | RemainingTime */ +BIF_RETTYPE read_timer_1(BIF_ALIST_1) +{ + Eterm res; + ErtsBifTimer *btm; + + if (is_not_internal_ref(BIF_ARG_1)) { + if (is_ref(BIF_ARG_1)) { + BIF_RET(am_false); + } + BIF_ERROR(BIF_P, BADARG); + } + + if (erts_smp_safe_btm_rlock(BIF_P, ERTS_PROC_LOCK_MAIN)) + ERTS_BIF_EXITED(BIF_P); + + btm = tab_find(BIF_ARG_1); + if (!btm || btm->flags & BTM_FLG_CANCELED) { + res = am_false; + } + else { + Uint left = time_left(&btm->tm); + res = erts_make_integer(left, BIF_P); + } + + erts_smp_btm_runlock(); + + BIF_RET(res); +} + +void +erts_print_bif_timer_info(int to, void *to_arg) +{ + int i; + int lock = !ERTS_IS_CRASH_DUMPING; + + if (lock) + erts_smp_btm_rlock(); + + for (i = 0; i < TIMER_HASH_VEC_SZ; i++) { + ErtsBifTimer *btm; + for (btm = bif_timer_tab[i]; btm; btm = btm->tab.next) { + Eterm receiver = (btm->flags & BTM_FLG_BYNAME + ? btm->receiver.name + : btm->receiver.proc.ess->id); + erts_print(to, to_arg, "=timer:%T\n", receiver); + erts_print(to, to_arg, "Message: %T\n", btm->message); + erts_print(to, to_arg, "Time left: %d ms\n", time_left(&btm->tm)); + } + } + + if (lock) + erts_smp_btm_runlock(); +} + + +void +erts_cancel_bif_timers(Process *p, ErtsProcLocks plocks) +{ + ErtsBifTimer *btm; + + if (erts_smp_btm_tryrwlock() == EBUSY) { + erts_smp_proc_unlock(p, plocks); + erts_smp_btm_rwlock(); + erts_smp_proc_lock(p, plocks); + } + + btm = p->bif_timers; + while (btm) { + ErtsBifTimer *tmp_btm; + ASSERT(!(btm->flags & BTM_FLG_CANCELED)); + tab_remove(btm); + tmp_btm = btm; + btm = btm->receiver.proc.next; + erl_cancel_timer(&tmp_btm->tm); + } + + p->bif_timers = NULL; + + erts_smp_btm_rwunlock(); +} + +void erts_bif_timer_init(void) +{ + int i; + no_bif_timers = 0; + init_btm_pre_alloc(); + erts_smp_btm_lock_init(); + bif_timer_tab = erts_alloc(ERTS_ALC_T_BIF_TIMER_TABLE, + sizeof(ErtsBifTimer *)*TIMER_HASH_VEC_SZ); + for (i = 0; i < TIMER_HASH_VEC_SZ; ++i) + bif_timer_tab[i] = NULL; +} + +Uint +erts_bif_timer_memory_size(void) +{ + Uint res; + int lock = !ERTS_IS_CRASH_DUMPING; + + if (lock) + erts_smp_btm_rlock(); + + res = (sizeof(ErtsBifTimer *)*TIMER_HASH_VEC_SZ + + no_bif_timers*sizeof(ErtsBifTimer)); + + if (lock) + erts_smp_btm_runlock(); + + return res; +} + + +void +erts_bif_timer_foreach(void (*func)(Eterm, Eterm, ErlHeapFragment *, void *), + void *arg) +{ + int i; + + ERTS_SMP_LC_ASSERT(erts_smp_is_system_blocked(0)); + + for (i = 0; i < TIMER_HASH_VEC_SZ; i++) { + ErtsBifTimer *btm; + for (btm = bif_timer_tab[i]; btm; btm = btm->tab.next) { + (*func)((btm->flags & BTM_FLG_BYNAME + ? btm->receiver.name + : btm->receiver.proc.ess->id), + btm->message, + btm->bp, + arg); + } + } +} diff --git a/erts/emulator/beam/erl_bif_timer.h b/erts/emulator/beam/erl_bif_timer.h new file mode 100644 index 0000000000..1197c176f5 --- /dev/null +++ b/erts/emulator/beam/erl_bif_timer.h @@ -0,0 +1,36 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2005-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + + +#ifndef ERL_BIF_TIMER_H__ +#define ERL_BIF_TIMER_H__ + +typedef struct ErtsBifTimer_ ErtsBifTimer; + +#include "sys.h" +#include "erl_process.h" +#include "erl_message.h" + +Uint erts_bif_timer_memory_size(void); +void erts_print_bif_timer_info(int to, void *to_arg); +void erts_cancel_bif_timers(Process *p, ErtsProcLocks plocks); +void erts_bif_timer_init(void); +void erts_bif_timer_foreach(void (*func)(Eterm,Eterm,ErlHeapFragment *,void *), + void *arg); +#endif diff --git a/erts/emulator/beam/erl_bif_trace.c b/erts/emulator/beam/erl_bif_trace.c new file mode 100644 index 0000000000..7dff5e0eeb --- /dev/null +++ b/erts/emulator/beam/erl_bif_trace.c @@ -0,0 +1,2106 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1999-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* + * Trace BIFs. + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "erl_process.h" +#include "error.h" +#include "erl_driver.h" +#include "bif.h" +#include "big.h" +#include "dist.h" +#include "erl_version.h" +#include "beam_bp.h" +#include "erl_binary.h" + +#define DECL_AM(S) Eterm AM_ ## S = am_atom_put(#S, sizeof(#S) - 1) + +static erts_smp_mtx_t trace_pattern_mutex; +const struct trace_pattern_flags erts_trace_pattern_flags_off = {0, 0, 0, 0}; +static int erts_default_trace_pattern_is_on; +static Binary *erts_default_match_spec; +static Binary *erts_default_meta_match_spec; +static struct trace_pattern_flags erts_default_trace_pattern_flags; +static Eterm erts_default_meta_tracer_pid; + +static void new_seq_trace_token(Process* p); /* help func for seq_trace_2*/ +static int already_traced(Process *p, Process *tracee_p, Eterm tracer); +static int port_already_traced(Process *p, Port *tracee_port, Eterm tracer); +static Eterm trace_info_pid(Process* p, Eterm pid_spec, Eterm key); +static Eterm trace_info_func(Process* p, Eterm pid_spec, Eterm key); +static Eterm trace_info_on_load(Process* p, Eterm key); + +static int setup_func_trace(Export* ep, void* match_prog); +static int reset_func_trace(Export* ep); +static void reset_bif_trace(int bif_index); +static void setup_bif_trace(int bif_index); +static void set_trace_bif(int bif_index, void* match_prog); +static void clear_trace_bif(int bif_index); + +void +erts_bif_trace_init(void) +{ + erts_smp_mtx_init(&trace_pattern_mutex, "trace_pattern"); + erts_default_trace_pattern_is_on = 0; + erts_default_match_spec = NULL; + erts_default_meta_match_spec = NULL; + erts_default_trace_pattern_flags = erts_trace_pattern_flags_off; + erts_default_meta_tracer_pid = NIL; +} + +/* + * Turn on/off call tracing for the given function(s). + */ + +Eterm +trace_pattern_2(Process* p, Eterm MFA, Eterm Pattern) +{ + return trace_pattern_3(p,MFA,Pattern,NIL); +} + +Eterm +trace_pattern_3(Process* p, Eterm MFA, Eterm Pattern, Eterm flaglist) +{ + Eterm mfa[3]; + int i; + int matches = 0; + int specified = 0; + enum erts_break_op on; + Binary* match_prog_set; + Eterm l; + struct trace_pattern_flags flags = erts_trace_pattern_flags_off; + int is_global; + Process *meta_tracer_proc = p; + Eterm meta_tracer_pid = p->id; + + erts_smp_proc_unlock(p, ERTS_PROC_LOCK_MAIN); + erts_smp_block_system(0); + + /* + * Check and compile the match specification. + */ + + if (Pattern == am_false) { + match_prog_set = NULL; + on = 0; + } else if (is_nil(Pattern) || Pattern == am_true) { + match_prog_set = NULL; + on = 1; + } else if (Pattern == am_restart) { + match_prog_set = NULL; + on = erts_break_reset; + } else if (Pattern == am_pause) { + match_prog_set = NULL; + on = erts_break_stop; + } else if ((match_prog_set = erts_match_set_compile(p, Pattern)) != NULL) { + MatchSetRef(match_prog_set); + on = 1; + } else{ + goto error; + } + + is_global = 0; + for(l = flaglist; is_list(l); l = CDR(list_val(l))) { + if (is_tuple(CAR(list_val(l)))) { + Eterm *tp = tuple_val(CAR(list_val(l))); + + if (arityval(tp[0]) != 2 || tp[1] != am_meta) { + goto error; + } + meta_tracer_pid = tp[2]; + if (is_internal_pid(meta_tracer_pid)) { + meta_tracer_proc = erts_pid2proc(NULL, 0, meta_tracer_pid, 0); + if (!meta_tracer_proc) { + goto error; + } + } else if (is_internal_port(meta_tracer_pid)) { + Port *meta_tracer_port; + meta_tracer_proc = NULL; + if (internal_port_index(meta_tracer_pid) >= erts_max_ports) + goto error; + meta_tracer_port = + &erts_port[internal_port_index(meta_tracer_pid)]; + if (INVALID_TRACER_PORT(meta_tracer_port, meta_tracer_pid)) { + goto error; + } + } else { + goto error; + } + if (is_global) { + goto error; + } + flags.breakpoint = 1; + flags.meta = 1; + } else { + switch (CAR(list_val(l))) { + case am_local: + if (is_global) { + goto error; + } + flags.breakpoint = 1; + flags.local = 1; + break; + case am_meta: + if (is_global) { + goto error; + } + flags.breakpoint = 1; + flags.meta = 1; + break; + case am_global: + if (flags.breakpoint) { + goto error; + } + is_global = !0; + break; + case am_call_count: + if (is_global) { + goto error; + } + flags.breakpoint = 1; + flags.call_count = 1; + break; + default: + goto error; + } + } + } + if (l != NIL) { + goto error; + } + + if (match_prog_set && !flags.local && !flags.meta && flags.call_count) { + /* A match prog is not allowed with just call_count */ + goto error; + } + + /* + * Check the MFA specification. + */ + + if (MFA == am_on_load) { + if (flags.local || (! flags.breakpoint)) { + MatchSetUnref(erts_default_match_spec); + erts_default_match_spec = match_prog_set; + MatchSetRef(erts_default_match_spec); + } + if (flags.meta) { + MatchSetUnref(erts_default_meta_match_spec); + erts_default_meta_match_spec = match_prog_set; + MatchSetRef(erts_default_meta_match_spec); + erts_default_meta_tracer_pid = meta_tracer_pid; + if (meta_tracer_proc) { + meta_tracer_proc->trace_flags |= F_TRACER; + } + } else if (! flags.breakpoint) { + MatchSetUnref(erts_default_meta_match_spec); + erts_default_meta_match_spec = NULL; + erts_default_meta_tracer_pid = NIL; + } + MatchSetUnref(match_prog_set); + if (erts_default_trace_pattern_flags.breakpoint && + flags.breakpoint) { + /* Breakpoint trace -> breakpoint trace */ + ASSERT(erts_default_trace_pattern_is_on); + if (on) { + erts_default_trace_pattern_flags.local + |= flags.local; + erts_default_trace_pattern_flags.meta + |= flags.meta; + erts_default_trace_pattern_flags.call_count + |= (on == 1) ? flags.call_count : 0; + } else { + erts_default_trace_pattern_flags.local + &= ~flags.local; + erts_default_trace_pattern_flags.meta + &= ~flags.meta; + erts_default_trace_pattern_flags.call_count + &= ~flags.call_count; + if (! (erts_default_trace_pattern_flags.breakpoint = + erts_default_trace_pattern_flags.local | + erts_default_trace_pattern_flags.meta | + erts_default_trace_pattern_flags.call_count)) { + erts_default_trace_pattern_is_on = !!on; /* i.e off */ + } + } + } else if (! erts_default_trace_pattern_flags.breakpoint && + ! flags.breakpoint) { + /* Global call trace -> global call trace */ + erts_default_trace_pattern_is_on = !!on; + } else if (erts_default_trace_pattern_flags.breakpoint && + ! flags.breakpoint) { + /* Breakpoint trace -> global call trace */ + if (on) { + erts_default_trace_pattern_flags = flags; /* Struct copy */ + erts_default_trace_pattern_is_on = !!on; + } + } else { + ASSERT(! erts_default_trace_pattern_flags.breakpoint && + flags.breakpoint); + /* Global call trace -> breakpoint trace */ + if (on) { + if (on != 1) { + flags.call_count = 0; + } + flags.breakpoint = flags.local | flags.meta | flags.call_count; + erts_default_trace_pattern_flags = flags; /* Struct copy */ + erts_default_trace_pattern_is_on = !!flags.breakpoint; + } + } + + goto done; + } else if (is_tuple(MFA)) { + Eterm *tp = tuple_val(MFA); + if (tp[0] != make_arityval(3)) { + goto error; + } + mfa[0] = tp[1]; + mfa[1] = tp[2]; + mfa[2] = tp[3]; + if (!is_atom(mfa[0]) || !is_atom(mfa[1]) || + (!is_small(mfa[2]) && mfa[2] != am_Underscore)) { + goto error; + } + for (i = 0; i < 3 && mfa[i] != am_Underscore; i++, specified++) { + /* Empty loop body */ + } + for (i = specified; i < 3; i++) { + if (mfa[i] != am_Underscore) { + goto error; + } + } + if (is_small(mfa[2])) { + mfa[2] = signed_val(mfa[2]); + } + } else { + goto error; + } + + if (meta_tracer_proc) { + meta_tracer_proc->trace_flags |= F_TRACER; + } + + + matches = erts_set_trace_pattern(mfa, specified, + match_prog_set, match_prog_set, + on, flags, meta_tracer_pid); + MatchSetUnref(match_prog_set); + + done: + + erts_smp_release_system(); + erts_smp_proc_lock(p, ERTS_PROC_LOCK_MAIN); + + return make_small(matches); + + error: + + MatchSetUnref(match_prog_set); + + erts_smp_release_system(); + erts_smp_proc_lock(p, ERTS_PROC_LOCK_MAIN); + BIF_ERROR(p, BADARG); +} + +void +erts_get_default_trace_pattern(int *trace_pattern_is_on, + Binary **match_spec, + Binary **meta_match_spec, + struct trace_pattern_flags *trace_pattern_flags, + Eterm *meta_tracer_pid) +{ + erts_smp_mtx_lock(&trace_pattern_mutex); + if (trace_pattern_is_on) + *trace_pattern_is_on = erts_default_trace_pattern_is_on; + if (match_spec) + *match_spec = erts_default_match_spec; + if (meta_match_spec) + *meta_match_spec = erts_default_meta_match_spec; + if (trace_pattern_flags) + *trace_pattern_flags = erts_default_trace_pattern_flags; + if (meta_tracer_pid) + *meta_tracer_pid = erts_default_meta_tracer_pid; + erts_smp_mtx_unlock(&trace_pattern_mutex); +} + + + + +Uint +erts_trace_flag2bit(Eterm flag) +{ + switch (flag) { + case am_all: return TRACEE_FLAGS; + case am_send: return F_TRACE_SEND; + case am_receive: return F_TRACE_RECEIVE; + case am_set_on_spawn: return F_TRACE_SOS; + case am_procs: return F_TRACE_PROCS; + case am_set_on_first_spawn: return F_TRACE_SOS1; + case am_set_on_link: return F_TRACE_SOL; + case am_set_on_first_link: return F_TRACE_SOL1; + case am_timestamp: return F_TIMESTAMP; + case am_running: return F_TRACE_SCHED; + case am_exiting: return F_TRACE_SCHED_EXIT; + case am_garbage_collection: return F_TRACE_GC; + case am_call: return F_TRACE_CALLS; + case am_arity: return F_TRACE_ARITY_ONLY; + case am_return_to: return F_TRACE_RETURN_TO; + case am_silent: return F_TRACE_SILENT; + case am_scheduler_id: return F_TRACE_SCHED_NO; + case am_running_ports: return F_TRACE_SCHED_PORTS; + case am_running_procs: return F_TRACE_SCHED_PROCS; + case am_ports: return F_TRACE_PORTS; + default: return 0; + } +} + +/* Scan the argument list and sort out the trace flags. +** +** Returns !0 on success, 0 on failure. +** +** Sets the result variables on success, if their flags has +** occurred in the argument list. +*/ +int +erts_trace_flags(Eterm List, + Uint *pMask, Eterm *pTracer, int *pCpuTimestamp) +{ + Eterm list = List; + Uint mask = 0; + Eterm tracer = NIL; + int cpu_timestamp = 0; + + while (is_list(list)) { + Uint bit; + Eterm item = CAR(list_val(list)); + if (is_atom(item) && (bit = erts_trace_flag2bit(item))) { + mask |= bit; +#ifdef HAVE_ERTS_NOW_CPU + } else if (item == am_cpu_timestamp) { + cpu_timestamp = !0; +#endif + } else if (is_tuple(item)) { + Eterm* tp = tuple_val(item); + + if (arityval(tp[0]) != 2 || tp[1] != am_tracer) goto error; + if (is_internal_pid(tp[2]) || is_internal_port(tp[2])) { + tracer = tp[2]; + } else goto error; + } else goto error; + list = CDR(list_val(list)); + } + if (is_not_nil(list)) goto error; + + if (pMask && mask) *pMask = mask; + if (pTracer && tracer != NIL) *pTracer = tracer; + if (pCpuTimestamp && cpu_timestamp) *pCpuTimestamp = cpu_timestamp; + return !0; + error: + return 0; +} + +Eterm +trace_3(Process* p, Eterm pid_spec, Eterm how, Eterm list) +{ + int on; + Eterm tracer = NIL; + int matches = 0; + Uint mask = 0; + int cpu_ts = 0; +#ifdef ERTS_SMP + int system_blocked = 0; +#endif + + if (! erts_trace_flags(list, &mask, &tracer, &cpu_ts)) { + BIF_ERROR(p, BADARG); + } + + if (is_nil(tracer) || is_internal_pid(tracer)) { + Process *tracer_proc = erts_pid2proc(p, + ERTS_PROC_LOCK_MAIN, + is_nil(tracer) ? p->id : tracer, + ERTS_PROC_LOCKS_ALL); + if (!tracer_proc) + goto error; + tracer_proc->trace_flags |= F_TRACER; + erts_smp_proc_unlock(tracer_proc, + (tracer_proc == p + ? ERTS_PROC_LOCKS_ALL_MINOR + : ERTS_PROC_LOCKS_ALL)); + } else if (is_internal_port(tracer)) { + Port *tracer_port = erts_id2port(tracer, p, ERTS_PROC_LOCK_MAIN); + if (!erts_is_valid_tracer_port(tracer)) { + if (tracer_port) + erts_smp_port_unlock(tracer_port); + goto error; + } + tracer_port->trace_flags |= F_TRACER; + erts_smp_port_unlock(tracer_port); + } else + goto error; + + switch (how) { + case am_false: + on = 0; + break; + case am_true: + on = 1; + if (is_nil(tracer)) + tracer = p->id; + break; + default: + goto error; + } + + /* + * Set/reset the call trace flag for the given Pids. + */ + + if (is_port(pid_spec)) { + Port *tracee_port; + +#ifdef HAVE_ERTS_NOW_CPU + if (cpu_ts) { + goto error; + } +#endif + + if (pid_spec == tracer) + goto error; + + tracee_port = erts_id2port(pid_spec, p, ERTS_PROC_LOCK_MAIN); + if (!tracee_port) + goto error; + + if (tracer != NIL && port_already_traced(p, tracee_port, tracer)) { + erts_smp_port_unlock(tracee_port); + goto already_traced; + } + + if (on) + tracee_port->trace_flags |= mask; + else + tracee_port->trace_flags &= ~mask; + + if (!tracee_port->trace_flags) + tracee_port->tracer_proc = NIL; + else if (tracer != NIL) + tracee_port->tracer_proc = tracer; + + erts_smp_port_unlock(tracee_port); + + matches = 1; + } else if (is_pid(pid_spec)) { + Process *tracee_p; + +#ifdef HAVE_ERTS_NOW_CPU + if (cpu_ts) { + goto error; + } +#endif + /* Check that the tracee is not dead, not tracing + * and not about to be tracing. + */ + + if (pid_spec == tracer) + goto error; + + tracee_p = erts_pid2proc(p, ERTS_PROC_LOCK_MAIN, + pid_spec, ERTS_PROC_LOCKS_ALL); + if (!tracee_p) + goto error; + + if (tracer != NIL && already_traced(p, tracee_p, tracer)) { + erts_smp_proc_unlock(tracee_p, + (tracee_p == p + ? ERTS_PROC_LOCKS_ALL_MINOR + : ERTS_PROC_LOCKS_ALL)); + goto already_traced; + } + + if (on) + tracee_p->trace_flags |= mask; + else + tracee_p->trace_flags &= ~mask; + + if ((tracee_p->trace_flags & TRACEE_FLAGS) == 0) + tracee_p->tracer_proc = NIL; + else if (tracer != NIL) + tracee_p->tracer_proc = tracer; + + erts_smp_proc_unlock(tracee_p, + (tracee_p == p + ? ERTS_PROC_LOCKS_ALL_MINOR + : ERTS_PROC_LOCKS_ALL)); + + matches = 1; + } else { + int ok = 0; + +#ifdef HAVE_ERTS_NOW_CPU + if (cpu_ts) { + if (pid_spec == am_all) { + if (on) { + if (!erts_cpu_timestamp) { +#ifdef HAVE_CLOCK_GETTIME + /* + Perhaps clock_gettime was found during config + on a different machine than this. We check + if it works here and now, then don't bother + about checking return value for error later. + */ + { + SysCpuTime start, stop; + SysTimespec tp; + int i; + + if (sys_get_proc_cputime(start, tp) < 0) + goto error; + start = ((SysCpuTime)tp.tv_sec * 1000000000LL) + + (SysCpuTime)tp.tv_nsec; + for (i = 0; i < 100; i++) + sys_get_proc_cputime(stop, tp); + stop = ((SysCpuTime)tp.tv_sec * 1000000000LL) + + (SysCpuTime)tp.tv_nsec; + if (start == 0) goto error; + if (start == stop) goto error; + } +#else /* HAVE_GETHRVTIME */ + if (erts_start_now_cpu() < 0) { + goto error; + } +#endif /* HAVE_CLOCK_GETTIME */ + erts_cpu_timestamp = !0; + } + } + } else { + goto error; + } + } +#endif + + if (pid_spec == am_all || pid_spec == am_existing) { + int i; + int procs = 0; + int ports = 0; + int mods = 0; + + if (mask & (ERTS_PROC_TRACEE_FLAGS & ~ERTS_TRACEE_MODIFIER_FLAGS)) + procs = 1; + if (mask & (ERTS_PORT_TRACEE_FLAGS & ~ERTS_TRACEE_MODIFIER_FLAGS)) + ports = 1; + if (mask & ERTS_TRACEE_MODIFIER_FLAGS) + mods = 1; + +#ifdef ERTS_SMP + erts_smp_proc_unlock(p, ERTS_PROC_LOCK_MAIN); + erts_smp_block_system(0); + system_blocked = 1; +#endif + + ok = 1; + if (procs || mods) { + /* tracing of processes */ + for (i = 0; i < erts_max_processes; i++) { + Process* tracee_p = process_tab[i]; + + if (! tracee_p) + continue; + if (tracer != NIL) { + if (tracee_p->id == tracer) + continue; + if (already_traced(NULL, tracee_p, tracer)) + continue; + } + if (on) { + tracee_p->trace_flags |= mask; + } else { + tracee_p->trace_flags &= ~mask; + } + if(!(tracee_p->trace_flags & TRACEE_FLAGS)) { + tracee_p->tracer_proc = NIL; + } else if (tracer != NIL) { + tracee_p->tracer_proc = tracer; + } + matches++; + } + } + if (ports || mods) { + /* tracing of ports */ + for (i = 0; i < erts_max_ports; i++) { + Port *tracee_port = &erts_port[i]; + if (tracee_port->status & ERTS_PORT_SFLGS_DEAD) continue; + if (tracer != NIL) { + if (tracee_port->id == tracer) continue; + if (port_already_traced(NULL, tracee_port, tracer)) continue; + } + + if (on) tracee_port->trace_flags |= mask; + else tracee_port->trace_flags &= ~mask; + + if (!(tracee_port->trace_flags & TRACEE_FLAGS)) { + tracee_port->tracer_proc = NIL; + } else if (tracer != NIL) { + tracee_port->tracer_proc = tracer; + } + /* matches are not counted for ports since it would violate compability */ + /* This could be a reason to modify this function or make a new one. */ + } + } + } + + if (pid_spec == am_all || pid_spec == am_new) { + Uint def_flags = mask; + Eterm def_tracer = tracer; + + ok = 1; + erts_change_default_tracing(on, &def_flags, &def_tracer); + +#ifdef HAVE_ERTS_NOW_CPU + if (cpu_ts && !on) { + /* cpu_ts => pid_spec == am_all */ + if (erts_cpu_timestamp) { +#ifdef HAVE_GETHRVTIME + erts_stop_now_cpu(); +#endif + erts_cpu_timestamp = 0; + } + } +#endif + } + + if (!ok) + goto error; + } + +#ifdef ERTS_SMP + if (system_blocked) { + erts_smp_release_system(); + erts_smp_proc_lock(p, ERTS_PROC_LOCK_MAIN); + } +#endif + + BIF_RET(make_small(matches)); + + already_traced: + erts_send_error_to_logger_str(p->group_leader, + "** can only have one tracer per process\n"); + + error: + +#ifdef ERTS_SMP + if (system_blocked) { + erts_smp_release_system(); + erts_smp_proc_lock(p, ERTS_PROC_LOCK_MAIN); + } +#endif + + BIF_ERROR(p, BADARG); +} + +/* Check that the process to be traced is not already traced + * by a valid other tracer than the tracer to be. + */ +static int port_already_traced(Process *c_p, Port *tracee_port, Eterm tracer) +{ + /* + * SMP build assumes that either system is blocked or: + * * main lock is held on c_p + * * all locks are held on port tracee_p + */ + if ((tracee_port->trace_flags & TRACEE_FLAGS) + && tracee_port->tracer_proc != tracer) { + /* This tracee is already being traced, and not by the + * tracer to be */ + if (is_internal_port(tracee_port->tracer_proc)) { + if (!erts_is_valid_tracer_port(tracee_port->tracer_proc)) { + /* Current trace port now invalid + * - discard it and approve the new. */ + goto remove_tracer; + } else + return 1; + } + else if(is_internal_pid(tracee_port->tracer_proc)) { + Process *tracer_p = erts_pid2proc(c_p, ERTS_PROC_LOCK_MAIN, + tracee_port->tracer_proc, 0); + if (!tracer_p) { + /* Current trace process now invalid + * - discard it and approve the new. */ + goto remove_tracer; + } else + return 1; + } + else { + remove_tracer: + tracee_port->trace_flags &= ~TRACEE_FLAGS; + tracee_port->tracer_proc = NIL; + } + } + return 0; +} + +/* Check that the process to be traced is not already traced + * by a valid other tracer than the tracer to be. + */ +static int already_traced(Process *c_p, Process *tracee_p, Eterm tracer) +{ + /* + * SMP build assumes that either system is blocked or: + * * main lock is held on c_p + * * all locks multiple are held on tracee_p + */ + if ((tracee_p->trace_flags & TRACEE_FLAGS) + && tracee_p->tracer_proc != tracer) { + /* This tracee is already being traced, and not by the + * tracer to be */ + if (is_internal_port(tracee_p->tracer_proc)) { + if (!erts_is_valid_tracer_port(tracee_p->tracer_proc)) { + /* Current trace port now invalid + * - discard it and approve the new. */ + goto remove_tracer; + } else + return 1; + } + else if(is_internal_pid(tracee_p->tracer_proc)) { + Process *tracer_p = erts_pid2proc(c_p, ERTS_PROC_LOCK_MAIN, + tracee_p->tracer_proc, 0); + if (!tracer_p) { + /* Current trace process now invalid + * - discard it and approve the new. */ + goto remove_tracer; + } else + return 1; + } + else { + remove_tracer: + tracee_p->trace_flags &= ~TRACEE_FLAGS; + tracee_p->tracer_proc = NIL; + } + } + return 0; +} + +/* + * Return information about a process or an external function being traced. + */ + +Eterm +trace_info_2(Process* p, Eterm What, Eterm Key) +{ + Eterm res; + if (What == am_on_load) { + res = trace_info_on_load(p, Key); + } else if (is_atom(What) || is_pid(What)) { + res = trace_info_pid(p, What, Key); + } else if (is_tuple(What)) { + res = trace_info_func(p, What, Key); + } else { + BIF_ERROR(p, BADARG); + } + BIF_RET(res); +} + +static Eterm +trace_info_pid(Process* p, Eterm pid_spec, Eterm key) +{ + Eterm tracer; + Uint trace_flags; + Eterm* hp; + + if (pid_spec == am_new) { + erts_get_default_tracing(&trace_flags, &tracer); + } else if (is_internal_pid(pid_spec) + && internal_pid_index(pid_spec) < erts_max_processes) { + Process *tracee; + tracee = erts_pid2proc(p, ERTS_PROC_LOCK_MAIN, + pid_spec, ERTS_PROC_LOCKS_ALL); + + if (!tracee) { + return am_undefined; + } else { + tracer = tracee->tracer_proc; + trace_flags = tracee->trace_flags; + } + + if (is_internal_pid(tracer)) { + if (!erts_pid2proc(p, ERTS_PROC_LOCK_MAIN, tracer, 0)) { + reset_tracer: + tracee->trace_flags &= ~TRACEE_FLAGS; + trace_flags = tracee->trace_flags; + tracer = tracee->tracer_proc = NIL; + } + } + else if (is_internal_port(tracer)) { + if (!erts_is_valid_tracer_port(tracer)) + goto reset_tracer; + } +#ifdef ERTS_SMP + erts_smp_proc_unlock(tracee, + (tracee == p + ? ERTS_PROC_LOCKS_ALL_MINOR + : ERTS_PROC_LOCKS_ALL)); +#endif + } else if (is_external_pid(pid_spec) + && external_pid_dist_entry(pid_spec) == erts_this_dist_entry) { + return am_undefined; + } else { + error: + BIF_ERROR(p, BADARG); + } + + if (key == am_flags) { + int num_flags = 19; /* MAXIMUM number of flags. */ + Uint needed = 3+2*num_flags; + Eterm flag_list = NIL; + Eterm* limit; + +#define FLAG0(flag_mask,flag) \ + if (trace_flags & (flag_mask)) { flag_list = CONS(hp, flag, flag_list); hp += 2; } else {} + +#if defined(DEBUG) + /* + * Check num_flags if this assertion fires. + */ +# define FLAG ASSERT(num_flags-- > 0); FLAG0 +#else +# define FLAG FLAG0 +#endif + hp = HAlloc(p, needed); + limit = hp+needed; + FLAG(F_TRACE_SEND, am_send); + FLAG(F_TRACE_RECEIVE, am_receive); + FLAG(F_TRACE_SOS, am_set_on_spawn); + FLAG(F_TRACE_CALLS, am_call); + FLAG(F_TRACE_PROCS, am_procs); + FLAG(F_TRACE_SOS1, am_set_on_first_spawn); + FLAG(F_TRACE_SOL, am_set_on_link); + FLAG(F_TRACE_SOL1, am_set_on_first_link); + FLAG(F_TRACE_SCHED, am_running); + FLAG(F_TRACE_SCHED_EXIT, am_exiting); + FLAG(F_TRACE_GC, am_garbage_collection); + FLAG(F_TIMESTAMP, am_timestamp); + FLAG(F_TRACE_ARITY_ONLY, am_arity); + FLAG(F_TRACE_RETURN_TO, am_return_to); + FLAG(F_TRACE_SILENT, am_silent); + FLAG(F_TRACE_SCHED_NO, am_scheduler_id); + FLAG(F_TRACE_PORTS, am_ports); + FLAG(F_TRACE_SCHED_PORTS, am_running_ports); + FLAG(F_TRACE_SCHED_PROCS, am_running_procs); +#undef FLAG0 +#undef FLAG + HRelease(p,limit,hp+3); + return TUPLE2(hp, key, flag_list); + } else if (key == am_tracer) { + hp = HAlloc(p, 3); + return TUPLE2(hp, key, tracer); /* Local pid or port */ + } else { + goto error; + } +} + +#define FUNC_TRACE_NOEXIST 0 +#define FUNC_TRACE_UNTRACED (1<<0) +#define FUNC_TRACE_GLOBAL_TRACE (1<<1) +#define FUNC_TRACE_LOCAL_TRACE (1<<2) +#define FUNC_TRACE_META_TRACE (1<<3) +#define FUNC_TRACE_COUNT_TRACE (1<<4) +/* + * Returns either FUNC_TRACE_NOEXIST, FUNC_TRACE_UNTRACED, + * FUNC_TRACE_GLOBAL_TRACE, or, + * an or'ed combination of at least one of FUNC_TRACE_LOCAL_TRACE, + * FUNC_TRACE_META_TRACE, FUNC_TRACE_COUNT_TRACE. + * + * If the return value contains FUNC_TRACE_GLOBAL_TRACE + * or FUNC_TRACE_LOCAL_TRACE *ms is set. + * + * If the return value contains FUNC_TRACE_META_TRACE, + * *ms_meta or *tracer_pid_meta is set. + * + * If the return value contains FUNC_TRACE_COUNT_TRACE, *count is set. + */ +static int function_is_traced(Eterm mfa[3], + Binary **ms, /* out */ + Binary **ms_meta, /* out */ + Eterm *tracer_pid_meta, /* out */ + Sint *count) /* out */ +{ + Export e; + Export* ep; + int i; + Uint *code; + + /* First look for an export entry */ + e.code[0] = mfa[0]; + e.code[1] = mfa[1]; + e.code[2] = mfa[2]; + if ((ep = export_get(&e)) != NULL) { + if (ep->address == ep->code+3 && + ep->code[3] != (Uint) em_call_error_handler) { + if (ep->code[3] == (Uint) em_call_traced_function) { + *ms = ep->match_prog_set; + return FUNC_TRACE_GLOBAL_TRACE; + } + if (ep->code[3] == (Uint) em_apply_bif) { + for (i = 0; i < BIF_SIZE; ++i) { + if (bif_export[i] == ep) { + int r = 0; + + if (erts_bif_trace_flags[i] & BIF_TRACE_AS_GLOBAL) { + *ms = ep->match_prog_set; + return FUNC_TRACE_GLOBAL_TRACE; + } else { + if (erts_bif_trace_flags[i] & BIF_TRACE_AS_LOCAL) { + r |= FUNC_TRACE_LOCAL_TRACE; + *ms = ep->match_prog_set; + } + if (erts_is_mtrace_bif(ep->code+3, ms_meta, + tracer_pid_meta)) { + r |= FUNC_TRACE_META_TRACE; + } + } + return r ? r : FUNC_TRACE_UNTRACED; + } + } + erl_exit(1,"Impossible ghost bif encountered in trace_info."); + } + } + } + + /* OK, now look for breakpoint tracing */ + if ((code = erts_find_local_func(mfa)) != NULL) { + int r = + (erts_is_trace_break(code, ms, NULL) + ? FUNC_TRACE_LOCAL_TRACE : 0) + | (erts_is_mtrace_break(code, ms_meta, tracer_pid_meta) + ? FUNC_TRACE_META_TRACE : 0) + | (erts_is_count_break(code, count) + ? FUNC_TRACE_COUNT_TRACE : 0); + + return r ? r : FUNC_TRACE_UNTRACED; + } + return FUNC_TRACE_NOEXIST; +} + +static Eterm +trace_info_func(Process* p, Eterm func_spec, Eterm key) +{ + Eterm* tp; + Eterm* hp; + Eterm mfa[3]; + Binary *ms = NULL, *ms_meta = NULL; + Sint count = 0; + Eterm traced = am_false; + Eterm match_spec = am_false; + Eterm retval = am_false; + Eterm meta = am_false; + int r; + + if (!is_tuple(func_spec)) { + goto error; + } + tp = tuple_val(func_spec); + if (tp[0] != make_arityval(3)) { + goto error; + } + if (!is_atom(tp[1]) || !is_atom(tp[2]) || !is_small(tp[3])) { + goto error; + } + mfa[0] = tp[1]; + mfa[1] = tp[2]; + mfa[2] = signed_val(tp[3]); + + r = function_is_traced(mfa, &ms, &ms_meta, &meta, &count); + switch (r) { + case FUNC_TRACE_NOEXIST: + hp = HAlloc(p, 3); + return TUPLE2(hp, key, am_undefined); + case FUNC_TRACE_UNTRACED: + hp = HAlloc(p, 3); + return TUPLE2(hp, key, am_false); + case FUNC_TRACE_GLOBAL_TRACE: + traced = am_global; + match_spec = NIL; /* Fix up later if it's asked for*/ + break; + default: + if (r & FUNC_TRACE_LOCAL_TRACE) { + traced = am_local; + match_spec = NIL; /* Fix up later if it's asked for*/ + } + break; + } + + switch (key) { + case am_traced: + retval = traced; + break; + case am_match_spec: + if (ms) { + match_spec = MatchSetGetSource(ms); + match_spec = copy_object(match_spec, p); + } + retval = match_spec; + break; + case am_meta: + retval = meta; + break; + case am_meta_match_spec: + if (r & FUNC_TRACE_META_TRACE) { + if (ms_meta) { + retval = MatchSetGetSource(ms_meta); + retval = copy_object(retval, p); + } else { + retval = NIL; + } + } + break; + case am_call_count: + if (r & FUNC_TRACE_COUNT_TRACE) { + retval = count < 0 ? + erts_make_integer(-count-1, p) : + erts_make_integer(count, p); + } + break; + case am_all: { + Eterm match_spec_meta = am_false, c = am_false, t; + + if (ms) { + match_spec = MatchSetGetSource(ms); + match_spec = copy_object(match_spec, p); + } + if (r & FUNC_TRACE_META_TRACE) { + if (ms_meta) { + match_spec_meta = MatchSetGetSource(ms_meta); + match_spec_meta = copy_object(match_spec_meta, p); + } else + match_spec_meta = NIL; + } + if (r & FUNC_TRACE_COUNT_TRACE) { + c = count < 0 ? + erts_make_integer(-count-1, p) : + erts_make_integer(count, p); + } + hp = HAlloc(p, (3+2)*5); + retval = NIL; + t = TUPLE2(hp, am_call_count, c); hp += 3; + retval = CONS(hp, t, retval); hp += 2; + t = TUPLE2(hp, am_meta_match_spec, match_spec_meta); hp += 3; + retval = CONS(hp, t, retval); hp += 2; + t = TUPLE2(hp, am_meta, meta); hp += 3; + retval = CONS(hp, t, retval); hp += 2; + t = TUPLE2(hp, am_match_spec, match_spec); hp += 3; + retval = CONS(hp, t, retval); hp += 2; + t = TUPLE2(hp, am_traced, traced); hp += 3; + retval = CONS(hp, t, retval); hp += 2; + } break; + default: + goto error; + } + hp = HAlloc(p, 3); + return TUPLE2(hp, key, retval); + + error: + BIF_ERROR(p, BADARG); +} + +static Eterm +trace_info_on_load(Process* p, Eterm key) +{ + Eterm* hp; + + if (! erts_default_trace_pattern_is_on) { + hp = HAlloc(p, 3); + return TUPLE2(hp, key, am_false); + } + switch (key) { + case am_traced: + { + Eterm traced = am_false; + + if (! erts_default_trace_pattern_flags.breakpoint) { + traced = am_global; + } else if (erts_default_trace_pattern_flags.local) { + traced = am_local; + } + hp = HAlloc(p, 3); + return TUPLE2(hp, key, traced); + } + case am_match_spec: + { + Eterm match_spec = am_false; + + if ((! erts_default_trace_pattern_flags.breakpoint) || + erts_default_trace_pattern_flags.local) { + if (erts_default_match_spec) { + match_spec = MatchSetGetSource(erts_default_match_spec); + match_spec = copy_object(match_spec, p); + hp = HAlloc(p, 3); + } else { + match_spec = NIL; + hp = HAlloc(p, 3); + } + } else { + hp = HAlloc(p, 3); + } + return TUPLE2(hp, key, match_spec); + } + case am_meta: + hp = HAlloc(p, 3); + if (erts_default_trace_pattern_flags.meta) { + return TUPLE2(hp, key, erts_default_meta_tracer_pid); + } else { + return TUPLE2(hp, key, am_false); + } + case am_meta_match_spec: + { + Eterm match_spec = am_false; + + if (erts_default_trace_pattern_flags.meta) { + if (erts_default_meta_match_spec) { + match_spec = + MatchSetGetSource(erts_default_meta_match_spec); + match_spec = copy_object(match_spec, p); + hp = HAlloc(p, 3); + } else { + match_spec = NIL; + hp = HAlloc(p, 3); + } + } else { + hp = HAlloc(p, 3); + } + return TUPLE2(hp, key, match_spec); + } + case am_call_count: + hp = HAlloc(p, 3); + if (erts_default_trace_pattern_flags.call_count) { + return TUPLE2(hp, key, am_true); + } else { + return TUPLE2(hp, key, am_false); + } + case am_all: + { + Eterm match_spec = am_false, meta_match_spec = am_false, r = NIL, t; + + if (erts_default_trace_pattern_flags.local || + (! erts_default_trace_pattern_flags.breakpoint)) { + match_spec = NIL; + } + if (erts_default_match_spec) { + match_spec = MatchSetGetSource(erts_default_match_spec); + match_spec = copy_object(match_spec, p); + } + if (erts_default_trace_pattern_flags.meta) { + meta_match_spec = NIL; + } + if (erts_default_meta_match_spec) { + meta_match_spec = + MatchSetGetSource(erts_default_meta_match_spec); + meta_match_spec = copy_object(meta_match_spec, p); + } + hp = HAlloc(p, (3+2)*5 + 3); + t = TUPLE2(hp, am_call_count, + (erts_default_trace_pattern_flags.call_count + ? am_true : am_false)); hp += 3; + r = CONS(hp, t, r); hp += 2; + t = TUPLE2(hp, am_meta_match_spec, meta_match_spec); hp += 3; + r = CONS(hp, t, r); hp += 2; + t = TUPLE2(hp, am_meta, + (erts_default_trace_pattern_flags.meta + ? erts_default_meta_tracer_pid : am_false)); hp += 3; + r = CONS(hp, t, r); hp += 2; + t = TUPLE2(hp, am_match_spec, match_spec); hp += 3; + r = CONS(hp, t, r); hp += 2; + t = TUPLE2(hp, am_traced, + (! erts_default_trace_pattern_flags.breakpoint ? + am_global : (erts_default_trace_pattern_flags.local ? + am_local : am_false))); hp += 3; + r = CONS(hp, t, r); hp += 2; + return TUPLE2(hp, key, r); + } + default: + BIF_ERROR(p, BADARG); + } +} + +#undef FUNC_TRACE_NOEXIST +#undef FUNC_TRACE_UNTRACED +#undef FUNC_TRACE_GLOBAL_TRACE +#undef FUNC_TRACE_LOCAL_TRACE + +int +erts_set_trace_pattern(Eterm* mfa, int specified, + Binary* match_prog_set, Binary *meta_match_prog_set, + int on, struct trace_pattern_flags flags, + Eterm meta_tracer_pid) +{ + int matches = 0; + int i; + + /* + * First work on normal functions (not real BIFs). + */ + + for (i = 0; i < export_list_size(); i++) { + Export* ep = export_list(i); + int j; + + if (ExportIsBuiltIn(ep)) { + continue; + } + + for (j = 0; j < specified && mfa[j] == ep->code[j]; j++) { + /* Empty loop body */ + } + if (j == specified) { + if (on) { + if (! flags.breakpoint) + matches += setup_func_trace(ep, match_prog_set); + else + reset_func_trace(ep); + } else if (! flags.breakpoint) { + matches += reset_func_trace(ep); + } + } + } + + /* + ** OK, now for the bif's + */ + for (i = 0; i < BIF_SIZE; ++i) { + Export *ep = bif_export[i]; + int j; + + if (!ExportIsBuiltIn(ep)) { + continue; + } + + if (bif_table[i].f == bif_table[i].traced) { + /* Trace wrapper same as regular function - untraceable */ + continue; + } + + for (j = 0; j < specified && mfa[j] == ep->code[j]; j++) { + /* Empty loop body */ + } + if (j == specified) { + if (! flags.breakpoint) { /* Export entry call trace */ + if (on) { + if (erts_bif_trace_flags[i] & BIF_TRACE_AS_META) { + ASSERT(ExportIsBuiltIn(bif_export[i])); + erts_clear_mtrace_bif + ((Uint *)bif_export[i]->code + 3); + erts_bif_trace_flags[i] &= ~BIF_TRACE_AS_META; + } + set_trace_bif(i, match_prog_set); + erts_bif_trace_flags[i] &= ~BIF_TRACE_AS_LOCAL; + erts_bif_trace_flags[i] |= BIF_TRACE_AS_GLOBAL; + setup_bif_trace(i); + } else { /* off */ + if (erts_bif_trace_flags[i] & BIF_TRACE_AS_GLOBAL) { + clear_trace_bif(i); + erts_bif_trace_flags[i] &= ~BIF_TRACE_AS_GLOBAL; + } + if (! erts_bif_trace_flags[i]) { + reset_bif_trace(i); + } + } + matches++; + } else { /* Breakpoint call trace */ + int m = 0; + + if (on) { + if (flags.local) { + set_trace_bif(i, match_prog_set); + erts_bif_trace_flags[i] |= BIF_TRACE_AS_LOCAL; + erts_bif_trace_flags[i] &= ~BIF_TRACE_AS_GLOBAL; + m = 1; + } + if (flags.meta) { + erts_set_mtrace_bif + ((Uint *)bif_export[i]->code + 3, + meta_match_prog_set, meta_tracer_pid); + erts_bif_trace_flags[i] |= BIF_TRACE_AS_META; + erts_bif_trace_flags[i] &= ~BIF_TRACE_AS_GLOBAL; + m = 1; + } + if (erts_bif_trace_flags[i]) { + setup_bif_trace(i); + } + } else { /* off */ + if (flags.local) { + if (erts_bif_trace_flags[i] & BIF_TRACE_AS_LOCAL) { + clear_trace_bif(i); + erts_bif_trace_flags[i] &= ~BIF_TRACE_AS_LOCAL; + } + m = 1; + } + if (flags.meta) { + if (erts_bif_trace_flags[i] & BIF_TRACE_AS_META) { + erts_clear_mtrace_bif + ((Uint *)bif_export[i]->code + 3); + erts_bif_trace_flags[i] &= ~BIF_TRACE_AS_META; + } + m = 1; + } + if (! erts_bif_trace_flags[i]) { + reset_bif_trace(i); + } + } + matches += m; + } + } + } + + /* + ** So, now for breakpoint tracing + */ + if (on) { + if (! flags.breakpoint) { + erts_clear_trace_break(mfa, specified); + erts_clear_mtrace_break(mfa, specified); + erts_clear_count_break(mfa, specified); + } else { + int m = 0; + if (flags.local) { + m = erts_set_trace_break(mfa, specified, match_prog_set, + am_true); + } + if (flags.meta) { + m = erts_set_mtrace_break(mfa, specified, meta_match_prog_set, + meta_tracer_pid); + } + if (flags.call_count) { + m = erts_set_count_break(mfa, specified, on); + } + /* All assignments to 'm' above should give the same value, + * so just use the last */ + matches += m; + } + } else { + int m = 0; + if (flags.local) { + m = erts_clear_trace_break(mfa, specified); + } + if (flags.meta) { + m = erts_clear_mtrace_break(mfa, specified); + } + if (flags.call_count) { + m = erts_clear_count_break(mfa, specified); + } + /* All assignments to 'm' above should give the same value, + * so just use the last */ + matches += m; + } + + return matches; +} + +/* + * Setup function tracing for the given exported function. + * + * Return Value: 1 if entry refers to a BIF or loaded function, + * 0 if the entry refers to a function not loaded. + */ + +static int +setup_func_trace(Export* ep, void* match_prog) +{ + if (ep->address == ep->code+3) { + if (ep->code[3] == (Uint) em_call_error_handler) { + return 0; + } else if (ep->code[3] == (Uint) em_call_traced_function) { + MatchSetUnref(ep->match_prog_set); + ep->match_prog_set = match_prog; + MatchSetRef(ep->match_prog_set); + return 1; + } else { + /* + * We ignore apply/3 and anything else. + */ + return 0; + } + } + + /* + * Currently no trace support for native code. + */ + if (erts_is_native_break(ep->address)) { + return 0; + } + + ep->code[3] = (Uint) em_call_traced_function; + ep->code[4] = (Uint) ep->address; + ep->address = ep->code+3; + ep->match_prog_set = match_prog; + MatchSetRef(ep->match_prog_set); + return 1; +} + +static void setup_bif_trace(int bif_index) { + Export *ep = bif_export[bif_index]; + + ASSERT(ExportIsBuiltIn(ep)); + ASSERT(ep->code[4]); + ep->code[4] = (Uint) bif_table[bif_index].traced; +} + +static void set_trace_bif(int bif_index, void* match_prog) { + Export *ep = bif_export[bif_index]; + +#ifdef HARDDEBUG + erts_fprintf(stderr, "set_trace_bif: %T:%T/%bpu\n", + ep->code[0], ep->code[1], ep->code[2]); +#endif + ASSERT(ExportIsBuiltIn(ep)); + MatchSetUnref(ep->match_prog_set); + ep->match_prog_set = match_prog; + MatchSetRef(ep->match_prog_set); +} + +/* + * Reset function tracing for the given exported function. + * + * Return Value: 1 if entry refers to a BIF or loaded function, + * 0 if the entry refers to a function not loaded. + */ + +static int +reset_func_trace(Export* ep) +{ + if (ep->address == ep->code+3) { + if (ep->code[3] == (Uint) em_call_error_handler) { + return 0; + } else if (ep->code[3] == (Uint) em_call_traced_function) { + ep->address = (Uint *) ep->code[4]; + MatchSetUnref(ep->match_prog_set); + ep->match_prog_set = NULL; + return 1; + } else { + /* + * We ignore apply/3 and anything else. + */ + return 0; + } + } + + /* + * Currently no trace support for native code. + */ + if (erts_is_native_break(ep->address)) { + return 0; + } + + /* + * Nothing to do, but the export entry matches. + */ + + return 1; +} + +static void reset_bif_trace(int bif_index) { + Export *ep = bif_export[bif_index]; + + ASSERT(ExportIsBuiltIn(ep)); + ASSERT(ep->code[4]); + ASSERT(! ep->match_prog_set); + ASSERT(! erts_is_mtrace_bif((Uint *)ep->code+3, NULL, NULL)); + ep->code[4] = (Uint) bif_table[bif_index].f; +} + +static void clear_trace_bif(int bif_index) { + Export *ep = bif_export[bif_index]; + +#ifdef HARDDEBUG + erts_fprintf(stderr, "clear_trace_bif: %T:%T/%bpu\n", + ep->code[0], ep->code[1], ep->code[2]); +#endif + ASSERT(ExportIsBuiltIn(ep)); + MatchSetUnref(ep->match_prog_set); + ep->match_prog_set = NULL; +} + +/* + * Sequential tracing + * + * The sequential trace token is internally implemented as + * a tuple + * {Flags, Label, Serial, Sender, LastSerial} + * + * where + * - Flags is an integer (using masks 1, 2, and 4, for send, + * receive and print, respectively), + * - Label is any term, Serial (for now XXX) is an integer (it should + * be a list reflecting split traces), and + * - Sender is the Pid of the sender (i.e. the current process, + * except immediately after a message reception, in case it is + * the pid of the process that sent the message). + * + */ + +BIF_RETTYPE seq_trace_2(BIF_ALIST_2) +{ + Eterm res; + res = erts_seq_trace(BIF_P, BIF_ARG_1, BIF_ARG_2, 1); + if (is_non_value(res)) { + BIF_ERROR(BIF_P, BADARG); + } + BIF_RET(res); +} + +Eterm erts_seq_trace(Process *p, Eterm arg1, Eterm arg2, + int build_result) +{ + Eterm flags; + Eterm old_value = am_true; + Eterm* hp; + int current_flag; + + if (!is_atom(arg1)) { + return THE_NON_VALUE; + } + + + if (arg1 == am_send) { + current_flag = SEQ_TRACE_SEND; + } else if (arg1 == am_receive) { + current_flag = SEQ_TRACE_RECEIVE; + } else if (arg1 == am_print) { + current_flag = SEQ_TRACE_PRINT; + } else if (arg1 == am_timestamp) { + current_flag = SEQ_TRACE_TIMESTAMP; + } + else + current_flag = 0; + + if (current_flag && ( (arg2 == am_true) || (arg2 == am_false)) ) { + /* Flags */ + new_seq_trace_token(p); + flags = unsigned_val(SEQ_TRACE_TOKEN_FLAGS(p)); + if (build_result) { + old_value = flags & current_flag ? am_true : am_false; + } + if (arg2 == am_true) + SEQ_TRACE_TOKEN_FLAGS(p) = make_small(flags|current_flag); + else if (arg2 == am_false) + SEQ_TRACE_TOKEN_FLAGS(p) = make_small(flags&~current_flag); + else { + return THE_NON_VALUE; + } + return old_value; + } + else if (arg1 == am_label) { + if (! is_small(arg2)) { + return THE_NON_VALUE; + } + new_seq_trace_token(p); + if (build_result) { + old_value = SEQ_TRACE_TOKEN_LABEL(p); + } + SEQ_TRACE_TOKEN_LABEL(p) = arg2; + return old_value; + } + else if (arg1 == am_serial) { + Eterm* tp; + if (is_not_tuple(arg2)) { + return THE_NON_VALUE; + } + tp = tuple_val(arg2); + if ((*tp != make_arityval(2)) || is_not_small(*(tp+1)) || is_not_small(*(tp+2))) { + return THE_NON_VALUE; + } + new_seq_trace_token(p); + if (build_result) { + hp = HAlloc(p,3); + old_value = TUPLE2(hp, SEQ_TRACE_TOKEN_LASTCNT(p), + SEQ_TRACE_TOKEN_SERIAL(p)); + } + SEQ_TRACE_TOKEN_LASTCNT(p) = *(tp+1); + SEQ_TRACE_TOKEN_SERIAL(p) = *(tp+2); + p->seq_trace_clock = unsigned_val(*(tp+2)); + p->seq_trace_lastcnt = unsigned_val(*(tp+1)); + return old_value; + } + else if (arg1 == am_sequential_trace_token) { + if (is_not_nil(arg2)) { + return THE_NON_VALUE; + } + if (build_result) { + old_value = SEQ_TRACE_TOKEN(p); + } + SEQ_TRACE_TOKEN(p) = NIL; + return old_value; + } + else { + return THE_NON_VALUE; + } +} + +void +new_seq_trace_token(Process* p) +{ + Eterm* hp; + + if (SEQ_TRACE_TOKEN(p) == NIL) { + hp = HAlloc(p, 6); + SEQ_TRACE_TOKEN(p) = TUPLE5(hp, make_small(0), /* Flags */ + make_small(0), /* Label */ + make_small(0), /* Serial */ + p->id, /* Internal pid */ /* From */ + make_small(p->seq_trace_lastcnt)); + } +} + +BIF_RETTYPE seq_trace_info_1(BIF_ALIST_1) +{ + Eterm item; + Eterm res; + Eterm* hp; + Uint current_flag; + + if (is_not_atom(BIF_ARG_1)) { + BIF_ERROR(BIF_P, BADARG); + } + + item = BIF_ARG_1; + + if (SEQ_TRACE_TOKEN(BIF_P) == NIL) { + if ((item == am_send) || (item == am_receive) || + (item == am_print) || (item == am_timestamp)) { + hp = HAlloc(BIF_P,3); + res = TUPLE2(hp, item, am_false); + BIF_RET(res); + } else if ((item == am_label) || (item == am_serial)) { + BIF_RET(NIL); + } else { + goto error; + } + } + + if (BIF_ARG_1 == am_send) { + current_flag = SEQ_TRACE_SEND; + } else if (BIF_ARG_1 == am_receive) { + current_flag = SEQ_TRACE_RECEIVE; + } else if (BIF_ARG_1 == am_print) { + current_flag = SEQ_TRACE_PRINT; + } else if (BIF_ARG_1 == am_timestamp) { + current_flag = SEQ_TRACE_TIMESTAMP; + } else { + current_flag = 0; + } + + if (current_flag) { + res = unsigned_val(SEQ_TRACE_TOKEN_FLAGS(BIF_P)) & current_flag ? + am_true : am_false; + } else if (item == am_label) { + res = SEQ_TRACE_TOKEN_LABEL(BIF_P); + } else if (item == am_serial) { + hp = HAlloc(BIF_P, 3); + res = TUPLE2(hp, SEQ_TRACE_TOKEN_LASTCNT(BIF_P), SEQ_TRACE_TOKEN_SERIAL(BIF_P)); + } else { + error: + BIF_ERROR(BIF_P, BADARG); + } + hp = HAlloc(BIF_P, 3); + res = TUPLE2(hp, item, res); + BIF_RET(res); +} + +/* + seq_trace_print(Message) -> true | false + This function passes Message to the system_tracer + if the trace_token is not NIL. + Returns true if Message is passed else false + Note! That true is returned if the conditions to pass Message is + fulfilled, but nothing is passed if system_seq_tracer is not set. + */ +BIF_RETTYPE seq_trace_print_1(BIF_ALIST_1) +{ + if (SEQ_TRACE_TOKEN(BIF_P) == NIL) + BIF_RET(am_false); + seq_trace_update_send(BIF_P); + seq_trace_output(SEQ_TRACE_TOKEN(BIF_P), BIF_ARG_1, + SEQ_TRACE_PRINT, NIL, BIF_P); + BIF_RET(am_true); +} + +/* + seq_trace_print(Label,Message) -> true | false + This function passes Message to the system_tracer + if the trace_token is not NIL and the trace_token label is equal to + Label. Returns true if Message is passed else false + Note! That true is returned if the conditions to pass Message is + fulfilled, but nothing is passed if system_seq_tracer is not set. + */ +BIF_RETTYPE seq_trace_print_2(BIF_ALIST_2) +{ + if (SEQ_TRACE_TOKEN(BIF_P) == NIL) + BIF_RET(am_false); + if (!(is_atom(BIF_ARG_1) || is_small(BIF_ARG_1))) { + BIF_ERROR(BIF_P, BADARG); + } + if (SEQ_TRACE_TOKEN_LABEL(BIF_P) != BIF_ARG_1) + BIF_RET(am_false); + seq_trace_update_send(BIF_P); + seq_trace_output(SEQ_TRACE_TOKEN(BIF_P), BIF_ARG_2, + SEQ_TRACE_PRINT, NIL, BIF_P); + BIF_RET(am_true); +} + +void erts_system_monitor_clear(Process *c_p) { +#ifdef ERTS_SMP + if (c_p) { + erts_smp_proc_unlock(c_p, ERTS_PROC_LOCK_MAIN); + erts_smp_block_system(0); + } +#endif + erts_set_system_monitor(NIL); + erts_system_monitor_long_gc = 0; + erts_system_monitor_large_heap = 0; + erts_system_monitor_flags.busy_port = 0; + erts_system_monitor_flags.busy_dist_port = 0; +#ifdef ERTS_SMP + if (c_p) { + erts_smp_release_system(); + erts_smp_proc_lock(c_p, ERTS_PROC_LOCK_MAIN); + } +#endif +} + + +static Eterm system_monitor_get(Process *p) +{ + Eterm *hp; + Eterm system_monitor = erts_get_system_monitor(); + + if (system_monitor == NIL) { + return am_undefined; + } else { + Eterm res; + Uint hsz = 3 + (erts_system_monitor_flags.busy_dist_port ? 2 : 0) + + (erts_system_monitor_flags.busy_port ? 2 : 0); + Eterm long_gc = NIL; + Eterm large_heap = NIL; + + if (erts_system_monitor_long_gc != 0) { + hsz += 2+3; + (void) erts_bld_uint(NULL, &hsz, erts_system_monitor_long_gc); + } + if (erts_system_monitor_large_heap != 0) { + hsz += 2+3; + (void) erts_bld_uint(NULL, &hsz, erts_system_monitor_large_heap); + } + + hp = HAlloc(p, hsz); + if (erts_system_monitor_long_gc != 0) { + long_gc = erts_bld_uint(&hp, NULL, erts_system_monitor_long_gc); + } + if (erts_system_monitor_large_heap != 0) { + large_heap = erts_bld_uint(&hp, NULL, erts_system_monitor_large_heap); + } + res = NIL; + if (long_gc != NIL) { + Eterm t = TUPLE2(hp, am_long_gc, long_gc); hp += 3; + res = CONS(hp, t, res); hp += 2; + } + if (large_heap != NIL) { + Eterm t = TUPLE2(hp, am_large_heap, large_heap); hp += 3; + res = CONS(hp, t, res); hp += 2; + } + if (erts_system_monitor_flags.busy_port) { + res = CONS(hp, am_busy_port, res); hp += 2; + } + if (erts_system_monitor_flags.busy_dist_port) { + res = CONS(hp, am_busy_dist_port, res); hp += 2; + } + return TUPLE2(hp, system_monitor, res); + } +} + + +BIF_RETTYPE system_monitor_0(Process *p) { + BIF_RET(system_monitor_get(p)); +} + +BIF_RETTYPE system_monitor_1(Process *p, Eterm spec) { + if (spec == am_undefined) { + BIF_RET(system_monitor_2(p, spec, NIL)); + } else if (is_tuple(spec)) { + Eterm *tp = tuple_val(spec); + if (tp[0] != make_arityval(2)) goto error; + BIF_RET(system_monitor_2(p, tp[1], tp[2])); + } + error: + BIF_ERROR(p, BADARG); +} + +BIF_RETTYPE system_monitor_2(Process *p, Eterm monitor_pid, Eterm list) { + Eterm prev; + int system_blocked = 0; + + if (monitor_pid == am_undefined || list == NIL) { + prev = system_monitor_get(p); + erts_system_monitor_clear(p); + BIF_RET(prev); + } + if (is_not_list(list)) goto error; + else { + Uint long_gc, large_heap; + int busy_port, busy_dist_port; + + system_blocked = 1; + erts_smp_proc_unlock(p, ERTS_PROC_LOCK_MAIN); + erts_smp_block_system(0); + + if (!erts_pid2proc(p, ERTS_PROC_LOCK_MAIN, monitor_pid, 0)) + goto error; + + for (long_gc = 0, large_heap = 0, busy_port = 0, busy_dist_port = 0; + is_list(list); + list = CDR(list_val(list))) { + Eterm t = CAR(list_val(list)); + if (is_tuple(t)) { + Eterm *tp = tuple_val(t); + if (arityval(tp[0]) != 2) goto error; + if (tp[1] == am_long_gc) { + if (! term_to_Uint(tp[2], &long_gc)) goto error; + if (long_gc < 1) long_gc = 1; + } else if (tp[1] == am_large_heap) { + if (! term_to_Uint(tp[2], &large_heap)) goto error; + if (large_heap < 16384) large_heap = 16384; + /* 16 Kword is not an unnatural heap size */ + } else goto error; + } else if (t == am_busy_port) { + busy_port = !0; + } else if (t == am_busy_dist_port) { + busy_dist_port = !0; + } else goto error; + } + if (is_not_nil(list)) goto error; + prev = system_monitor_get(p); + erts_set_system_monitor(monitor_pid); + erts_system_monitor_long_gc = long_gc; + erts_system_monitor_large_heap = large_heap; + erts_system_monitor_flags.busy_port = !!busy_port; + erts_system_monitor_flags.busy_dist_port = !!busy_dist_port; + + erts_smp_release_system(); + erts_smp_proc_lock(p, ERTS_PROC_LOCK_MAIN); + BIF_RET(prev); + } + + error: + + if (system_blocked) { + erts_smp_release_system(); + erts_smp_proc_lock(p, ERTS_PROC_LOCK_MAIN); + } + + BIF_ERROR(p, BADARG); +} + +/* Begin: Trace for System Profiling */ + +void erts_system_profile_clear(Process *c_p) { +#ifdef ERTS_SMP + if (c_p) { + erts_smp_proc_unlock(c_p, ERTS_PROC_LOCK_MAIN); + erts_smp_block_system(0); + } +#endif + erts_set_system_profile(NIL); + erts_system_profile_flags.scheduler = 0; + erts_system_profile_flags.runnable_procs = 0; + erts_system_profile_flags.runnable_ports = 0; + erts_system_profile_flags.exclusive = 0; +#ifdef ERTS_SMP + if (c_p) { + erts_smp_release_system(); + erts_smp_proc_lock(c_p, ERTS_PROC_LOCK_MAIN); + } +#endif +} + +static Eterm system_profile_get(Process *p) { + Eterm *hp; + Eterm system_profile = erts_get_system_profile(); + if (system_profile == NIL) { + return am_undefined; + } else { + Eterm res; + Uint hsz = 3 + + (erts_system_profile_flags.scheduler ? 2 : 0) + + (erts_system_profile_flags.runnable_ports ? 2 : 0) + + (erts_system_profile_flags.exclusive ? 2 : 0) + + (erts_system_profile_flags.runnable_procs ? 2 : 0); + + hp = HAlloc(p, hsz); + res = NIL; + if (erts_system_profile_flags.runnable_ports) { + res = CONS(hp, am_runnable_ports, res); hp += 2; + } + if (erts_system_profile_flags.runnable_procs) { + res = CONS(hp, am_runnable_procs, res); hp += 2; + } + if (erts_system_profile_flags.scheduler) { + res = CONS(hp, am_scheduler, res); hp += 2; + } + if (erts_system_profile_flags.exclusive) { + res = CONS(hp, am_exclusive, res); hp += 2; + } + return TUPLE2(hp, system_profile, res); + } +} + +BIF_RETTYPE system_profile_0(Process *p) { + BIF_RET(system_profile_get(p)); +} + +BIF_RETTYPE system_profile_2(Process *p, Eterm profiler, Eterm list) { + Eterm prev; + int system_blocked = 0; + Process *profiler_p = NULL; + Port *profiler_port = NULL; + + if (profiler == am_undefined || list == NIL) { + prev = system_profile_get(p); + erts_system_profile_clear(p); + BIF_RET(prev); + } + if (is_not_list(list)) { + goto error; + } else { + int scheduler, runnable_procs, runnable_ports, exclusive; + system_blocked = 1; + + erts_smp_proc_unlock(p, ERTS_PROC_LOCK_MAIN); + erts_smp_block_system(0); + + /* Check if valid process, no locks are taken */ + + if (is_internal_pid(profiler)) { + if (internal_pid_index(profiler) >= erts_max_processes) goto error; + profiler_p = process_tab[internal_pid_index(profiler)]; + if (INVALID_PID(profiler_p, profiler)) goto error; + } else if (is_internal_port(profiler)) { + if (internal_port_index(profiler) >= erts_max_ports) goto error; + profiler_port = &erts_port[internal_port_index(profiler)]; + if (INVALID_TRACER_PORT(profiler_port, profiler)) goto error; + } else { + goto error; + } + + for (scheduler = 0, runnable_ports = 0, runnable_procs = 0, exclusive = 0; + is_list(list); + list = CDR(list_val(list))) { + + Eterm t = CAR(list_val(list)); + if (t == am_runnable_procs) { + runnable_procs = !0; + } else if (t == am_runnable_ports) { + runnable_ports = !0; + } else if (t == am_exclusive) { + exclusive = !0; + } else if (t == am_scheduler) { + scheduler = !0; + } else goto error; + } + if (is_not_nil(list)) goto error; + prev = system_profile_get(p); + erts_set_system_profile(profiler); + + erts_system_profile_flags.scheduler = !!scheduler; + if (erts_system_profile_flags.scheduler) + erts_system_profile_setup_active_schedulers(); + erts_system_profile_flags.runnable_ports = !!runnable_ports; + erts_system_profile_flags.runnable_procs = !!runnable_procs; + erts_system_profile_flags.exclusive = !!exclusive; + + erts_smp_release_system(); + erts_smp_proc_lock(p, ERTS_PROC_LOCK_MAIN); + + BIF_RET(prev); + + } + + error: + if (system_blocked) { + erts_smp_release_system(); + erts_smp_proc_lock(p, ERTS_PROC_LOCK_MAIN); + } + + BIF_ERROR(p, BADARG); +} +/* End: Trace for System Profiling */ + +BIF_RETTYPE +trace_delivered_1(BIF_ALIST_1) +{ + DECL_AM(trace_delivered); +#ifdef ERTS_SMP + ErlHeapFragment *bp; +#else + ErtsProcLocks locks = 0; +#endif + Eterm *hp; + Eterm msg, ref, msg_ref; + Process *p; + if (BIF_ARG_1 == am_all) { + p = NULL; + } else if (! (p = erts_pid2proc(BIF_P, ERTS_PROC_LOCK_MAIN, + BIF_ARG_1, ERTS_PROC_LOCKS_ALL))) { + if (is_not_internal_pid(BIF_ARG_1) + || internal_pid_index(BIF_ARG_1) >= erts_max_processes) { + BIF_ERROR(BIF_P, BADARG); + } + } + + ref = erts_make_ref(BIF_P); + +#ifdef ERTS_SMP + bp = new_message_buffer(REF_THING_SIZE + 4); + hp = &bp->mem[0]; + msg_ref = STORE_NC(&hp, &bp->off_heap.externals, ref); +#else + hp = HAlloc(BIF_P, 4); + msg_ref = ref; +#endif + + msg = TUPLE3(hp, AM_trace_delivered, BIF_ARG_1, msg_ref); + +#ifdef ERTS_SMP + erts_send_sys_msg_proc(BIF_P->id, BIF_P->id, msg, bp); + if (p) + erts_smp_proc_unlock(p, + (BIF_P == p + ? ERTS_PROC_LOCKS_ALL_MINOR + : ERTS_PROC_LOCKS_ALL)); +#else + erts_send_message(BIF_P, BIF_P, &locks, msg, ERTS_SND_FLG_NO_SEQ_TRACE); +#endif + + BIF_RET(ref); +} diff --git a/erts/emulator/beam/erl_binary.h b/erts/emulator/beam/erl_binary.h new file mode 100644 index 0000000000..dc5539faad --- /dev/null +++ b/erts/emulator/beam/erl_binary.h @@ -0,0 +1,282 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2000-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifndef __ERL_BINARY_H +#define __ERL_BINARY_H + +#include "erl_threads.h" + +/* + * Maximum number of bytes to place in a heap binary. + */ + +#define ERL_ONHEAP_BIN_LIMIT 64 + +/* + * This structure represents a SUB_BINARY. + * + * Note: The last field (orig) is not counted in arityval in the header. + * This simplifies garbage collection. + */ + +typedef struct erl_sub_bin { + Eterm thing_word; /* Subtag SUB_BINARY_SUBTAG. */ + Uint size; /* Binary size in bytes. */ + Uint offs; /* Offset into original binary. */ + byte bitsize; + byte bitoffs; + byte is_writable; /* The underlying binary is writable */ + Eterm orig; /* Original binary (REFC or HEAP binary). */ +} ErlSubBin; + +#define ERL_SUB_BIN_SIZE (sizeof(ErlSubBin)/sizeof(Eterm)) +#define HEADER_SUB_BIN _make_header(ERL_SUB_BIN_SIZE-2,_TAG_HEADER_SUB_BIN) + +/* + * This structure represents a HEAP_BINARY. + */ + +typedef struct erl_heap_bin { + Eterm thing_word; /* Subtag HEAP_BINARY_SUBTAG. */ + Uint size; /* Binary size in bytes. */ + Eterm data[1]; /* The data in the binary. */ +} ErlHeapBin; + +#define heap_bin_size(num_bytes) \ + (sizeof(ErlHeapBin)/sizeof(Eterm) - 1 + \ + ((num_bytes)+sizeof(Eterm)-1)/sizeof(Eterm)) + +#define header_heap_bin(num_bytes) \ + _make_header(heap_bin_size(num_bytes)-1,_TAG_HEADER_HEAP_BIN) + +/* + * Get the size in bytes of any type of binary. + */ + +#define binary_size(Bin) (binary_val(Bin)[1]) + +#define binary_bitsize(Bin) \ + ((*binary_val(Bin) == HEADER_SUB_BIN) ? \ + ((ErlSubBin *) binary_val(Bin))->bitsize: \ + 0) + +#define binary_bitoffset(Bin) \ + ((*binary_val(Bin) == HEADER_SUB_BIN) ? \ + ((ErlSubBin *) binary_val(Bin))->bitoffs: \ + 0) + +/* + * Get the pointer to the actual data bytes in a binary. + * Works for any type of binary. Always use binary_bytes() if + * you know that the binary cannot be a sub binary. + * + * Bin: input variable (Eterm) + * Bytep: output variable (byte *) + * Bitoffs: output variable (Uint) + * Bitsize: output variable (Uint) + */ + +#define ERTS_GET_BINARY_BYTES(Bin,Bytep,Bitoffs,Bitsize) \ +do { \ + Eterm* _real_bin = binary_val(Bin); \ + Uint _offs = 0; \ + Bitoffs = Bitsize = 0; \ + if (*_real_bin == HEADER_SUB_BIN) { \ + ErlSubBin* _sb = (ErlSubBin *) _real_bin; \ + _offs = _sb->offs; \ + Bitoffs = _sb->bitoffs; \ + Bitsize = _sb->bitsize; \ + _real_bin = binary_val(_sb->orig); \ + } \ + if (*_real_bin == HEADER_PROC_BIN) { \ + Bytep = ((ProcBin *) _real_bin)->bytes + _offs; \ + } else { \ + Bytep = (byte *)(&(((ErlHeapBin *) _real_bin)->data)) + _offs; \ + } \ +} while (0) + +/* + * Get the real binary from any binary type, where "real" means + * a REFC or HEAP binary. Also get the byte and bit offset into the + * real binary. Useful if you want to build a SUB binary from + * any binary. + * + * Bin: Input variable (Eterm) + * RealBin: Output variable (Eterm) + * ByteOffset: Output variable (Uint) + * BitOffset: Offset in bits (Uint) + * BitSize: Extra bit size (Uint) + */ + +#define ERTS_GET_REAL_BIN(Bin, RealBin, ByteOffset, BitOffset, BitSize) \ + do { \ + ErlSubBin* _sb = (ErlSubBin *) binary_val(Bin); \ + if (_sb->thing_word == HEADER_SUB_BIN) { \ + RealBin = _sb->orig; \ + ByteOffset = _sb->offs; \ + BitOffset = _sb->bitoffs; \ + BitSize = _sb->bitsize; \ + } else { \ + RealBin = Bin; \ + ByteOffset = BitOffset = BitSize = 0; \ + } \ + } while (0) + +/* + * Get a pointer to the binary bytes, for a heap or refc binary + * (NOT sub binary). + */ +#define binary_bytes(Bin) \ + (*binary_val(Bin) == HEADER_PROC_BIN ? \ + ((ProcBin *) binary_val(Bin))->bytes : \ + (ASSERT_EXPR(thing_subtag(*binary_val(Bin)) == HEAP_BINARY_SUBTAG), \ + (byte *)(&(((ErlHeapBin *) binary_val(Bin))->data)))) + +void erts_init_binary(void); + +byte* erts_get_aligned_binary_bytes(Eterm, byte**); + +#if defined(__i386__) || !defined(__GNUC__) +/* + * Doubles aren't required to be 8-byte aligned on intel x86. + * (if not gnuc we don't know if __i386__ is defined on x86; + * therefore, assume intel x86...) + */ +# define ERTS_BIN_ALIGNMENT_MASK ((Uint) 3) +#else +# define ERTS_BIN_ALIGNMENT_MASK ((Uint) 7) +#endif + +#define ERTS_CHK_BIN_ALIGNMENT(B) \ + do { ASSERT(!(B) || (((Uint) &((Binary *)(B))->orig_bytes[0]) & ERTS_BIN_ALIGNMENT_MASK) == ((Uint) 0)) } while(0) + +ERTS_GLB_INLINE void erts_free_aligned_binary_bytes(byte* buf); +ERTS_GLB_INLINE Binary *erts_bin_drv_alloc_fnf(Uint size); +ERTS_GLB_INLINE Binary *erts_bin_drv_alloc(Uint size); +ERTS_GLB_INLINE Binary *erts_bin_nrml_alloc(Uint size); +ERTS_GLB_INLINE Binary *erts_bin_realloc_fnf(Binary *bp, Uint size); +ERTS_GLB_INLINE Binary *erts_bin_realloc(Binary *bp, Uint size); +ERTS_GLB_INLINE void erts_bin_free(Binary *bp); +ERTS_GLB_INLINE Binary *erts_create_magic_binary(Uint size, + void (*destructor)(Binary *)); + +#if ERTS_GLB_INLINE_INCL_FUNC_DEF + +ERTS_GLB_INLINE void +erts_free_aligned_binary_bytes(byte* buf) +{ + if (buf) { + erts_free(ERTS_ALC_T_TMP, (void *) buf); + } +} + +ERTS_GLB_INLINE Binary * +erts_bin_drv_alloc_fnf(Uint size) +{ + Uint bsize = sizeof(Binary) - 1 + size; + void *res; + res = erts_alloc_fnf(ERTS_ALC_T_DRV_BINARY, bsize); + ERTS_CHK_BIN_ALIGNMENT(res); + return (Binary *) res; +} + +ERTS_GLB_INLINE Binary * +erts_bin_drv_alloc(Uint size) +{ + Uint bsize = sizeof(Binary) - 1 + size; + void *res; + res = erts_alloc(ERTS_ALC_T_DRV_BINARY, bsize); + ERTS_CHK_BIN_ALIGNMENT(res); + return (Binary *) res; +} + + +ERTS_GLB_INLINE Binary * +erts_bin_nrml_alloc(Uint size) +{ + Uint bsize = sizeof(Binary) - 1 + size; + void *res; + res = erts_alloc(ERTS_ALC_T_BINARY, bsize); + ERTS_CHK_BIN_ALIGNMENT(res); + return (Binary *) res; +} + +ERTS_GLB_INLINE Binary * +erts_bin_realloc_fnf(Binary *bp, Uint size) +{ + Binary *nbp; + Uint bsize = sizeof(Binary) - 1 + size; + ASSERT((bp->flags & BIN_FLAG_MAGIC) == 0); + if (bp->flags & BIN_FLAG_DRV) + nbp = erts_realloc_fnf(ERTS_ALC_T_DRV_BINARY, (void *) bp, bsize); + else + nbp = erts_realloc_fnf(ERTS_ALC_T_BINARY, (void *) bp, bsize); + ERTS_CHK_BIN_ALIGNMENT(nbp); + return nbp; +} + +ERTS_GLB_INLINE Binary * +erts_bin_realloc(Binary *bp, Uint size) +{ + Binary *nbp; + Uint bsize = sizeof(Binary) - 1 + size; + ASSERT((bp->flags & BIN_FLAG_MAGIC) == 0); + if (bp->flags & BIN_FLAG_DRV) + nbp = erts_realloc_fnf(ERTS_ALC_T_DRV_BINARY, (void *) bp, bsize); + else + nbp = erts_realloc_fnf(ERTS_ALC_T_BINARY, (void *) bp, bsize); + if (!nbp) + erts_realloc_n_enomem(ERTS_ALC_T2N(bp->flags & BIN_FLAG_DRV + ? ERTS_ALC_T_DRV_BINARY + : ERTS_ALC_T_BINARY), + bp, + bsize); + ERTS_CHK_BIN_ALIGNMENT(nbp); + return nbp; +} + +ERTS_GLB_INLINE void +erts_bin_free(Binary *bp) +{ + if (bp->flags & BIN_FLAG_MAGIC) + ERTS_MAGIC_BIN_DESTRUCTOR(bp)(bp); + if (bp->flags & BIN_FLAG_DRV) + erts_free(ERTS_ALC_T_DRV_BINARY, (void *) bp); + else + erts_free(ERTS_ALC_T_BINARY, (void *) bp); +} + +ERTS_GLB_INLINE Binary * +erts_create_magic_binary(Uint size, void (*destructor)(Binary *)) +{ + Uint bsize = sizeof(Binary) - 1 + sizeof(ErtsBinaryMagicPart) - 1 + size; + Binary* bptr = erts_alloc_fnf(ERTS_ALC_T_BINARY, bsize); + if (!bptr) + erts_alloc_n_enomem(ERTS_ALC_T2N(ERTS_ALC_T_BINARY), bsize); + ERTS_CHK_BIN_ALIGNMENT(bptr); + bptr->flags = BIN_FLAG_MAGIC; + bptr->orig_size = sizeof(ErtsBinaryMagicPart) - 1 + size; + erts_refc_init(&bptr->refc, 0); + ERTS_MAGIC_BIN_DESTRUCTOR(bptr) = destructor; + return bptr; +} + +#endif /* #if ERTS_GLB_INLINE_INCL_FUNC_DEF */ + +#endif diff --git a/erts/emulator/beam/erl_bits.c b/erts/emulator/beam/erl_bits.c new file mode 100644 index 0000000000..e4f5d50ddf --- /dev/null +++ b/erts/emulator/beam/erl_bits.c @@ -0,0 +1,1975 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1999-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "erl_process.h" +#include "error.h" +#include "bif.h" +#include "big.h" +#include "erl_bits.h" +#include "erl_binary.h" + +#ifdef MAX +#undef MAX +#endif +#define MAX(x,y) (((x)>(y))?(x):(y)) +#ifdef MIN +#undef MIN +#endif +#define MIN(x,y) (((x)<(y))?(x):(y)) + +#if defined(WORDS_BIGENDIAN) +# define BIT_ENDIAN_MACHINE 0 +#else +# define BIT_ENDIAN_MACHINE BSF_LITTLE +#endif + +#define BIT_IS_MACHINE_ENDIAN(x) (((x)&BSF_LITTLE) == BIT_ENDIAN_MACHINE) + +/* + * MAKE_MASK(n) constructs a mask with n bits. + * Example: MAKE_MASK(3) returns the binary number 00000111. + */ + +#define MAKE_MASK(n) ((((Uint) 1) << (n))-1) + +/* + * MASK_BITS assign src to dst, but preserves the dst bits outside the mask. + */ + +#define MASK_BITS(src,dst,mask) (((src) & (mask)) | ((dst) & ~(mask))) + +static byte get_bit(byte b, size_t a_offs); + +#if defined(ERTS_SMP) +/* the state resides in the current process' scheduler data */ +#elif defined(ERL_BITS_REENTRANT) +/* reentrant API but with a hidden single global state, for testing only */ +struct erl_bits_state ErlBitsState_; +#else +/* non-reentrant API with a single global state */ +struct erl_bits_state ErlBitsState; +#endif + +#define byte_buf (ErlBitsState.byte_buf_) +#define byte_buf_len (ErlBitsState.byte_buf_len_) + +#ifdef ERTS_SMP +static erts_smp_atomic_t bits_bufs_size; +#endif + +Uint +erts_bits_bufs_size(void) +{ + return 0; +} + +#if !defined(ERTS_SMP) +static +#endif +void +erts_bits_init_state(ERL_BITS_PROTO_0) +{ + byte_buf_len = 1; + byte_buf = erts_alloc(ERTS_ALC_T_BITS_BUF, byte_buf_len); + + erts_bin_offset = 0; +} + +#if defined(ERTS_SMP) +void +erts_bits_destroy_state(ERL_BITS_PROTO_0) +{ + erts_free(ERTS_ALC_T_BITS_BUF, byte_buf); +} +#endif + +void +erts_init_bits(void) +{ +#if defined(ERTS_SMP) + erts_smp_atomic_init(&bits_bufs_size, 0); + /* erl_process.c calls erts_bits_init_state() on all state instances */ +#else + ERL_BITS_DECLARE_STATEP; + erts_bits_init_state(ERL_BITS_ARGS_0); +#endif +} + +/***************************************************************** + *** + *** New matching binaries functions + *** + *****************************************************************/ + +#define ReadToVariable(v64, Buffer, x) \ + do{ \ + int _i; \ + v64 = 0; \ + for(_i = 0; _i < x; _i++) { \ + v64 = ((Uint)Buffer[_i] <<(8*_i)) + v64; \ + } \ + }while(0) \ + +Eterm +erts_bs_start_match_2(Process *p, Eterm Binary, Uint Max) +{ + Eterm Orig; + Uint offs; + Uint* hp; + Uint NeededSize; + ErlBinMatchState *ms; + Uint bitoffs; + Uint bitsize; + Uint total_bin_size; + ProcBin* pb; + + ASSERT(is_binary(Binary)); + total_bin_size = binary_size(Binary); + if ((total_bin_size >> (8*sizeof(Uint)-3)) != 0) { + return THE_NON_VALUE; + } + NeededSize = ERL_BIN_MATCHSTATE_SIZE(Max); + hp = HeapOnlyAlloc(p, NeededSize); + ms = (ErlBinMatchState *) hp; + ERTS_GET_REAL_BIN(Binary, Orig, offs, bitoffs, bitsize); + pb = (ProcBin *) boxed_val(Orig); + if (pb->thing_word == HEADER_PROC_BIN && pb->flags != 0) { + erts_emasculate_writable_binary(pb); + } + ms->thing_word = HEADER_BIN_MATCHSTATE(Max); + (ms->mb).orig = Orig; + (ms->mb).base = binary_bytes(Orig); + (ms->mb).offset = ms->save_offset[0] = 8 * offs + bitoffs; + (ms->mb).size = total_bin_size * 8 + (ms->mb).offset + bitsize; + return make_matchstate(ms); +} + +Eterm +erts_bs_get_integer_2(Process *p, Uint num_bits, unsigned flags, ErlBinMatchBuffer* mb) +{ + Uint bytes; + Uint bits; + Uint offs; + byte bigbuf[64]; + byte* LSB; + byte* MSB; + Uint* hp; + Uint* hp_end; + Uint words_needed; + Uint actual; + Uint v32; + int sgn = 0; + Eterm res = THE_NON_VALUE; + + if (num_bits == 0) { + return SMALL_ZERO; + } + + if (mb->size - mb->offset < num_bits) { /* Asked for too many bits. */ + return THE_NON_VALUE; + } + + /* + * Special cases for field sizes up to the size of Uint. + */ + + if (num_bits <= 8-(offs = BIT_OFFSET(mb->offset))) { + /* + * All bits are in one byte in the binary. We only need + * shift them right and mask them. + */ + Uint b = mb->base[BYTE_OFFSET(mb->offset)]; + Uint mask = MAKE_MASK(num_bits); + mb->offset += num_bits; + b >>= 8 - offs - num_bits; + b &= mask; + if ((flags & BSF_SIGNED) && b >> (num_bits-1)) { + b |= ~mask; + } + return make_small(b); + } else if (num_bits <= 8) { + /* + * The bits are in two different bytes. It is easiest to + * combine the bytes to a word first, and then shift right and + * mask to extract the bits. + */ + Uint byte_offset = BYTE_OFFSET(mb->offset); + Uint w = mb->base[byte_offset] << 8 | mb->base[byte_offset+1]; + Uint mask = MAKE_MASK(num_bits); + mb->offset += num_bits; + w >>= 16 - offs - num_bits; + w &= mask; + if ((flags & BSF_SIGNED) && w >> (num_bits-1)) { + w |= ~mask; + } + return make_small(w); + } else if (num_bits < SMALL_BITS && (flags & BSF_LITTLE) == 0) { + /* + * Handle field sizes from 9 up to SMALL_BITS-1 bits, big-endian, + * stored in at least two bytes. + */ + byte* bp = mb->base + BYTE_OFFSET(mb->offset); + Uint n; + Uint w; + + n = num_bits; + mb->offset += num_bits; + + /* + * Handle the most signicant byte if it contains 1 to 7 bits. + * It only needs to be masked, not shifted. + */ + if (offs == 0) { + w = 0; + } else { + Uint num_bits_in_msb = 8 - offs; + w = *bp++; + n -= num_bits_in_msb; + w &= MAKE_MASK(num_bits_in_msb); + } + + /* + * Simply shift whole bytes into the result. + */ + switch (BYTE_OFFSET(n)) { +#ifdef ARCH_64 + case 7: w = (w << 8) | *bp++; + case 6: w = (w << 8) | *bp++; + case 5: w = (w << 8) | *bp++; + case 4: w = (w << 8) | *bp++; +#endif + case 3: w = (w << 8) | *bp++; + case 2: w = (w << 8) | *bp++; + case 1: w = (w << 8) | *bp++; + } + n = BIT_OFFSET(n); + + /* + * Handle the 1 to 7 bits remaining in the last byte (if any). + * They need to be shifted right, but there is no need to mask; + * then they can be shifted into the word. + */ + if (n > 0) { + Uint b = *bp; + b >>= 8 - n; + w = (w << n) | b; + } + + /* + * Sign extend the result if the field type is 'signed' and the + * most significant bit is 1. + */ + if ((flags & BSF_SIGNED) != 0 && (w >> (num_bits-1) != 0)) { + w |= ~MAKE_MASK(num_bits); + } + return make_small(w); + } + + /* + * Handle everything else, that is: + * + * Big-endian fields >= SMALL_BITS (potentially bignums). + * Little-endian fields with 9 or more bits. + */ + + bytes = NBYTES(num_bits); + if ((bits = BIT_OFFSET(num_bits)) == 0) { /* number of bits in MSB */ + bits = 8; + } + offs = 8 - bits; /* adjusted offset in MSB */ + + if (bytes <= sizeof bigbuf) { + LSB = bigbuf; + } else { + LSB = erts_alloc(ERTS_ALC_T_TMP, bytes); + } + MSB = LSB + bytes - 1; + + /* + * Move bits to temporary buffer. We want the buffer to be stored in + * little-endian order, since bignums are little-endian. + */ + + if (flags & BSF_LITTLE) { + erts_copy_bits(mb->base, mb->offset, 1, LSB, 0, 1, num_bits); + *MSB >>= offs; /* adjust msb */ + } else { + *MSB = 0; + erts_copy_bits(mb->base, mb->offset, 1, MSB, offs, -1, num_bits); + } + mb->offset += num_bits; + + /* + * Get the sign bit. + */ + sgn = 0; + if ((flags & BSF_SIGNED) && (*MSB & (1<<(bits-1)))) { + byte* ptr = LSB; + byte c = 1; + + /* sign extend MSB */ + *MSB |= ~MAKE_MASK(bits); + + /* two's complement */ + while (ptr <= MSB) { + byte pd = ~(*ptr); + byte d = pd + c; + c = (d < pd); + *ptr++ = d; + } + sgn = 1; + } + + /* normalize */ + while ((*MSB == 0) && (MSB > LSB)) { + MSB--; + bytes--; + } + + /* check for guaranteed small num */ + switch (bytes) { + case 1: + v32 = LSB[0]; + goto big_small; + case 2: + v32 = LSB[0] + (LSB[1]<<8); + goto big_small; + case 3: + v32 = LSB[0] + (LSB[1]<<8) + (LSB[2]<<16); + goto big_small; +#if !defined(ARCH_64) + case 4: + v32 = (LSB[0] + (LSB[1]<<8) + (LSB[2]<<16) + (LSB[3]<<24)); + if (!IS_USMALL(sgn, v32)) { + goto make_big; + } +#else + case 4: + ReadToVariable(v32, LSB, 4); + goto big_small; + case 5: + ReadToVariable(v32, LSB, 5); + goto big_small; + case 6: + ReadToVariable(v32, LSB, 6); + goto big_small; + case 7: + ReadToVariable(v32, LSB, 7); + goto big_small; + case 8: + ReadToVariable(v32, LSB, 8); + if (!IS_USMALL(sgn, v32)) { + goto make_big; + } +#endif + big_small: /* v32 loaded with value which fits in fixnum */ + if (sgn) { + res = make_small(-((Sint)v32)); + } else { + res = make_small(v32); + } + break; + make_big: + hp = HeapOnlyAlloc(p, BIG_UINT_HEAP_SIZE); + if (sgn) { + hp[0] = make_neg_bignum_header(1); + } else { + hp[0] = make_pos_bignum_header(1); + } + BIG_DIGIT(hp,0) = v32; + res = make_big(hp); + break; + default: + words_needed = 1+WSIZE(bytes); + hp = HeapOnlyAlloc(p, words_needed); + hp_end = hp + words_needed; + res = bytes_to_big(LSB, bytes, sgn, hp); + if (is_small(res)) { + p->htop = hp; + } else if ((actual = bignum_header_arity(*hp)+1) < words_needed) { + p->htop = hp + actual; + } + break; + } + + if (LSB != bigbuf) { + erts_free(ERTS_ALC_T_TMP, (void *) LSB); + } + return res; +} + +Eterm +erts_bs_get_binary_2(Process *p, Uint num_bits, unsigned flags, ErlBinMatchBuffer* mb) +{ + ErlSubBin* sb; + size_t num_bytes; /* Number of bytes in binary. */ + + if (mb->size - mb->offset < num_bits) { /* Asked for too many bits. */ + return THE_NON_VALUE; + } + + /* + * From now on, we can't fail. + */ + + num_bytes = NBYTES(num_bits); + sb = (ErlSubBin *) HeapOnlyAlloc(p, ERL_SUB_BIN_SIZE); + + sb->thing_word = HEADER_SUB_BIN; + sb->orig = mb->orig; + sb->size = BYTE_OFFSET(num_bits); + sb->bitsize = BIT_OFFSET(num_bits); + sb->offs = BYTE_OFFSET(mb->offset); + sb->bitoffs = BIT_OFFSET(mb->offset); + sb->is_writable = 0; + mb->offset += num_bits; + + return make_binary(sb); +} + +Eterm +erts_bs_get_float_2(Process *p, Uint num_bits, unsigned flags, ErlBinMatchBuffer* mb) +{ + Eterm* hp; + float f32; + double f64; + byte* fptr; + FloatDef f; + + if (num_bits == 0) { + f.fd = 0.0; + hp = HeapOnlyAlloc(p, FLOAT_SIZE_OBJECT); + PUT_DOUBLE(f, hp); + return make_float(hp); + } + if (mb->size - mb->offset < num_bits) { /* Asked for too many bits. */ + return THE_NON_VALUE; + } + if (num_bits == 32) { + fptr = (byte *) &f32; + } else if (num_bits == 64) { + fptr = (byte *) &f64; + } else { + return THE_NON_VALUE; + } + + if (BIT_IS_MACHINE_ENDIAN(flags)) { + erts_copy_bits(mb->base, mb->offset, 1, + fptr, 0, 1, + num_bits); + } else { + erts_copy_bits(mb->base, mb->offset, 1, + fptr + NBYTES(num_bits) - 1, 0, -1, + num_bits); + } + ERTS_FP_CHECK_INIT(p); + if (num_bits == 32) { + ERTS_FP_ERROR_THOROUGH(p, f32, return THE_NON_VALUE); + f.fd = f32; + } else { + ERTS_FP_ERROR_THOROUGH(p, f64, return THE_NON_VALUE); + f.fd = f64; + } + mb->offset += num_bits; + hp = HeapOnlyAlloc(p, FLOAT_SIZE_OBJECT); + PUT_DOUBLE(f, hp); + return make_float(hp); +} + +Eterm +erts_bs_get_binary_all_2(Process *p, ErlBinMatchBuffer* mb) +{ + ErlSubBin* sb; + Uint size; + size = mb->size-mb->offset; + sb = (ErlSubBin *) HeapOnlyAlloc(p, ERL_SUB_BIN_SIZE); + sb->thing_word = HEADER_SUB_BIN; + sb->size = BYTE_OFFSET(size); + sb->bitsize = BIT_OFFSET(size); + sb->offs = BYTE_OFFSET(mb->offset); + sb->bitoffs = BIT_OFFSET(mb->offset); + sb->is_writable = 0; + sb->orig = mb->orig; + mb->offset = mb->size; + return make_binary(sb); +} + +/**************************************************************** + *** + *** Building binaries + *** + ****************************************************************/ + + +/* COPY_VAL: + * copy sz byte from val to dst buffer, + * dst, val are updated!!! + */ + +#define COPY_VAL(dst,ddir,val,sz) do { \ + Uint __sz = (sz); \ + while(__sz) { \ + switch(__sz) { \ + default: \ + case 4: *dst = (val&0xff); dst += ddir; val >>= 8; __sz--; \ + case 3: *dst = (val&0xff); dst += ddir; val >>= 8; __sz--; \ + case 2: *dst = (val&0xff); dst += ddir; val >>= 8; __sz--; \ + case 1: *dst = (val&0xff); dst += ddir; val >>= 8; __sz--; \ + } \ + } \ + } while(0) + +/* calculate a - *cp (carry) (store result in b), *cp is updated! */ +#define SUBc(a, cp, b) do { \ + byte __x = (a); \ + byte __y = (__x - (*(cp))); \ + (*cp) = (__y > __x); \ + *(b) = ~__y; \ + } while(0) + +static int +fmt_int(byte *buf, Uint sz, Eterm val, Uint size, Uint flags) +{ + unsigned long offs; + + ASSERT(size != 0); + offs = BIT_OFFSET(size); + if (is_small(val)) { + Sint v = signed_val(val); + if (flags & BSF_LITTLE) { /* Little endian */ + sz--; + COPY_VAL(buf,1,v,sz); + *buf = offs ? ((v << (8-offs)) & 0xff) : (v & 0xff); + } else { /* Big endian */ + buf += (sz - 1); + if (offs) { + *buf-- = (v << (8-offs)) & 0xff; + sz--; + v >>= offs; + } + COPY_VAL(buf,-1,v,sz); + } + } else if (is_big(val)) { + int sign = big_sign(val); + Uint ds = big_size(val)*sizeof(ErtsDigit); /* number of digits bytes */ + ErtsDigit* dp = big_v(val); + int n = MIN(sz,ds); + + if (flags & BSF_LITTLE) { + sz -= n; /* pad with this amount */ + if (sign) { + int c = 1; + while(n >= sizeof(ErtsDigit)) { + ErtsDigit d = *dp++; + int i; + for(i = 0; i < sizeof(ErtsDigit); ++i) { + SUBc((d&0xff), &c, buf); + buf++; + d >>= 8; + } + n -= sizeof(ErtsDigit); + } + if (n) { + ErtsDigit d = *dp; + do { + SUBc((d&0xff), &c, buf); + buf++; + d >>= 8; + } while (--n > 0); + } + /* pad */ + while(sz--) { + SUBc(0, &c, buf); + buf++; + } + } + else { + while(n >= sizeof(ErtsDigit)) { + ErtsDigit d = *dp++; + int i; + for(i = 0; i < sizeof(ErtsDigit); ++i) { + *buf++ = (d & 0xff); + d >>= 8; + } + n -= sizeof(ErtsDigit); + } + if (n) { + ErtsDigit d = *dp; + do { + *buf++ = (d & 0xff); + d >>= 8; + } while (--n > 0); + } + /* pad */ + while(sz) { + *buf++ = 0; + sz--; + } + } + /* adjust MSB!!! */ + if (offs) { + buf--; + *buf <<= (8 - offs); + } + } + else { /* BIG ENDIAN */ + ErtsDigit acc = 0; + ErtsDigit d; + + buf += (sz - 1); /* end of buffer */ + sz -= n; /* pad with this amount */ + offs = offs ? (8-offs) : 0; /* shift offset */ + + if (sign) { /* SIGNED */ + int c = 1; + + while (n >= sizeof(ErtsDigit)) { + int i; + + d = *dp++; + acc |= d << offs; + SUBc((acc&0xff), &c, buf); + buf--; + acc = d >> (8-offs); + for (i = 0; i < sizeof(ErtsDigit)-1; ++i) { + SUBc((acc&0xff), &c, buf); + buf--; + acc >>= 8; + } + n -= sizeof(ErtsDigit); + } + if (n) { + acc |= ((ErtsDigit)*dp << offs); + do { + SUBc((acc & 0xff), &c, buf); + buf--; + acc >>= 8; + } while (--n > 0); + } + /* pad */ + while(sz--) { + SUBc((acc & 0xff), &c, buf); + buf--; + acc >>= 8; + } + } + else { /* UNSIGNED */ + while (n >= sizeof(ErtsDigit)) { + int i; + + d = *dp++; + acc |= d << offs; + *buf-- = acc; + acc = d >> (8-offs); + for (i = 0; i < sizeof(ErtsDigit)-1; ++i) { + *buf-- = acc; + acc >>= 8; + } + n -= sizeof(ErtsDigit); + } + if (n) { + acc |= ((ErtsDigit)*dp << offs); + do { + *buf-- = acc & 0xff; + acc >>= 8; + } while (--n > 0); + } + while (sz--) { + *buf-- = acc & 0xff; + acc >>= 8; + } + } + } + } else { /* Neither small nor big */ + return -1; + } + return 0; +} + +static void +ERTS_INLINE need_byte_buf(ERL_BITS_PROTO_1(int need)) +{ + if (byte_buf_len < need) { +#ifdef ERTS_SMP + erts_smp_atomic_add(&bits_bufs_size, need - byte_buf_len); +#endif + byte_buf_len = need; + byte_buf = erts_realloc(ERTS_ALC_T_BITS_BUF, byte_buf, byte_buf_len); + } +} + +int +erts_new_bs_put_integer(ERL_BITS_PROTO_3(Eterm arg, Uint num_bits, unsigned flags)) +{ + Uint bin_offset = erts_bin_offset; + Uint bit_offset; + Uint b; + byte *iptr; + + if (num_bits == 0) { + return 1; + } + + bit_offset = BIT_OFFSET(bin_offset); + if (is_small(arg)) { + Uint rbits = 8 - bit_offset; + + if (bit_offset + num_bits <= 8) { + /* + * All bits are in the same byte. + */ + iptr = erts_current_bin+BYTE_OFFSET(bin_offset); + b = *iptr & (0xff << rbits); + b |= (signed_val(arg) & ((1 << num_bits)-1)) << (8-bit_offset-num_bits); + *iptr = b; + } else if (bit_offset == 0) { + /* + * More than one bit, starting at a byte boundary. + * That will be quite efficiently handled by fmt_int(). + * + * (We know that fmt_int() can't fail here.) + */ + (void) fmt_int(erts_current_bin+BYTE_OFFSET(bin_offset), + NBYTES(num_bits), arg, num_bits, flags); + } else if (flags & BSF_LITTLE) { + /* + * Can't handle unaligned little-endian in a simple way. + */ + goto unaligned; + } else { /* Big endian */ + /* + * Big-endian, more than one byte, but not aligned on a byte boundary. + * Handle the bits up to the next byte boundary specially, + * then let fmt_int() handle the rest. + */ + Uint shift_count = num_bits - rbits; + Sint val = signed_val(arg); + iptr = erts_current_bin+BYTE_OFFSET(bin_offset); + b = *iptr & (0xff << rbits); + + /* + * Shifting with a shift count greater than or equal to the word + * size may be a no-op (instead of 0 the result may be the unshifted + * value). Therefore, only do the shift and the OR if the shift count + * is less than the word size if the number is positive; if negative, + * we must simulate the sign extension. + */ + if (shift_count < sizeof(Uint)*8) { + b |= (val >> shift_count) & ((1 << rbits) - 1); + } else if (val < 0) { + /* Simulate sign extension. */ + b |= (-1) & ((1 << rbits) - 1); + } + *iptr++ = b; + + /* fmt_int() can't fail here. */ + (void) fmt_int(iptr, NBYTES(num_bits-rbits), arg, + num_bits-rbits, flags); + } + } else if (bit_offset == 0) { + /* + * Big number, aligned on a byte boundary. We can format the + * integer directly into the binary. + */ + if (fmt_int(erts_current_bin+BYTE_OFFSET(bin_offset), + NBYTES(num_bits), arg, num_bits, flags) < 0) { + return 0; + } + } else { + unaligned: + /* + * Big number or small little-endian number, not byte-aligned, + * or not a number at all. + * + * We must format the number into a temporary buffer, and then + * copy that into the binary. + */ + need_byte_buf(ERL_BITS_ARGS_1(NBYTES(num_bits))); + iptr = byte_buf; + if (fmt_int(iptr, NBYTES(num_bits), arg, num_bits, flags) < 0) { + return 0; + } + erts_copy_bits(iptr, 0, 1, erts_current_bin, bin_offset, 1, num_bits); + } + erts_bin_offset = bin_offset + num_bits; + return 1; +} + +int +erts_bs_put_utf8(ERL_BITS_PROTO_1(Eterm arg)) +{ + Uint bin_offset = erts_bin_offset; + Uint bit_offset; + Uint num_bits; + byte tmp_buf[4]; + byte* dst; + Sint val; + + if (is_not_small(arg)) { + return 0; + } + val = signed_val(arg); + if (val < 0) { + return 0; + } + + if ((bit_offset = BIT_OFFSET(bin_offset)) == 0) { + /* We can write directly into the destination binary. */ + dst = erts_current_bin+BYTE_OFFSET(bin_offset); + } else { + /* Unaligned destination binary. Must use a temporary buffer. */ + dst = tmp_buf; + } + if (val < 0x80) { + dst[0] = val; + num_bits = 8; + } else if (val < 0x800) { + dst[0] = 0xC0 | (val >> 6); + dst[1] = 0x80 | (val & 0x3F); + num_bits = 16; + } else if (val < 0x10000UL) { + if ((0xD800 <= val && val <= 0xDFFF) || + val == 0xFFFE || val == 0xFFFF) { + return 0; + } + dst[0] = 0xE0 | (val >> 12); + dst[1] = 0x80 | ((val >> 6) & 0x3F); + dst[2] = 0x80 | (val & 0x3F); + num_bits = 24; + } else if (val < 0x110000) { + dst[0] = 0xF0 | (val >> 18); + dst[1] = 0x80 | ((val >> 12) & 0x3F); + dst[2] = 0x80 | ((val >> 6) & 0x3F); + dst[3] = 0x80 | (val & 0x3F); + num_bits = 32; + } else { + return 0; + } + + if (bin_offset != 0) { + erts_copy_bits(dst, 0, 1, erts_current_bin, bin_offset, 1, num_bits); + } + + erts_bin_offset += num_bits; + + return 1; +} + +int +erts_bs_put_utf16(ERL_BITS_PROTO_2(Eterm arg, Uint flags)) +{ + Uint bin_offset = erts_bin_offset; + Uint bit_offset; + Uint num_bits; + byte tmp_buf[4]; + byte* dst; + Uint val; + + if (is_not_small(arg)) { + return 0; + } + val = unsigned_val(arg); + if (val > 0x10FFFF || (0xD800 <= val && val <= 0xDFFF) || + val == 0xFFFE || val == 0xFFFF) { + return 0; + } + + if ((bit_offset = BIT_OFFSET(bin_offset)) == 0) { + /* We can write directly into the destination binary. */ + dst = erts_current_bin+BYTE_OFFSET(bin_offset); + } else { + /* Unaligned destination binary. Must use a temporary buffer. */ + dst = tmp_buf; + } + + if (val < 0x10000UL) { + num_bits = 16; + if (flags & BSF_LITTLE) { + dst[0] = val; + dst[1] = val >> 8; + } else { + dst[0] = val >> 8; + dst[1] = val; + } + } else { + Uint16 w1, w2; + + num_bits = 32; + val = val - 0x10000UL; + w1 = 0xD800 | (val >> 10); + w2 = 0xDC00 | (val & 0x3FF); + if (flags & BSF_LITTLE) { + dst[0] = w1; + dst[1] = w1 >> 8; + dst[2] = w2; + dst[3] = w2 >> 8; + } else { + dst[0] = w1 >> 8; + dst[1] = w1; + dst[2] = w2 >> 8; + dst[3] = w2; + } + } + + if (bin_offset != 0) { + erts_copy_bits(dst, 0, 1, erts_current_bin, bin_offset, 1, num_bits); + } + + erts_bin_offset += num_bits; + return 1; +} + + +int +erts_new_bs_put_binary(ERL_BITS_PROTO_2(Eterm arg, Uint num_bits)) +{ + byte *bptr; + Uint bitoffs; + Uint bitsize; + + if (!is_binary(arg)) { + return 0; + } + ERTS_GET_BINARY_BYTES(arg, bptr, bitoffs, bitsize); + if (num_bits > 8*binary_size(arg)+bitsize) { + return 0; + } + copy_binary_to_buffer(erts_current_bin, erts_bin_offset, bptr, bitoffs, num_bits); + erts_bin_offset += num_bits; + return 1; +} + +int +erts_new_bs_put_binary_all(ERL_BITS_PROTO_2(Eterm arg, Uint unit)) +{ + byte *bptr; + Uint bitoffs; + Uint bitsize; + Uint num_bits; + + /* + * This type test is not needed if the code was compiled with + * an R12B or later compiler, since there would have been a + * call to bit_size/1 or byte_size/1 that would have failed if + * 'arg' was not a binary. However, in R11B and earlier releases, + * size/1 was use for calculating the size of the binary, and + * therefore 'arg' could be a tuple. + */ + if (!is_binary(arg)) { + return 0; + } + + ERTS_GET_BINARY_BYTES(arg, bptr, bitoffs, bitsize); + num_bits = 8*binary_size(arg)+bitsize; + if (unit == 8) { + if (bitsize != 0) { + return 0; + } + } else if (unit != 1 && num_bits % unit != 0) { + return 0; + } + copy_binary_to_buffer(erts_current_bin, erts_bin_offset, bptr, bitoffs, num_bits); + erts_bin_offset += num_bits; + return 1; +} + +int +erts_new_bs_put_float(Process *c_p, Eterm arg, Uint num_bits, int flags) +{ + ERL_BITS_DEFINE_STATEP(c_p); + + if (BIT_OFFSET(erts_bin_offset) == 0) { + Uint32 a; + Uint32 b; + + if (num_bits == 64) { + union { + double f64; + Uint32 i32[2]; + } u; + + if (is_float(arg)) { + FloatDef *fdp = (FloatDef*)(float_val(arg) + 1); + a = fdp->fw[0]; + b = fdp->fw[1]; + } else if (is_small(arg)) { + u.f64 = (double) signed_val(arg); + a = u.i32[0]; + b = u.i32[1]; + } else if (is_big(arg)) { + if (big_to_double(arg, &u.f64) < 0) { + return 0; + } + a = u.i32[0]; + b = u.i32[1]; + } else { + return 0; + } + } else if (num_bits == 32) { + union { + float f32; + Uint32 i32; + } u; + + b = 0; + if (is_float(arg)) { + FloatDef f; + GET_DOUBLE(arg, f); + ERTS_FP_CHECK_INIT(c_p); + u.f32 = f.fd; + ERTS_FP_ERROR(c_p,u.f32,;); + a = u.i32; + } else if (is_small(arg)) { + u.f32 = (float) signed_val(arg); + a = u.i32; + } else if (is_big(arg)) { + double f64; + if (big_to_double(arg, &f64) < 0) { + return 0; + } + ERTS_FP_CHECK_INIT(c_p); + u.f32 = (float) f64; + ERTS_FP_ERROR(c_p,u.f32,;); + a = u.i32; + } else { + return 0; + } + } else { + return 0; + } + + if (BIT_IS_MACHINE_ENDIAN(flags)) { + byte* t = erts_current_bin+BYTE_OFFSET(erts_bin_offset); +#ifdef WORDS_BIGENDIAN + t[0] = a >> 24; + t[1] = a >> 16; + t[2] = a >> 8; + t[3] = a; + if (num_bits == 64) { + t[4] = b >> 24; + t[5] = b >> 16; + t[6] = b >> 8; + t[7] = b; + } +#else + t[3] = a >> 24; + t[2] = a >> 16; + t[1] = a >> 8; + t[0] = a; + if (num_bits == 64) { + t[7] = b >> 24; + t[6] = b >> 16; + t[5] = b >> 8; + t[4] = b; + } +#endif + } else { + byte* t = erts_current_bin+BYTE_OFFSET(erts_bin_offset) + NBYTES(num_bits); +#ifdef WORDS_BIGENDIAN + t[-1] = a >> 24; + t[-2] = a >> 16; + t[-3] = a >> 8; + t[-4] = a; + if (num_bits == 64) { + t[-5] = b >> 24; + t[-6] = b >> 16; + t[-7] = b >> 8; + t[-8] = b; + } +#else + t[-1] = a; + t[-2] = a >> 8; + t[-3] = a >> 16; + t[-4] = a >> 24; + if (num_bits == 64) { + t[-5] = b; + t[-6] = b >> 8; + t[-7] = b >> 16; + t[-8] = b >> 24; + } +#endif + } + } else { + byte *bptr; + double f64; + float f32; + + if (num_bits == 64) { + if (is_float(arg)) { + bptr = (byte *) (float_val(arg) + 1); + } else if (is_small(arg)) { + f64 = (double) signed_val(arg); + bptr = (byte *) &f64; + } else if (is_big(arg)) { + if (big_to_double(arg, &f64) < 0) { + return 0; + } + bptr = (byte *) &f64; + } else { + return 0; + } + } else if (num_bits == 32) { + if (is_float(arg)) { + FloatDef f; + GET_DOUBLE(arg, f); + ERTS_FP_CHECK_INIT(c_p); + f32 = f.fd; + ERTS_FP_ERROR(c_p,f32,;); + bptr = (byte *) &f32; + } else if (is_small(arg)) { + f32 = (float) signed_val(arg); + bptr = (byte *) &f32; + } else if (is_big(arg)) { + if (big_to_double(arg, &f64) < 0) { + return 0; + } + ERTS_FP_CHECK_INIT(c_p); + f32 = (float) f64; + ERTS_FP_ERROR(c_p,f32,;); + bptr = (byte *) &f32; + } else { + return 0; + } + } else { + return 0; + } + if (BIT_IS_MACHINE_ENDIAN(flags)) { + erts_copy_bits(bptr, 0, 1, + erts_current_bin, + erts_bin_offset, 1, num_bits); + } else { + erts_copy_bits(bptr+NBYTES(num_bits)-1, 0, -1, + erts_current_bin, erts_bin_offset, 1, + num_bits); + } + } + erts_bin_offset += num_bits; + return 1; +} + +void +erts_new_bs_put_string(ERL_BITS_PROTO_2(byte* iptr, Uint num_bytes)) +{ + if (BIT_OFFSET(erts_bin_offset) != 0) { + erts_copy_bits(iptr, 0, 1, erts_current_bin, erts_bin_offset, 1, num_bytes*8); + } else { + sys_memcpy(erts_current_bin+BYTE_OFFSET(erts_bin_offset), iptr, num_bytes); + } + erts_bin_offset += num_bytes*8; +} + +Eterm +erts_bs_append(Process* c_p, Eterm* reg, Uint live, Eterm build_size_term, + Uint extra_words, Uint unit) +{ + Eterm bin; /* Given binary */ + Eterm* ptr; + Eterm hdr; + ErlSubBin* sb; + ProcBin* pb; + Binary* binp; + Uint heap_need; + Uint build_size_in_bits; + Uint used_size_in_bits; + Uint unsigned_bits; + ERL_BITS_DEFINE_STATEP(c_p); + + /* + * Check and untag the requested build size. + */ + if (is_small(build_size_term)) { + Sint signed_bits = signed_val(build_size_term); + if (signed_bits < 0) { + goto badarg; + } + build_size_in_bits = (Uint) signed_bits; + } else if (term_to_Uint(build_size_term, &unsigned_bits)) { + build_size_in_bits = unsigned_bits; + } else { + c_p->freason = unsigned_bits; + return THE_NON_VALUE; + } + + /* + * Check the binary argument. + */ + bin = reg[live]; + if (!is_boxed(bin)) { + badarg: + c_p->freason = BADARG; + return THE_NON_VALUE; + } + ptr = boxed_val(bin); + hdr = *ptr; + if (!is_binary_header(hdr)) { + goto badarg; + } + if (hdr != HEADER_SUB_BIN) { + goto not_writable; + } + sb = (ErlSubBin *) ptr; + if (!sb->is_writable) { + goto not_writable; + } + pb = (ProcBin *) boxed_val(sb->orig); + ASSERT(pb->thing_word == HEADER_PROC_BIN); + if ((pb->flags & PB_IS_WRITABLE) == 0) { + goto not_writable; + } + + /* + * OK, the binary is writable. + */ + + erts_bin_offset = 8*sb->size + sb->bitsize; + used_size_in_bits = erts_bin_offset + build_size_in_bits; + sb->is_writable = 0; /* Make sure that no one else can write. */ + pb->size = NBYTES(used_size_in_bits); + pb->flags |= PB_ACTIVE_WRITER; + + /* + * Reallocate the binary if it is too small. + */ + binp = pb->val; + if (binp->orig_size < pb->size) { + Uint new_size = 2*pb->size; + binp = erts_bin_realloc(binp, new_size); + binp->orig_size = new_size; + pb->val = binp; + pb->bytes = (byte *) binp->orig_bytes; + } + erts_current_bin = pb->bytes; + + /* + * Allocate heap space and build a new sub binary. + */ + reg[live] = sb->orig; + heap_need = ERL_SUB_BIN_SIZE + extra_words; + if (c_p->stop - c_p->htop < heap_need) { + (void) erts_garbage_collect(c_p, heap_need, reg, live+1); + } + sb = (ErlSubBin *) c_p->htop; + c_p->htop += ERL_SUB_BIN_SIZE; + sb->thing_word = HEADER_SUB_BIN; + sb->size = BYTE_OFFSET(used_size_in_bits); + sb->bitsize = BIT_OFFSET(used_size_in_bits); + sb->offs = 0; + sb->bitoffs = 0; + sb->is_writable = 1; + sb->orig = reg[live]; + + return make_binary(sb); + + /* + * The binary is not writable. We must create a new writable binary and + * copy the old contents of the binary. + */ + not_writable: + { + Uint used_size_in_bytes; /* Size of old binary + data to be built */ + Uint bin_size; + Binary* bptr; + byte* src_bytes; + Uint bitoffs; + Uint bitsize; + Eterm* hp; + + /* + * Allocate heap space. + */ + heap_need = PROC_BIN_SIZE + ERL_SUB_BIN_SIZE + extra_words; + if (c_p->stop - c_p->htop < heap_need) { + (void) erts_garbage_collect(c_p, heap_need, reg, live+1); + bin = reg[live]; + } + hp = c_p->htop; + + /* + * Calculate sizes. The size of the new binary, is the sum of the + * build size and the size of the old binary. Allow some room + * for growing. + */ + ERTS_GET_BINARY_BYTES(bin, src_bytes, bitoffs, bitsize); + erts_bin_offset = 8*binary_size(bin) + bitsize; + used_size_in_bits = erts_bin_offset + build_size_in_bits; + used_size_in_bytes = NBYTES(used_size_in_bits); + bin_size = 2*used_size_in_bytes; + bin_size = (bin_size < 256) ? 256 : bin_size; + + /* + * Allocate the binary data struct itself. + */ + bptr = erts_bin_nrml_alloc(bin_size); + bptr->flags = 0; + bptr->orig_size = bin_size; + erts_refc_init(&bptr->refc, 1); + erts_current_bin = (byte *) bptr->orig_bytes; + + /* + * Now allocate the ProcBin on the heap. + */ + pb = (ProcBin *) hp; + hp += PROC_BIN_SIZE; + pb->thing_word = HEADER_PROC_BIN; + pb->size = used_size_in_bytes; + pb->next = MSO(c_p).mso; + MSO(c_p).mso = pb; + pb->val = bptr; + pb->bytes = (byte*) bptr->orig_bytes; + pb->flags = PB_IS_WRITABLE | PB_ACTIVE_WRITER; + MSO(c_p).overhead += pb->size / sizeof(Eterm); + + /* + * Now allocate the sub binary and set its size to include the + * data about to be built. + */ + sb = (ErlSubBin *) hp; + hp += ERL_SUB_BIN_SIZE; + sb->thing_word = HEADER_SUB_BIN; + sb->size = BYTE_OFFSET(used_size_in_bits); + sb->bitsize = BIT_OFFSET(used_size_in_bits); + sb->offs = 0; + sb->bitoffs = 0; + sb->is_writable = 1; + sb->orig = make_binary(pb); + + c_p->htop = hp; + + /* + * Now copy the data into the binary. + */ + if (unit > 1) { + if ((unit == 8 && (erts_bin_offset & 7) != 0) || + (erts_bin_offset % unit) != 0) { + return THE_NON_VALUE; + } + } + copy_binary_to_buffer(erts_current_bin, 0, src_bytes, bitoffs, erts_bin_offset); + + return make_binary(sb); + } +} + +Eterm +erts_bs_private_append(Process* p, Eterm bin, Eterm build_size_term, Uint unit) +{ + Eterm* ptr; + ErlSubBin* sb; + ProcBin* pb; + Binary* binp; + Uint build_size_in_bits; + Uint pos_in_bits_after_build; + Uint unsigned_bits; + ERL_BITS_DEFINE_STATEP(p); + + /* + * Check and untag the requested build size. + */ + if (is_small(build_size_term)) { + Sint signed_bits = signed_val(build_size_term); + if (signed_bits < 0) { + p->freason = BADARG; + return THE_NON_VALUE; + } + build_size_in_bits = (Uint) signed_bits; + } else if (term_to_Uint(build_size_term, &unsigned_bits)) { + build_size_in_bits = unsigned_bits; + } else { + p->freason = unsigned_bits; + return THE_NON_VALUE; + } + + ptr = boxed_val(bin); + ASSERT(*ptr == HEADER_SUB_BIN); + + sb = (ErlSubBin *) ptr; + ASSERT(sb->is_writable); + + pb = (ProcBin *) boxed_val(sb->orig); + ASSERT(pb->thing_word == HEADER_PROC_BIN); + + /* + * Calculate new size in bytes. + */ + erts_bin_offset = 8*sb->size + sb->bitsize; + pos_in_bits_after_build = erts_bin_offset + build_size_in_bits; + pb->size = (pos_in_bits_after_build+7) >> 3; + pb->flags |= PB_ACTIVE_WRITER; + + /* + * Reallocate the binary if it is too small. + */ + binp = pb->val; + if (binp->orig_size < pb->size) { + Uint new_size = 2*pb->size; + + if (pb->flags & PB_IS_WRITABLE) { + /* + * This is the normal case - the binary is writable. + * There are no other references to the binary, so it + * is safe to reallocate it. + */ + binp = erts_bin_realloc(binp, new_size); + binp->orig_size = new_size; + pb->val = binp; + pb->bytes = (byte *) binp->orig_bytes; + } else { + /* + * The binary is NOT writable. The only way that is + * supposed to happen if is call trace has been turned + * on. That means that a trace process now has (or have + * had) a reference to the binary, so we are not allowed + * to reallocate the binary. Instead, we must allocate a new + * binary and copy the contents of the old binary into it. + */ + Binary* bptr = erts_bin_nrml_alloc(new_size); + bptr->flags = 0; + bptr->orig_size = new_size; + erts_refc_init(&bptr->refc, 1); + sys_memcpy(bptr->orig_bytes, binp->orig_bytes, pb->size); + pb->flags |= PB_IS_WRITABLE | PB_ACTIVE_WRITER; + pb->val = bptr; + pb->bytes = (byte *) bptr->orig_bytes; + if (erts_refc_dectest(&binp->refc, 0) == 0) { + erts_bin_free(binp); + } + } + } + erts_current_bin = pb->bytes; + + sb->size = pos_in_bits_after_build >> 3; + sb->bitsize = pos_in_bits_after_build & 7; + return bin; +} + +Eterm +erts_bs_init_writable(Process* p, Eterm sz) +{ + Uint bin_size = 1024; + Uint heap_need; + Binary* bptr; + ProcBin* pb; + ErlSubBin* sb; + Eterm* hp; + + if (is_small(sz)) { + Sint s = signed_val(sz); + if (s >= 0) { + bin_size = (Uint) s; + } + } + + /* + * Allocate heap space. + */ + heap_need = PROC_BIN_SIZE + ERL_SUB_BIN_SIZE; + if (p->stop - p->htop < heap_need) { + (void) erts_garbage_collect(p, heap_need, NULL, 0); + } + hp = p->htop; + + /* + * Allocate the binary data struct itself. + */ + bptr = erts_bin_nrml_alloc(bin_size); + bptr->flags = 0; + bptr->orig_size = bin_size; + erts_refc_init(&bptr->refc, 1); + + /* + * Now allocate the ProcBin on the heap. + */ + pb = (ProcBin *) hp; + hp += PROC_BIN_SIZE; + pb->thing_word = HEADER_PROC_BIN; + pb->size = 0; + pb->next = MSO(p).mso; + MSO(p).mso = pb; + pb->val = bptr; + pb->bytes = (byte*) bptr->orig_bytes; + pb->flags = PB_IS_WRITABLE | PB_ACTIVE_WRITER; + MSO(p).overhead += pb->size / sizeof(Eterm); + + /* + * Now allocate the sub binary. + */ + sb = (ErlSubBin *) hp; + hp += ERL_SUB_BIN_SIZE; + sb->thing_word = HEADER_SUB_BIN; + sb->size = 0; + sb->offs = 0; + sb->bitsize = 0; + sb->bitoffs = 0; + sb->is_writable = 1; + sb->orig = make_binary(pb); + + p->htop = hp; + return make_binary(sb); +} + +void +erts_emasculate_writable_binary(ProcBin* pb) +{ + Binary* binp; + Uint unused; + + pb->flags = 0; + binp = pb->val; + ASSERT(binp->orig_size >= pb->size); + unused = binp->orig_size - pb->size; + /* Our allocators are 8 byte aligned, i.e., shrinking with + less than 8 bytes will have no real effect */ + if (unused >= 8) { + Uint new_size = pb->size; + binp = erts_bin_realloc(binp, pb->size); + binp->orig_size = new_size; + pb->val = binp; + pb->bytes = (byte *) binp->orig_bytes; + } +} + +Uint32 +erts_bs_get_unaligned_uint32(ErlBinMatchBuffer* mb) +{ + Uint bytes; + Uint bits; + Uint offs; + byte bigbuf[4]; + byte* LSB; + byte* MSB; + + ASSERT((mb->offset & 7) != 0); + ASSERT(mb->size - mb->offset >= 32); + + bytes = 4; + bits = 8; + offs = 0; + + LSB = bigbuf; + MSB = LSB + bytes - 1; + + *MSB = 0; + erts_copy_bits(mb->base, mb->offset, 1, MSB, offs, -1, 32); + return LSB[0] | (LSB[1]<<8) | (LSB[2]<<16) | (LSB[3]<<24); +} + +void +erts_align_utf8_bytes(ErlBinMatchBuffer* mb, byte* buf) +{ + Uint bits = mb->size - mb->offset; + + /* + * Copy up to 4 bytes into the supplied buffer. + */ + + ASSERT(bits >= 8); + if (bits <= 15) { + bits = 8; + } else if (bits >= 32) { + bits = 32; + } else if (bits >= 24) { + bits = 24; + } else { + bits = 16; + } + erts_copy_bits(mb->base, mb->offset, 1, buf, 0, 1, bits); +} + +Eterm +erts_bs_get_utf8(ErlBinMatchBuffer* mb) +{ + Eterm result; + Uint remaining_bits; + byte* pos; + byte tmp_buf[4]; + Eterm a, b, c; + + /* + * Number of trailing bytes for each value of the first byte. + */ + static const byte erts_trailing_bytes_for_utf8[256] = { + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9, 9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9, + 9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9, 9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9, + 9,9,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, + 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 3,3,3,3,3,3,3,3,9,9,9,9,9,9,9,9 + }; + + if ((remaining_bits = mb->size - mb->offset) < 8) { + return THE_NON_VALUE; + } + if (BIT_OFFSET(mb->offset) == 0) { + pos = mb->base + BYTE_OFFSET(mb->offset); + } else { + erts_align_utf8_bytes(mb, tmp_buf); + pos = tmp_buf; + } + result = pos[0]; + switch (erts_trailing_bytes_for_utf8[result]) { + case 0: + /* One byte only */ + mb->offset += 8; + break; + case 1: + /* Two bytes */ + if (remaining_bits < 16) { + return THE_NON_VALUE; + } + a = pos[1]; + if ((a & 0xC0) != 0x80) { + return THE_NON_VALUE; + } + result = (result << 6) + a - (Eterm) 0x00003080UL; + mb->offset += 16; + break; + case 2: + /* Three bytes */ + if (remaining_bits < 24) { + return THE_NON_VALUE; + } + a = pos[1]; + b = pos[2]; + if ((a & 0xC0) != 0x80 || (b & 0xC0) != 0x80 || + (result == 0xE0 && a < 0xA0)) { + return THE_NON_VALUE; + } + result = (((result << 6) + a) << 6) + b - (Eterm) 0x000E2080UL; + if ((0xD800 <= result && result <= 0xDFFF) || + result == 0xFFFE || result == 0xFFFF) { + return THE_NON_VALUE; + } + mb->offset += 24; + break; + case 3: + /* Four bytes */ + if (remaining_bits < 32) { + return THE_NON_VALUE; + } + a = pos[1]; + b = pos[2]; + c = pos[3]; + if ((a & 0xC0) != 0x80 || (b & 0xC0) != 0x80 || + (c & 0xC0) != 0x80 || + (result == 0xF0 && a < 0x90)) { + return THE_NON_VALUE; + } + result = (((((result << 6) + a) << 6) + b) << 6) + + c - (Eterm) 0x03C82080UL; + if (result > 0x10FFFF) { + return THE_NON_VALUE; + } + mb->offset += 32; + break; + default: + return THE_NON_VALUE; + } + return make_small(result); +} + +Eterm +erts_bs_get_utf16(ErlBinMatchBuffer* mb, Uint flags) +{ + Uint bit_offset; + Uint num_bits = mb->size - mb->offset; + byte* src; + byte tmp_buf[4]; + Uint16 w1; + Uint16 w2; + + if (num_bits < 16) { + return THE_NON_VALUE; + } + + /* + * Set up the pointer to the source bytes. + */ + if ((bit_offset = BIT_OFFSET(mb->offset)) == 0) { + /* We can access the binary directly because the bytes are aligned. */ + src = mb->base + BYTE_OFFSET(mb->offset); + } else { + /* + * We must copy the data to a temporary buffer. If possible, + * get 4 bytes, otherwise two bytes. + */ + Uint n = num_bits < 32 ? 16 : 32; + erts_copy_bits(mb->base, mb->offset, 1, tmp_buf, 0, 1, n); + src = tmp_buf; + } + + /* + * Get the first (and maybe only) 16-bit word. See if we are done. + */ + if (flags & BSF_LITTLE) { + w1 = src[0] | (src[1] << 8); + } else { + w1 = (src[0] << 8) | src[1]; + } + if (w1 < 0xD800 || w1 > 0xDFFF) { + if (w1 == 0xFFFE || w1 == 0xFFFF) { + return THE_NON_VALUE; + } + mb->offset += 16; + return make_small(w1); + } else if (w1 > 0xDBFF) { + return THE_NON_VALUE; + } + + /* + * Get the second 16-bit word and combine it with the first. + */ + if (num_bits < 32) { + return THE_NON_VALUE; + } else if (flags & BSF_LITTLE) { + w2 = src[2] | (src[3] << 8); + } else { + w2 = (src[2] << 8) | src[3]; + } + if (!(0xDC00 <= w2 && w2 <= 0xDFFF)) { + return THE_NON_VALUE; + } + mb->offset += 32; + return make_small((((w1 & 0x3FF) << 10) | (w2 & 0x3FF)) + 0x10000UL); +} + +static byte +get_bit(byte b, size_t offs) +{ + return (b >> (7-offs)) & 1; +} + +int +erts_cmp_bits(byte* a_ptr, size_t a_offs, byte* b_ptr, size_t b_offs, size_t size) +{ + byte a; + byte b; + byte a_bit; + byte b_bit; + Uint lshift; + Uint rshift; + int cmp; + + if (((a_offs | b_offs | size) & 7) == 0) { + int byte_size = size >> 3; + return sys_memcmp(a_ptr, b_ptr, byte_size); + } + + /* Compare bit by bit until a_ptr is aligned on byte boundary */ + a = *a_ptr++; + b = *b_ptr++; + while (size > 0) { + a_bit = get_bit(a, a_offs); + b_bit = get_bit(b, b_offs); + if ((cmp = (a_bit-b_bit)) != 0) { + return cmp; + } + size--; + b_offs++; + if (b_offs == 8) { + b_offs = 0; + b = *b_ptr++; + } + a_offs++; + if (a_offs == 8) { + a_offs = 0; + a = *a_ptr++; + break; + } + } + + /* Compare byte by byte as long as at least 8 bits remain */ + lshift = b_offs; + rshift = 8 - lshift; + while (size >= 8) { + byte b_cmp = (b << lshift); + b = *b_ptr++; + b_cmp |= b >> rshift; + if ((cmp = (a - b_cmp)) != 0) { + return cmp; + } + a = *a_ptr++; + size -= 8; + } + + /* Compare the remaining bits bit by bit */ + while (size > 0) { + a_bit = get_bit(a, a_offs); + b_bit = get_bit(b, b_offs); + if ((cmp = (a_bit-b_bit)) != 0) { + return cmp; + } + a_offs++; + if (a_offs == 8) { + a_offs = 0; + a = *a_ptr++; + } + b_offs++; + if (b_offs == 8) { + b_offs = 0; + b = *b_ptr++; + } + size--; + } + + return 0; +} + +/* + * The basic bit copy operation. Copies n bits from the source buffer to + * the destination buffer. Depending on the directions, it can reverse the + * copied bits. + */ + + +void +erts_copy_bits(byte* src, /* Base pointer to source. */ + size_t soffs, /* Bit offset for source relative to src. */ + int sdir, /* Direction: 1 (forward) or -1 (backward). */ + byte* dst, /* Base pointer to destination. */ + size_t doffs, /* Bit offset for destination relative to dst. */ + int ddir, /* Direction: 1 (forward) or -1 (backward). */ + size_t n) /* Number of bits to copy. */ +{ + Uint lmask; + Uint rmask; + Uint count; + Uint deoffs; + + if (n == 0) { + return; + } + + src += sdir*BYTE_OFFSET(soffs); + dst += ddir*BYTE_OFFSET(doffs); + soffs = BIT_OFFSET(soffs); + doffs = BIT_OFFSET(doffs); + deoffs = BIT_OFFSET(doffs+n); + lmask = (doffs) ? MAKE_MASK(8-doffs) : 0; + rmask = (deoffs) ? (MAKE_MASK(deoffs)<<(8-deoffs)) : 0; + + /* + * Take care of the case that all bits are in the same byte. + */ + + if (doffs+n < 8) { /* All bits are in the same byte */ + lmask = (lmask & rmask) ? (lmask & rmask) : (lmask | rmask); + + if (soffs == doffs) { + *dst = MASK_BITS(*src,*dst,lmask); + } else if (soffs > doffs) { + Uint bits = (*src << (soffs-doffs)); + if (soffs+n > 8) { + src += sdir; + bits |= (*src >> (8-(soffs-doffs))); + } + *dst = MASK_BITS(bits,*dst,lmask); + } else { + *dst = MASK_BITS((*src >> (doffs-soffs)),*dst,lmask); + } + return; /* We are done! */ + } + + /* + * At this point, we know that the bits are in 2 or more bytes. + */ + + count = ((lmask) ? (n - (8 - doffs)) : n) >> 3; + + if (soffs == doffs) { + /* + * The bits are aligned in the same way. We can just copy the bytes + * (except for the first and last bytes). Note that the directions + * might be different, so we can't just use memcpy(). + */ + + if (lmask) { + *dst = MASK_BITS(*src, *dst, lmask); + dst += ddir; + src += sdir; + } + + while (count--) { + *dst = *src; + dst += ddir; + src += sdir; + } + + if (rmask) { + *dst = MASK_BITS(*src,*dst,rmask); + } + } else { + Uint bits; + Uint bits1; + Uint rshift; + Uint lshift; + + /* + * The tricky case. The bits must be shifted into position. + */ + + if (soffs > doffs) { + lshift = (soffs - doffs); + rshift = 8 - lshift; + bits = *src; + if (soffs + n > 8) { + src += sdir; + } + } else { + rshift = (doffs - soffs); + lshift = 8 - rshift; + bits = 0; + } + + if (lmask) { + bits1 = bits << lshift; + bits = *src; + src += sdir; + bits1 |= (bits >> rshift); + *dst = MASK_BITS(bits1,*dst,lmask); + dst += ddir; + } + + while (count--) { + bits1 = bits << lshift; + bits = *src; + src += sdir; + *dst = bits1 | (bits >> rshift); + dst += ddir; + } + + if (rmask) { + bits1 = bits << lshift; + if ((rmask << rshift) & 0xff) { + bits = *src; + bits1 |= (bits >> rshift); + } + *dst = MASK_BITS(bits1,*dst,rmask); + } + } +} + diff --git a/erts/emulator/beam/erl_bits.h b/erts/emulator/beam/erl_bits.h new file mode 100644 index 0000000000..e3f8e0b679 --- /dev/null +++ b/erts/emulator/beam/erl_bits.h @@ -0,0 +1,212 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1999-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifndef __ERL_BITS_H__ +#define __ERL_BITS_H__ + +/* + * This structure represents a binary to be matched. + */ + +typedef struct erl_bin_match_buffer { + Eterm orig; /* Original binary term. */ + byte* base; /* Current position in binary. */ + Uint offset; /* Offset in bits. */ + size_t size; /* Size of binary in bits. */ +} ErlBinMatchBuffer; + +struct erl_bits_state { + /* + * Used for building binaries. + */ + byte *byte_buf_; + int byte_buf_len_; + /* + * Used for building binaries using the new instruction set. + */ + byte* erts_current_bin_; /* Pointer to beginning of current binary. */ + /* + * Offset in bits into the current binary (new instruction set) or + * buffer (old instruction set). + */ + Uint erts_bin_offset_; + /* + * Whether the current binary is writable. + */ + unsigned erts_writable_bin_; +}; + +typedef struct erl_bin_match_struct{ + Eterm thing_word; + ErlBinMatchBuffer mb; /* Present match buffer */ + Eterm save_offset[1]; /* Saved offsets */ +} ErlBinMatchState; + +#define ERL_BIN_MATCHSTATE_SIZE(_Max) ((sizeof(ErlBinMatchState) + (_Max)*sizeof(Eterm))/sizeof(Eterm)) +#define HEADER_BIN_MATCHSTATE(_Max) _make_header(ERL_BIN_MATCHSTATE_SIZE((_Max))-1, _TAG_HEADER_BIN_MATCHSTATE) +#define HEADER_NUM_SLOTS(hdr) (header_arity(hdr)-sizeof(ErlBinMatchState)/sizeof(Eterm)+1) + +#define make_matchstate(_Ms) make_boxed((Eterm*)(_Ms)) +#define ms_matchbuffer(_Ms) &(((ErlBinMatchState*)(_Ms - TAG_PRIMARY_BOXED))->mb) + + +#if defined(ERTS_SMP) +#define ERL_BITS_REENTRANT +#else +/* uncomment to test the reentrant API in the non-SMP runtime system */ +/* #define ERL_BITS_REENTRANT */ +#endif + +#ifdef ERL_BITS_REENTRANT + +/* + * Reentrant API with the state passed as a parameter. + * (Except when the current Process* already is a parameter.) + */ +#ifdef ERTS_SMP +/* the state resides in the current process' scheduler data */ +#define ERL_BITS_DECLARE_STATEP struct erl_bits_state *EBS +#define ERL_BITS_RELOAD_STATEP(P) do{EBS = &(P)->scheduler_data->erl_bits_state;}while(0) +#define ERL_BITS_DEFINE_STATEP(P) struct erl_bits_state *EBS = &(P)->scheduler_data->erl_bits_state +#else +/* reentrant API but with a hidden single global state, for testing only */ +extern struct erl_bits_state ErlBitsState_; +#define ERL_BITS_DECLARE_STATEP struct erl_bits_state *EBS = &ErlBitsState_ +#define ERL_BITS_RELOAD_STATEP(P) do{}while(0) +#define ERL_BITS_DEFINE_STATEP(P) ERL_BITS_DECLARE_STATEP +#endif +#define ErlBitsState (*EBS) + +#define ERL_BITS_PROTO_0 struct erl_bits_state *EBS +#define ERL_BITS_PROTO_1(PARM1) struct erl_bits_state *EBS, PARM1 +#define ERL_BITS_PROTO_2(PARM1,PARM2) struct erl_bits_state *EBS, PARM1, PARM2 +#define ERL_BITS_PROTO_3(PARM1,PARM2,PARM3) struct erl_bits_state *EBS, PARM1, PARM2, PARM3 +#define ERL_BITS_ARGS_0 EBS +#define ERL_BITS_ARGS_1(ARG1) EBS, ARG1 +#define ERL_BITS_ARGS_2(ARG1,ARG2) EBS, ARG1, ARG2 +#define ERL_BITS_ARGS_3(ARG1,ARG2,ARG3) EBS, ARG1, ARG2, ARG3 + +#else /* ERL_BITS_REENTRANT */ + +/* + * Non-reentrant API with a single global state. + */ +extern struct erl_bits_state ErlBitsState; +#define ERL_BITS_DECLARE_STATEP /*empty*/ +#define ERL_BITS_RELOAD_STATEP(P) do{}while(0) +#define ERL_BITS_DEFINE_STATEP(P) /*empty*/ + +#define ERL_BITS_PROTO_0 void +#define ERL_BITS_PROTO_1(PARM1) PARM1 +#define ERL_BITS_PROTO_2(PARM1,PARM2) PARM1, PARM2 +#define ERL_BITS_PROTO_3(PARM1,PARM2,PARM3) PARM1, PARM2, PARM3 +#define ERL_BITS_ARGS_0 /*empty*/ +#define ERL_BITS_ARGS_1(ARG1) ARG1 +#define ERL_BITS_ARGS_2(ARG1,ARG2) ARG1, ARG2 +#define ERL_BITS_ARGS_3(ARG1,ARG2,ARG3) ARG1, ARG2, ARG3 + +#endif /* ERL_BITS_REENTRANT */ + +#define erts_bin_offset (ErlBitsState.erts_bin_offset_) +#define erts_current_bin (ErlBitsState.erts_current_bin_) +#define erts_writable_bin (ErlBitsState.erts_writable_bin_) + +#define copy_binary_to_buffer(DstBuffer, DstBufOffset, SrcBuffer, SrcBufferOffset, NumBits) \ + do { \ + if (BIT_OFFSET(DstBufOffset) == 0 && (SrcBufferOffset == 0) && \ + (BIT_OFFSET(NumBits)==0)) { \ + sys_memcpy(DstBuffer+BYTE_OFFSET(DstBufOffset), \ + SrcBuffer, NBYTES(NumBits)); \ + } else { \ + erts_copy_bits(SrcBuffer, SrcBufferOffset, 1, \ + (byte*)DstBuffer, DstBufOffset, 1, NumBits); \ + } \ + } while (0) + +void erts_init_bits(void); /* Initialization once. */ +#ifdef ERTS_SMP +void erts_bits_init_state(ERL_BITS_PROTO_0); +void erts_bits_destroy_state(ERL_BITS_PROTO_0); +#endif + + +/* + * NBYTES(x) returns the number of bytes needed to store x bits. + */ + +#define NBYTES(x) (((x) + 7) >> 3) +#define BYTE_OFFSET(ofs) ((Uint) (ofs) >> 3) +#define BIT_OFFSET(ofs) ((ofs) & 7) + +/* + * Return number of Eterm words needed for allocation with HAlloc(), + * given a number of bytes. + */ +#define WSIZE(n) ((n + sizeof(Eterm) - 1) / sizeof(Eterm)) + +/* + * Binary matching. + */ + +Eterm erts_bs_start_match_2(Process *p, Eterm Bin, Uint Max); +Eterm erts_bs_get_integer_2(Process *p, Uint num_bits, unsigned flags, ErlBinMatchBuffer* mb); +Eterm erts_bs_get_binary_2(Process *p, Uint num_bits, unsigned flags, ErlBinMatchBuffer* mb); +Eterm erts_bs_get_float_2(Process *p, Uint num_bits, unsigned flags, ErlBinMatchBuffer* mb); +Eterm erts_bs_get_binary_all_2(Process *p, ErlBinMatchBuffer* mb); + +/* + * Binary construction, new instruction set. + */ + +int erts_new_bs_put_integer(ERL_BITS_PROTO_3(Eterm Integer, Uint num_bits, unsigned flags)); +int erts_bs_put_utf8(ERL_BITS_PROTO_1(Eterm Integer)); +int erts_bs_put_utf16(ERL_BITS_PROTO_2(Eterm Integer, Uint flags)); +int erts_new_bs_put_binary(ERL_BITS_PROTO_2(Eterm Bin, Uint num_bits)); +int erts_new_bs_put_binary_all(ERL_BITS_PROTO_2(Eterm Bin, Uint unit)); +int erts_new_bs_put_float(Process *c_p, Eterm Float, Uint num_bits, int flags); +void erts_new_bs_put_string(ERL_BITS_PROTO_2(byte* iptr, Uint num_bytes)); + +Uint erts_bits_bufs_size(void); +Uint32 erts_bs_get_unaligned_uint32(ErlBinMatchBuffer* mb); +void erts_align_utf8_bytes(ErlBinMatchBuffer* mb, byte* buf); +Eterm erts_bs_get_utf8(ErlBinMatchBuffer* mb); +Eterm erts_bs_get_utf16(ErlBinMatchBuffer* mb, Uint flags); +Eterm erts_bs_append(Process* p, Eterm* reg, Uint live, Eterm build_size_term, + Uint extra_words, Uint unit); +Eterm erts_bs_private_append(Process* p, Eterm bin, Eterm sz, Uint unit); +Eterm erts_bs_init_writable(Process* p, Eterm sz); + +/* + * Common utilities. + */ +void erts_copy_bits(byte* src, size_t soffs, int sdir, + byte* dst, size_t doffs,int ddir, size_t n); +int erts_cmp_bits(byte* a_ptr, size_t a_offs, byte* b_ptr, size_t b_offs, size_t size); + +/* + * Flags for bs_get_* / bs_put_* / bs_init* instructions. + */ + +#define BSF_ALIGNED 1 /* Field is guaranteed to be byte-aligned. */ +#define BSF_LITTLE 2 /* Field is little-endian (otherwise big-endian). */ +#define BSF_SIGNED 4 /* Field is signed (otherwise unsigned). */ +#define BSF_EXACT 8 /* Size in bs_init is exact. */ +#define BSF_NATIVE 16 /* Native endian. */ + +#endif /* __ERL_BITS_H__ */ diff --git a/erts/emulator/beam/erl_db.c b/erts/emulator/beam/erl_db.c new file mode 100644 index 0000000000..b02150008f --- /dev/null +++ b/erts/emulator/beam/erl_db.c @@ -0,0 +1,3631 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* + * This file contains the bif interface functions and + * the handling of the "meta tables" ie the tables of + * db tables. + */ + +/* +#ifdef DEBUG +#define HARDDEBUG 1 +#endif +*/ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "erl_process.h" +#include "error.h" +#define ERTS_WANT_DB_INTERNAL__ +#include "erl_db.h" +#include "bif.h" +#include "big.h" + + +erts_smp_atomic_t erts_ets_misc_mem_size; + +/* +** Utility macros +*/ + +/* Get a key from any table structure and a tagged object */ +#define TERM_GETKEY(tb, obj) db_getkey((tb)->common.keypos, (obj)) + + +/* How safe are we from double-hits or missed objects +** when iterating without fixation? */ +enum DbIterSafety { + ITER_UNSAFE, /* Must fixate to be safe */ + ITER_SAFE_LOCKED, /* Safe while table is locked, not between trap calls */ + ITER_SAFE /* No need to fixate at all */ +}; +#ifdef ERTS_SMP +# define ITERATION_SAFETY(Proc,Tab) \ + ((IS_TREE_TABLE((Tab)->common.status) || ONLY_WRITER(Proc,Tab)) ? ITER_SAFE \ + : (((Tab)->common.status & DB_FINE_LOCKED) ? ITER_UNSAFE : ITER_SAFE_LOCKED)) +#else +# define ITERATION_SAFETY(Proc,Tab) \ + ((IS_TREE_TABLE((Tab)->common.status) || ONLY_WRITER(Proc,Tab)) \ + ? ITER_SAFE : ITER_SAFE_LOCKED) +#endif + +#define DID_TRAP(P,Ret) (!is_value(Ret) && ((P)->freason == TRAP)) + + +/* +** The main meta table, containing all ets tables. +*/ +#ifdef ERTS_SMP +# define META_MAIN_TAB_LOCK_CNT 16 +static union { + erts_smp_spinlock_t lck; + byte _cache_line_alignment[64]; +}meta_main_tab_locks[META_MAIN_TAB_LOCK_CNT]; +#endif +static struct { + union { + DbTable *tb; /* Only directly readable if slot is ALIVE */ + Uint next_free; /* (index<<2)|1 if slot is FREE */ + }u; +} *meta_main_tab; + +/* A slot in meta_main_tab can have three states: + * FREE : Free to use for new table. Part of linked free-list. + * ALIVE: Contains a table + * DEAD : Contains a table that is being removed. + */ +#define IS_SLOT_FREE(i) (meta_main_tab[(i)].u.next_free & 1) +#define IS_SLOT_DEAD(i) (meta_main_tab[(i)].u.next_free & 2) +#define IS_SLOT_ALIVE(i) (!(meta_main_tab[(i)].u.next_free & (1|2))) +#define GET_NEXT_FREE_SLOT(i) (meta_main_tab[(i)].u.next_free >> 2) +#define SET_NEXT_FREE_SLOT(i,next) (meta_main_tab[(i)].u.next_free = ((next)<<2)|1) +#define MARK_SLOT_DEAD(i) (meta_main_tab[(i)].u.next_free |= 2) +#define GET_ANY_SLOT_TAB(i) ((DbTable*)(meta_main_tab[(i)].u.next_free & ~(1|2))) /* dead or alive */ + +static ERTS_INLINE void meta_main_tab_lock(unsigned slot) +{ +#ifdef ERTS_SMP + erts_smp_spin_lock(&meta_main_tab_locks[slot % META_MAIN_TAB_LOCK_CNT].lck); +#endif +} + +static ERTS_INLINE void meta_main_tab_unlock(unsigned slot) +{ +#ifdef ERTS_SMP + erts_smp_spin_unlock(&meta_main_tab_locks[slot % META_MAIN_TAB_LOCK_CNT].lck); +#endif +} + +static erts_smp_spinlock_t meta_main_tab_main_lock; +static Uint meta_main_tab_first_free; /* Index of first free slot */ +static int meta_main_tab_cnt; /* Number of active tables */ +static Uint meta_main_tab_slot_mask; /* The slot index part of an unnamed table id */ +static Uint meta_main_tab_seq_incr; +static Uint meta_main_tab_seq_cnt = 0; /* To give unique(-ish) table identifiers */ + + + +/* +** The meta hash table of all NAMED ets tables +*/ +#ifdef ERTS_SMP +# define META_NAME_TAB_LOCK_CNT 16 +union { + erts_smp_rwmtx_t lck; + byte _cache_line_alignment[64]; +}meta_name_tab_rwlocks[META_NAME_TAB_LOCK_CNT]; +#endif +static struct meta_name_tab_entry { + union { + Eterm name_atom; + Eterm mcnt; /* Length of mvec in multiple tab entry */ + }u; + union { + DbTable *tb; + struct meta_name_tab_entry* mvec; + }pu; +} *meta_name_tab; + +static unsigned meta_name_tab_mask; + +static ERTS_INLINE +struct meta_name_tab_entry* meta_name_tab_bucket(Eterm name, + erts_smp_rwmtx_t** lockp) +{ + unsigned bix = atom_val(name) & meta_name_tab_mask; + struct meta_name_tab_entry* bucket = &meta_name_tab[bix]; +#ifdef ERTS_SMP + *lockp = &meta_name_tab_rwlocks[bix % META_NAME_TAB_LOCK_CNT].lck; +#endif + return bucket; +} + + +typedef enum { + LCK_READ=1, /* read only access */ + LCK_WRITE=2, /* exclusive table write access */ + LCK_WRITE_REC=3 /* record write access */ +} db_lock_kind_t; + +extern DbTableMethod db_hash; +extern DbTableMethod db_tree; + +int user_requested_db_max_tabs; +int erts_ets_realloc_always_moves; +static int db_max_tabs; +static DbTable *meta_pid_to_tab; /* Pid mapped to owned tables */ +static DbTable *meta_pid_to_fixed_tab; /* Pid mapped to fixed tables */ +static Eterm ms_delete_all; +static Eterm ms_delete_all_buff[8]; /* To compare with for deletion + of all objects */ + +/* +** Forward decls, static functions +*/ + +static void fix_table_locked(Process* p, DbTable* tb); +static void unfix_table_locked(Process* p, DbTable* tb, db_lock_kind_t* kind); +static void set_heir(Process* me, DbTable* tb, Eterm heir, Eterm heir_data); +static void free_heir_data(DbTable*); +static void free_fixations_locked(DbTable *tb); + +static int free_table_cont(Process *p, + DbTable *tb, + int first, + int clean_meta_tab); +static void print_table(int to, void *to_arg, int show, DbTable* tb); +static BIF_RETTYPE ets_select_delete_1(Process *p, Eterm a1); +static BIF_RETTYPE ets_select_count_1(Process *p, Eterm a1); +static BIF_RETTYPE ets_select_trap_1(Process *p, Eterm a1); +static BIF_RETTYPE ets_delete_trap(Process *p, Eterm a1); +static Eterm table_info(Process* p, DbTable* tb, Eterm What); + +/* + * Exported global + */ +Export ets_select_delete_continue_exp; +Export ets_select_count_continue_exp; +Export ets_select_continue_exp; + +/* + * Static traps + */ +static Export ets_delete_continue_exp; + +static ERTS_INLINE DbTable* db_ref(DbTable* tb) +{ + if (tb != NULL) { + erts_refc_inc(&tb->common.ref, 2); + } + return tb; +} + +static ERTS_INLINE DbTable* db_unref(DbTable* tb) +{ + if (!erts_refc_dectest(&tb->common.ref, 0)) { +#ifdef HARDDEBUG + if (erts_smp_atomic_read(&tb->common.memory_size) != sizeof(DbTable)) { + erts_fprintf(stderr, "ets: db_unref memory remain=%ld fix=%x\n", + erts_smp_atomic_read(&tb->common.memory_size)-sizeof(DbTable), + tb->common.fixations); + } + erts_fprintf(stderr, "ets: db_unref(%T) deleted!!!\r\n", + tb->common.id); + + erts_fprintf(stderr, "ets: db_unref: meta_pid_to_tab common.memory_size = %ld\n", + erts_smp_atomic_read(&meta_pid_to_tab->common.memory_size)); + print_table(ERTS_PRINT_STDOUT, NULL, 1, meta_pid_to_tab); + + + erts_fprintf(stderr, "ets: db_unref: meta_pid_to_fixed_tab common.memory_size = %ld\n", + erts_smp_atomic_read(&meta_pid_to_fixed_tab->common.memory_size)); + print_table(ERTS_PRINT_STDOUT, NULL, 1, meta_pid_to_fixed_tab); + +#endif +#ifdef ERTS_SMP + erts_smp_rwmtx_destroy(&tb->common.rwlock); + erts_smp_mtx_destroy(&tb->common.fixlock); +#endif + ASSERT(is_immed(tb->common.heir_data)); + erts_db_free(ERTS_ALC_T_DB_TABLE, tb, (void *) tb, sizeof(DbTable)); + ERTS_ETS_MISC_MEM_ADD(-sizeof(DbTable)); + return NULL; + } + return tb; +} + +static ERTS_INLINE void db_init_lock(DbTable* tb, char *rwname, char* fixname) +{ + erts_refc_init(&tb->common.ref, 1); + erts_refc_init(&tb->common.fixref, 0); +#ifdef ERTS_SMP +# ifdef ERTS_ENABLE_LOCK_COUNT + erts_smp_rwmtx_init_x(&tb->common.rwlock, rwname, tb->common.the_name); + erts_smp_mtx_init_x(&tb->common.fixlock, fixname, tb->common.the_name); +# else + erts_smp_rwmtx_init(&tb->common.rwlock, rwname); + erts_smp_mtx_init(&tb->common.fixlock, fixname); +# endif + tb->common.is_thread_safe = !(tb->common.status & DB_FINE_LOCKED); +#endif +} + +static ERTS_INLINE void db_lock_take_over_ref(DbTable* tb, db_lock_kind_t kind) +{ +#ifdef ERTS_SMP + ASSERT(tb != meta_pid_to_tab && tb != meta_pid_to_fixed_tab); + if (tb->common.type & DB_FINE_LOCKED) { + if (kind == LCK_WRITE) { + erts_smp_rwmtx_rwlock(&tb->common.rwlock); + tb->common.is_thread_safe = 1; + } else { + erts_smp_rwmtx_rlock(&tb->common.rwlock); + ASSERT(!tb->common.is_thread_safe); + } + } + else + { + switch (kind) { + case LCK_WRITE: + case LCK_WRITE_REC: + erts_smp_rwmtx_rwlock(&tb->common.rwlock); + break; + default: + erts_smp_rwmtx_rlock(&tb->common.rwlock); + } + ASSERT(tb->common.is_thread_safe); + } +#endif +} + +static ERTS_INLINE void db_lock(DbTable* tb, db_lock_kind_t kind) +{ + (void) db_ref(tb); +#ifdef ERTS_SMP + db_lock_take_over_ref(tb, kind); +#endif +} + +static ERTS_INLINE void db_unlock(DbTable* tb, db_lock_kind_t kind) +{ +#ifdef ERTS_SMP + ASSERT(tb != meta_pid_to_tab && tb != meta_pid_to_fixed_tab); + + if (tb->common.type & DB_FINE_LOCKED) { + if (tb->common.is_thread_safe) { + ASSERT(kind == LCK_WRITE); + tb->common.is_thread_safe = 0; + erts_smp_rwmtx_rwunlock(&tb->common.rwlock); + } + else { + ASSERT(kind != LCK_WRITE); + erts_smp_rwmtx_runlock(&tb->common.rwlock); + } + } + else { + ASSERT(tb->common.is_thread_safe); + switch (kind) { + case LCK_WRITE: + case LCK_WRITE_REC: + erts_smp_rwmtx_rwunlock(&tb->common.rwlock); + break; + default: + erts_smp_rwmtx_runlock(&tb->common.rwlock); + } + } +#endif + (void) db_unref(tb); /* May delete table... */ +} + + +static ERTS_INLINE void db_meta_lock(DbTable* tb, db_lock_kind_t kind) +{ + ASSERT(tb == meta_pid_to_tab || tb == meta_pid_to_fixed_tab); + ASSERT(kind != LCK_WRITE); + /* As long as we only lock for READ we don't have to lock at all. */ +} + +static ERTS_INLINE void db_meta_unlock(DbTable* tb, db_lock_kind_t kind) +{ + ASSERT(tb == meta_pid_to_tab || tb == meta_pid_to_fixed_tab); + ASSERT(kind != LCK_WRITE); +} + +static ERTS_INLINE +DbTable* db_get_table(Process *p, + Eterm id, + int what, + db_lock_kind_t kind) +{ + DbTable *tb = NULL; + + if (is_small(id)) { + Uint slot = unsigned_val(id) & meta_main_tab_slot_mask; + meta_main_tab_lock(slot); + if (slot < db_max_tabs && IS_SLOT_ALIVE(slot)) { + /* SMP: inc to prevent race, between unlock of meta_main_tab_lock + * and the table locking outside the meta_main_tab_lock + */ + tb = db_ref(meta_main_tab[slot].u.tb); + } + meta_main_tab_unlock(slot); + } + else if (is_atom(id)) { + erts_smp_rwmtx_t* rwlock; + struct meta_name_tab_entry* bucket = meta_name_tab_bucket(id,&rwlock); + erts_smp_rwmtx_rlock(rwlock); + if (bucket->pu.tb != NULL) { + if (is_atom(bucket->u.name_atom)) { /* single */ + if (bucket->u.name_atom == id) { + tb = db_ref(bucket->pu.tb); + } + } + else { /* multi */ + Uint cnt = unsigned_val(bucket->u.mcnt); + Uint i; + for (i=0; ipu.mvec[i].u.name_atom == id) { + tb = db_ref(bucket->pu.mvec[i].pu.tb); + break; + } + } + } + } + erts_smp_rwmtx_runlock(rwlock); + } + if (tb) { + db_lock_take_over_ref(tb, kind); + if (tb->common.id == id && ((tb->common.status & what) != 0 || + p->id == tb->common.owner)) { + return tb; + } + db_unlock(tb, kind); + } + return NULL; +} + +/* Requires meta_main_tab_locks[slot] locked. +*/ +static ERTS_INLINE void free_slot(int slot) +{ + ASSERT(!IS_SLOT_FREE(slot)); + erts_smp_spin_lock(&meta_main_tab_main_lock); + SET_NEXT_FREE_SLOT(slot,meta_main_tab_first_free); + meta_main_tab_first_free = slot; + meta_main_tab_cnt--; + erts_smp_spin_unlock(&meta_main_tab_main_lock); +} + +static int insert_named_tab(Eterm name_atom, DbTable* tb) +{ + int ret = 0; + erts_smp_rwmtx_t* rwlock; + struct meta_name_tab_entry* new_entry; + struct meta_name_tab_entry* bucket = meta_name_tab_bucket(name_atom, + &rwlock); + + erts_smp_rwmtx_rwlock(rwlock); + + if (bucket->pu.tb == NULL) { /* empty */ + new_entry = bucket; + } + else { + struct meta_name_tab_entry* entries; + Uint cnt; + if (is_atom(bucket->u.name_atom)) { /* single */ + size_t size; + if (bucket->u.name_atom == name_atom) { + goto done; + } + cnt = 2; + size = sizeof(struct meta_name_tab_entry)*cnt; + entries = erts_db_alloc_nt(ERTS_ALC_T_DB_NTAB_ENT, size); + ERTS_ETS_MISC_MEM_ADD(size); + new_entry = &entries[0]; + entries[1] = *bucket; + } + else { /* multi */ + size_t size, old_size; + Uint i; + cnt = unsigned_val(bucket->u.mcnt); + for (i=0; ipu.mvec[i].u.name_atom == name_atom) { + goto done; + } + } + old_size = sizeof(struct meta_name_tab_entry)*cnt; + size = sizeof(struct meta_name_tab_entry)*(cnt+1); + entries = erts_db_realloc_nt(ERTS_ALC_T_DB_NTAB_ENT, + bucket->pu.mvec, + old_size, + size); + ERTS_ETS_MISC_MEM_ADD(size-old_size); + new_entry = &entries[cnt]; + cnt++; + } + bucket->pu.mvec = entries; + bucket->u.mcnt = make_small(cnt); + } + new_entry->pu.tb = tb; + new_entry->u.name_atom = name_atom; + ret = 1; /* Ok */ + +done: + erts_smp_rwmtx_rwunlock(rwlock); + return ret; +} + +static int remove_named_tab(Eterm name_atom) +{ + int ret = 0; + erts_smp_rwmtx_t* rwlock; + struct meta_name_tab_entry* bucket = meta_name_tab_bucket(name_atom, + &rwlock); + erts_smp_rwmtx_rwlock(rwlock); + if (bucket->pu.tb == NULL) { + goto done; + } + else if (is_atom(bucket->u.name_atom)) { /* single */ + if (bucket->u.name_atom != name_atom) { + goto done; + } + bucket->pu.tb = NULL; + } + else { /* multi */ + Uint cnt = unsigned_val(bucket->u.mcnt); + Uint i = 0; + for (;;) { + if (bucket->pu.mvec[i].u.name_atom == name_atom) { + break; + } + if (++i >= cnt) { + goto done; + } + } + if (cnt == 2) { /* multi -> single */ + size_t size; + struct meta_name_tab_entry* entries = bucket->pu.mvec; + *bucket = entries[1-i]; + size = sizeof(struct meta_name_tab_entry)*cnt; + erts_db_free_nt(ERTS_ALC_T_DB_NTAB_ENT, entries, size); + ERTS_ETS_MISC_MEM_ADD(-size); + ASSERT(is_atom(bucket->u.name_atom)); + } + else { + size_t size, old_size; + ASSERT(cnt > 2); + bucket->u.mcnt = make_small(--cnt); + if (i != cnt) { + /* reposition last one before realloc destroys it */ + bucket->pu.mvec[i] = bucket->pu.mvec[cnt]; + } + old_size = sizeof(struct meta_name_tab_entry)*(cnt+1); + size = sizeof(struct meta_name_tab_entry)*cnt; + bucket->pu.mvec = erts_db_realloc_nt(ERTS_ALC_T_DB_NTAB_ENT, + bucket->pu.mvec, + old_size, + size); + ERTS_ETS_MISC_MEM_ADD(size - old_size); + + } + } + ret = 1; /* Ok */ + +done: + erts_smp_rwmtx_rwunlock(rwlock); + return ret; +} + +/* Do a fast fixation of a hash table. +** Must be matched by a local unfix before releasing table lock. +*/ +static ERTS_INLINE void local_fix_table(DbTable* tb) +{ + erts_refc_inc(&tb->common.fixref, 1); +} +static ERTS_INLINE void local_unfix_table(DbTable* tb) +{ + if (erts_refc_dectest(&tb->common.fixref, 0) == 0) { + ASSERT(IS_HASH_TABLE(tb->common.status)); + db_unfix_table_hash(&(tb->hash)); + } +} + + +/* + * BIFs. + */ + +BIF_RETTYPE ets_safe_fixtable_2(BIF_ALIST_2) +{ + DbTable *tb; + db_lock_kind_t kind; +#ifdef HARDDEBUG + erts_fprintf(stderr, + "ets:safe_fixtable(%T,%T); Process: %T, initial: %T:%T/%bpu\n", + BIF_ARG_1, BIF_ARG_2, BIF_P->id, + BIF_P->initial[0], BIF_P->initial[1], BIF_P->initial[2]); +#endif + kind = (BIF_ARG_2 == am_true) ? LCK_READ : LCK_WRITE_REC; + + if ((tb = db_get_table(BIF_P, BIF_ARG_1, DB_READ, kind)) == NULL) { + BIF_ERROR(BIF_P, BADARG); + } + + if (BIF_ARG_2 == am_true) { + fix_table_locked(BIF_P, tb); + } + else if (BIF_ARG_2 == am_false) { + if (IS_FIXED(tb)) { + unfix_table_locked(BIF_P, tb, &kind); + } + } + else { + db_unlock(tb, kind); + BIF_ERROR(BIF_P, BADARG); + } + db_unlock(tb, kind); + BIF_RET(am_true); +} + + +/* +** Returns the first Key in a table +*/ +BIF_RETTYPE ets_first_1(BIF_ALIST_1) +{ + DbTable* tb; + int cret; + Eterm ret; + + CHECK_TABLES(); + + tb = db_get_table(BIF_P, BIF_ARG_1, DB_READ, LCK_READ); + + if (!tb) { + BIF_ERROR(BIF_P, BADARG); + } + + cret = tb->common.meth->db_first(BIF_P, tb, &ret); + + db_unlock(tb, LCK_READ); + + if (cret != DB_ERROR_NONE) { + BIF_ERROR(BIF_P, BADARG); + } + BIF_RET(ret); +} + +/* +** The next BIF, given a key, return the "next" key +*/ +BIF_RETTYPE ets_next_2(BIF_ALIST_2) +{ + DbTable* tb; + int cret; + Eterm ret; + + CHECK_TABLES(); + + tb = db_get_table(BIF_P, BIF_ARG_1, DB_READ, LCK_READ); + + if (!tb) { + BIF_ERROR(BIF_P, BADARG); + } + + cret = tb->common.meth->db_next(BIF_P, tb, BIF_ARG_2, &ret); + + db_unlock(tb, LCK_READ); + + if (cret != DB_ERROR_NONE) { + BIF_ERROR(BIF_P, BADARG); + } + BIF_RET(ret); +} + +/* +** Returns the last Key in a table +*/ +BIF_RETTYPE ets_last_1(BIF_ALIST_1) +{ + DbTable* tb; + int cret; + Eterm ret; + + CHECK_TABLES(); + + tb = db_get_table(BIF_P, BIF_ARG_1, DB_READ, LCK_READ); + + if (!tb) { + BIF_ERROR(BIF_P, BADARG); + } + + cret = tb->common.meth->db_last(BIF_P, tb, &ret); + + db_unlock(tb, LCK_READ); + + if (cret != DB_ERROR_NONE) { + BIF_ERROR(BIF_P, BADARG); + } + BIF_RET(ret); +} + +/* +** The prev BIF, given a key, return the "previous" key +*/ +BIF_RETTYPE ets_prev_2(BIF_ALIST_2) +{ + DbTable* tb; + int cret; + Eterm ret; + + CHECK_TABLES(); + + tb = db_get_table(BIF_P, BIF_ARG_1, DB_READ, LCK_READ); + + if (!tb) { + BIF_ERROR(BIF_P, BADARG); + } + + cret = tb->common.meth->db_prev(BIF_P,tb,BIF_ARG_2,&ret); + + db_unlock(tb, LCK_READ); + + if (cret != DB_ERROR_NONE) { + BIF_ERROR(BIF_P, BADARG); + } + BIF_RET(ret); +} + +/* +** update_element(Tab, Key, {Pos, Value}) +** update_element(Tab, Key, [{Pos, Value}]) +*/ +BIF_RETTYPE ets_update_element_3(BIF_ALIST_3) +{ + DbTable* tb; + int cret = DB_ERROR_BADITEM; + Eterm list; + Eterm iter; + Eterm cell[2]; + DbUpdateHandle handle; + + if ((tb = db_get_table(BIF_P, BIF_ARG_1, DB_WRITE, LCK_WRITE_REC)) == NULL) { + BIF_ERROR(BIF_P, BADARG); + } + if (!(tb->common.status & (DB_SET | DB_ORDERED_SET))) { + goto bail_out; + } + if (is_tuple(BIF_ARG_3)) { + list = CONS(cell, BIF_ARG_3, NIL); + } + else { + list = BIF_ARG_3; + } + + if (!tb->common.meth->db_lookup_dbterm(tb, BIF_ARG_2, &handle)) { + cret = DB_ERROR_BADKEY; + goto bail_out; + } + + /* First verify that list is ok to avoid nasty rollback scenarios + */ + for (iter=list ; is_not_nil(iter); iter = CDR(list_val(iter))) { + Eterm pv; + Eterm* pvp; + Sint position; + + if (is_not_list(iter)) { + goto finalize; + } + pv = CAR(list_val(iter)); /* {Pos,Value} */ + if (is_not_tuple(pv)) { + goto finalize; + } + pvp = tuple_val(pv); + if (arityval(*pvp) != 2 || !is_small(pvp[1])) { + goto finalize; + } + position = signed_val(pvp[1]); + if (position < 1 || position == tb->common.keypos || + position > arityval(handle.dbterm->tpl[0])) { + goto finalize; + } + } + /* The point of no return, no failures from here on. + */ + cret = DB_ERROR_NONE; + + for (iter=list ; is_not_nil(iter); iter = CDR(list_val(iter))) { + Eterm* pvp = tuple_val(CAR(list_val(iter))); /* {Pos,Value} */ + db_do_update_element(&handle, signed_val(pvp[1]), pvp[2]); + } + +finalize: + tb->common.meth->db_finalize_dbterm(&handle); + +bail_out: + db_unlock(tb, LCK_WRITE_REC); + + switch (cret) { + case DB_ERROR_NONE: + BIF_RET(am_true); + case DB_ERROR_BADKEY: + BIF_RET(am_false); + case DB_ERROR_SYSRES: + BIF_ERROR(BIF_P, SYSTEM_LIMIT); + default: + BIF_ERROR(BIF_P, BADARG); + break; + } +} + +/* +** update_counter(Tab, Key, Incr) +** update_counter(Tab, Key, {Upop}) +** update_counter(Tab, Key, [{Upop}]) +** Upop = {Pos,Incr} | {Pos,Incr,Threshold,WarpTo} +** Returns new value(s) (integer or [integer]) +*/ +BIF_RETTYPE ets_update_counter_3(BIF_ALIST_3) +{ + DbTable* tb; + int cret = DB_ERROR_BADITEM; + Eterm upop_list; + int list_size; + Eterm ret; /* int or [int] */ + Eterm* ret_list_currp = NULL; + Eterm* ret_list_prevp = NULL; + Eterm iter; + Eterm cell[2]; + Eterm tuple[3]; + DbUpdateHandle handle; + Uint halloc_size = 0; /* overestimated heap usage */ + Eterm* htop; /* actual heap usage */ + Eterm* hstart; + Eterm* hend; + + if ((tb = db_get_table(BIF_P, BIF_ARG_1, DB_WRITE, LCK_WRITE_REC)) == NULL) { + BIF_ERROR(BIF_P, BADARG); + } + if (!(tb->common.status & (DB_SET | DB_ORDERED_SET))) { + goto bail_out; + } + if (is_integer(BIF_ARG_3)) { /* Incr */ + upop_list = CONS(cell, TUPLE2(tuple, make_small(tb->common.keypos+1), + BIF_ARG_3), NIL); + } + else if (is_tuple(BIF_ARG_3)) { /* {Upop} */ + upop_list = CONS(cell, BIF_ARG_3, NIL); + } + else { /* [{Upop}] (probably) */ + upop_list = BIF_ARG_3; + ret_list_prevp = &ret; + } + + if (!tb->common.meth->db_lookup_dbterm(tb, BIF_ARG_2, &handle)) { + goto bail_out; /* key not found */ + } + + /* First verify that list is ok to avoid nasty rollback scenarios + */ + list_size = 0; + for (iter=upop_list ; is_not_nil(iter); iter = CDR(list_val(iter)), + list_size += 2) { + Eterm upop; + Eterm* tpl; + Sint position; + Eterm incr, warp, oldcnt; + + if (is_not_list(iter)) { + goto finalize; + } + upop = CAR(list_val(iter)); + if (is_not_tuple(upop)) { + goto finalize; + } + tpl = tuple_val(upop); + switch (arityval(*tpl)) { + case 4: /* threshold specified */ + if (is_not_integer(tpl[3])) { + goto finalize; + } + warp = tpl[4]; + if (is_big(warp)) { + halloc_size += BIG_NEED_SIZE(big_arity(warp)); + } + else if (is_not_small(warp)) { + goto finalize; + } + /* Fall through */ + case 2: + if (!is_small(tpl[1])) { + goto finalize; + } + incr = tpl[2]; + if (is_big(incr)) { + halloc_size += BIG_NEED_SIZE(big_arity(incr)); + } + else if (is_not_small(incr)) { + goto finalize; + } + position = signed_val(tpl[1]); + if (position < 1 || position == tb->common.keypos || + position > arityval(handle.dbterm->tpl[0])) { + goto finalize; + } + oldcnt = handle.dbterm->tpl[position]; + if (is_big(oldcnt)) { + halloc_size += BIG_NEED_SIZE(big_arity(oldcnt)); + } + else if (is_not_small(oldcnt)) { + goto finalize; + } + break; + default: + goto finalize; + } + halloc_size += 2; /* worst growth case: small(0)+small(0)=big(2) */ + } + + /* The point of no return, no failures from here on. + */ + cret = DB_ERROR_NONE; + + if (ret_list_prevp) { /* Prepare to return a list */ + ret = NIL; + halloc_size += list_size; + hstart = HAlloc(BIF_P, halloc_size); + ret_list_currp = hstart; + htop = hstart + list_size; + hend = hstart + halloc_size; + } + else { + hstart = htop = HAlloc(BIF_P, halloc_size); + } + hend = hstart + halloc_size; + + for (iter=upop_list ; is_not_nil(iter); iter = CDR(list_val(iter))) { + + Eterm* tpl = tuple_val(CAR(list_val(iter))); + Sint position = signed_val(tpl[1]); + Eterm incr = tpl[2]; + Eterm oldcnt = handle.dbterm->tpl[position]; + Eterm newcnt = db_add_counter(&htop, oldcnt, incr); + + if (newcnt == NIL) { + cret = DB_ERROR_SYSRES; /* Can only happen if BIG_ARITY_MAX */ + ret = NIL; /* is reached, ie should not happen */ + htop = hstart; + break; + } + ASSERT(is_integer(newcnt)); + + if (arityval(*tpl) == 4) { /* Maybe warp it */ + Eterm threshold = tpl[3]; + if ((cmp(incr,make_small(0)) < 0) ? /* negative increment? */ + (cmp(newcnt,threshold) < 0) : /* if negative, check if below */ + (cmp(newcnt,threshold) > 0)) { /* else check if above threshold */ + + newcnt = tpl[4]; + } + } + + db_do_update_element(&handle,position,newcnt); + + if (ret_list_prevp) { + *ret_list_prevp = CONS(ret_list_currp,newcnt,NIL); + ret_list_prevp = &CDR(ret_list_currp); + ret_list_currp += 2; + } + else { + ret = newcnt; + break; + } + } + + ASSERT(is_integer(ret) || is_nil(ret) || + (is_list(ret) && (list_val(ret)+list_size)==ret_list_currp)); + ASSERT(htop <= hend); + + HRelease(BIF_P,hend,htop); + +finalize: + tb->common.meth->db_finalize_dbterm(&handle); + +bail_out: + db_unlock(tb, LCK_WRITE_REC); + + switch (cret) { + case DB_ERROR_NONE: + BIF_RET(ret); + case DB_ERROR_SYSRES: + BIF_ERROR(BIF_P, SYSTEM_LIMIT); + default: + BIF_ERROR(BIF_P, BADARG); + break; + } +} + +/* +** The put BIF +*/ +BIF_RETTYPE ets_insert_2(BIF_ALIST_2) +{ + DbTable* tb; + int cret = DB_ERROR_NONE; + Eterm lst; + DbTableMethod* meth; + db_lock_kind_t kind; + + CHECK_TABLES(); + + /* Write lock table if more than one object to keep atomicy */ + kind = ((is_list(BIF_ARG_2) && CDR(list_val(BIF_ARG_2)) != NIL) + ? LCK_WRITE : LCK_WRITE_REC); + + if ((tb = db_get_table(BIF_P, BIF_ARG_1, DB_WRITE, kind)) == NULL) { + BIF_ERROR(BIF_P, BADARG); + } + if (BIF_ARG_2 == NIL) { + db_unlock(tb, kind); + BIF_RET(am_true); + } + meth = tb->common.meth; + if (is_list(BIF_ARG_2)) { + for (lst = BIF_ARG_2; is_list(lst); lst = CDR(list_val(lst))) { + if (is_not_tuple(CAR(list_val(lst))) || + (arityval(*tuple_val(CAR(list_val(lst)))) < tb->common.keypos)) { + goto badarg; + } + } + if (lst != NIL) { + goto badarg; + } + for (lst = BIF_ARG_2; is_list(lst); lst = CDR(list_val(lst))) { + cret = meth->db_put(tb, CAR(list_val(lst)), 0); + if (cret != DB_ERROR_NONE) + break; + } + } else { + if (is_not_tuple(BIF_ARG_2) || + (arityval(*tuple_val(BIF_ARG_2)) < tb->common.keypos)) { + goto badarg; + } + cret = meth->db_put(tb, BIF_ARG_2, 0); + } + + db_unlock(tb, kind); + + switch (cret) { + case DB_ERROR_NONE: + BIF_RET(am_true); + case DB_ERROR_SYSRES: + BIF_ERROR(BIF_P, SYSTEM_LIMIT); + default: + BIF_ERROR(BIF_P, BADARG); + } + badarg: + db_unlock(tb, kind); + BIF_ERROR(BIF_P, BADARG); +} + + +/* +** The put-if-not-already-there BIF... +*/ +BIF_RETTYPE ets_insert_new_2(BIF_ALIST_2) +{ + DbTable* tb; + int cret = DB_ERROR_NONE; + Eterm ret = am_true; + Eterm obj; + db_lock_kind_t kind; + + CHECK_TABLES(); + + if (is_list(BIF_ARG_2)) { + if (CDR(list_val(BIF_ARG_2)) != NIL) { + Eterm lst; + Eterm lookup_ret; + DbTableMethod* meth; + + /* More than one object, use LCK_WRITE to keep atomicy */ + kind = LCK_WRITE; + tb = db_get_table(BIF_P, BIF_ARG_1, DB_WRITE, kind); + if (tb == NULL) { + BIF_ERROR(BIF_P, BADARG); + } + meth = tb->common.meth; + for (lst = BIF_ARG_2; is_list(lst); lst = CDR(list_val(lst))) { + if (is_not_tuple(CAR(list_val(lst))) + || (arityval(*tuple_val(CAR(list_val(lst)))) + < tb->common.keypos)) { + goto badarg; + } + } + if (lst != NIL) { + goto badarg; + } + for (lst = BIF_ARG_2; is_list(lst); lst = CDR(list_val(lst))) { + cret = meth->db_member(tb, TERM_GETKEY(tb,CAR(list_val(lst))), + &lookup_ret); + if ((cret != DB_ERROR_NONE) || (lookup_ret != am_false)) { + ret = am_false; + goto done; + } + } + + for (lst = BIF_ARG_2; is_list(lst); lst = CDR(list_val(lst))) { + cret = meth->db_put(tb,CAR(list_val(lst)), 0); + if (cret != DB_ERROR_NONE) + break; + } + goto done; + } + obj = CAR(list_val(BIF_ARG_2)); + } + else { + obj = BIF_ARG_2; + } + /* Only one object (or NIL) + */ + kind = LCK_WRITE_REC; + if ((tb = db_get_table(BIF_P, BIF_ARG_1, DB_WRITE, kind)) == NULL) { + BIF_ERROR(BIF_P, BADARG); + } + if (BIF_ARG_2 == NIL) { + db_unlock(tb, kind); + BIF_RET(am_true); + } + if (is_not_tuple(obj) + || (arityval(*tuple_val(obj)) < tb->common.keypos)) { + goto badarg; + } + cret = tb->common.meth->db_put(tb, obj, + 1); /* key_clash_fail */ + +done: + db_unlock(tb, kind); + switch (cret) { + case DB_ERROR_NONE: + BIF_RET(ret); + case DB_ERROR_BADKEY: + BIF_RET(am_false); + case DB_ERROR_SYSRES: + BIF_ERROR(BIF_P, SYSTEM_LIMIT); + default: + BIF_ERROR(BIF_P, BADARG); + } + badarg: + db_unlock(tb, kind); + BIF_ERROR(BIF_P, BADARG); +} + +/* +** Rename a (possibly) named table +*/ + +BIF_RETTYPE ets_rename_2(BIF_ALIST_2) +{ + DbTable* tb; + Eterm ret; + +#ifdef HARDDEBUG + erts_fprintf(stderr, + "ets:rename(%T,%T); Process: %T, initial: %T:%T/%bpu\n", + BIF_ARG_1, BIF_ARG_2, BIF_P->id, + BIF_P->initial[0], BIF_P->initial[1], BIF_P->initial[2]); +#endif + + if ((tb = db_get_table(BIF_P, BIF_ARG_1, DB_WRITE, LCK_WRITE)) == NULL) { + BIF_ERROR(BIF_P, BADARG); + } + + if (is_not_atom(BIF_ARG_2)) { + goto badarg; + } + + if (is_not_atom(tb->common.id)) { /* Not a named table */ + tb->common.the_name = BIF_ARG_2; + goto done; + } + + if (!insert_named_tab(BIF_ARG_2,tb)) { + goto badarg; + } + if (!remove_named_tab(tb->common.id)) { + erl_exit(1,"Could not find named tab %s", tb->common.id); + } + + tb->common.id = tb->common.the_name = BIF_ARG_2; + + done: + ret = tb->common.id; + db_unlock(tb, LCK_WRITE); + BIF_RET(ret); + badarg: + db_unlock(tb, LCK_WRITE); + BIF_ERROR(BIF_P, BADARG); +} + + +/* +** The create table BIF +** Args: (Name, Properties) +*/ + +BIF_RETTYPE ets_new_2(BIF_ALIST_2) +{ + DbTable* tb = NULL; + int slot; + Eterm list; + Eterm val; + Eterm ret; + Eterm heir; + Eterm heir_data; + Uint32 status; + Sint keypos; + int is_named, is_fine_locked; + int cret; + Eterm meta_tuple[3]; + DbTableMethod* meth; + + if (is_not_atom(BIF_ARG_1)) { + BIF_ERROR(BIF_P, BADARG); + } + if (is_not_nil(BIF_ARG_2) && is_not_list(BIF_ARG_2)) { + BIF_ERROR(BIF_P, BADARG); + } + + status = DB_NORMAL | DB_SET | DB_PROTECTED; + keypos = 1; + is_named = 0; + is_fine_locked = 0; + heir = am_none; + heir_data = am_undefined; + + list = BIF_ARG_2; + while(is_list(list)) { + val = CAR(list_val(list)); + if (val == am_bag) { + status |= DB_BAG; + status &= ~(DB_SET | DB_DUPLICATE_BAG | DB_ORDERED_SET); + } + else if (val == am_duplicate_bag) { + status |= DB_DUPLICATE_BAG; + status &= ~(DB_SET | DB_BAG | DB_ORDERED_SET); + } + else if (val == am_ordered_set) { + status |= DB_ORDERED_SET; + status &= ~(DB_SET | DB_BAG | DB_DUPLICATE_BAG); + } + /*TT*/ + else if (is_tuple(val)) { + Eterm *tp = tuple_val(val); + if (arityval(tp[0]) == 2) { + if (tp[1] == am_keypos + && is_small(tp[2]) && (signed_val(tp[2]) > 0)) { + keypos = signed_val(tp[2]); + } + else if (tp[1] == am_write_concurrency) { + if (tp[2] == am_true) { + is_fine_locked = 1; + } else if (tp[2] == am_false) { + is_fine_locked = 0; + } else break; + } + else if (tp[1] == am_heir && tp[2] == am_none) { + heir = am_none; + heir_data = am_undefined; + } + else break; + } + else if (arityval(tp[0]) == 3 && tp[1] == am_heir + && is_internal_pid(tp[2])) { + heir = tp[2]; + heir_data = tp[3]; + } + else break; + } + else if (val == am_public) { + status |= DB_PUBLIC; + status &= ~(DB_PROTECTED|DB_PRIVATE); + } + else if (val == am_private) { + status |= DB_PRIVATE; + status &= ~(DB_PROTECTED|DB_PUBLIC); + } + else if (val == am_named_table) { + is_named = 1; + } + else if (val == am_set || val == am_protected) + ; + else break; + + list = CDR(list_val(list)); + } + if (is_not_nil(list)) { /* bad opt or not a well formed list */ + BIF_ERROR(BIF_P, BADARG); + } + if (IS_HASH_TABLE(status)) { + meth = &db_hash; + #ifdef ERTS_SMP + if (is_fine_locked && !(status & DB_PRIVATE)) { + status |= DB_FINE_LOCKED; + } + #endif + } + else if (IS_TREE_TABLE(status)) { + meth = &db_tree; + } + else { + BIF_ERROR(BIF_P, BADARG); + } + + /* we create table outside any table lock + * and take the unusal cost of destroy table if it + * fails to find a slot + */ + { + DbTable init_tb; + + erts_smp_atomic_init(&init_tb.common.memory_size, 0); + tb = (DbTable*) erts_db_alloc(ERTS_ALC_T_DB_TABLE, + &init_tb, sizeof(DbTable)); + ERTS_ETS_MISC_MEM_ADD(sizeof(DbTable)); + erts_smp_atomic_init(&tb->common.memory_size, + erts_smp_atomic_read(&init_tb.common.memory_size)); + } + + tb->common.meth = meth; + tb->common.the_name = BIF_ARG_1; + tb->common.status = status; +#ifdef ERTS_SMP + tb->common.type = status & ERTS_ETS_TABLE_TYPES; + /* Note, 'type' is *read only* from now on... */ +#endif + db_init_lock(tb, "db_tab", "db_tab_fix"); + tb->common.keypos = keypos; + tb->common.owner = BIF_P->id; + set_heir(BIF_P, tb, heir, heir_data); + + erts_smp_atomic_init(&tb->common.nitems, 0); + + tb->common.fixations = NULL; + + cret = meth->db_create(BIF_P, tb); + ASSERT(cret == DB_ERROR_NONE); + + erts_smp_spin_lock(&meta_main_tab_main_lock); + + if (meta_main_tab_cnt >= db_max_tabs) { + erts_smp_spin_unlock(&meta_main_tab_main_lock); + erts_send_error_to_logger_str(BIF_P->group_leader, + "** Too many db tables **\n"); + free_heir_data(tb); + tb->common.meth->db_free_table(tb); + erts_db_free(ERTS_ALC_T_DB_TABLE, tb, (void *) tb, sizeof(DbTable)); + ERTS_ETS_MISC_MEM_ADD(-sizeof(DbTable)); + BIF_ERROR(BIF_P, SYSTEM_LIMIT); + } + + slot = meta_main_tab_first_free; + ASSERT(slot>=0 && slotcommon.id = ret; + tb->common.slot = slot; /* store slot for erase */ + + meta_main_tab_lock(slot); + meta_main_tab[slot].u.tb = tb; + ASSERT(IS_SLOT_ALIVE(slot)); + meta_main_tab_unlock(slot); + + if (is_named && !insert_named_tab(BIF_ARG_1, tb)) { + meta_main_tab_lock(slot); + free_slot(slot); + meta_main_tab_unlock(slot); + + db_lock_take_over_ref(tb,LCK_WRITE); + free_heir_data(tb); + tb->common.meth->db_free_table(tb); + db_unlock(tb,LCK_WRITE); + BIF_ERROR(BIF_P, BADARG); + } + + BIF_P->flags |= F_USING_DB; /* So we can remove tb if p dies */ + +#ifdef HARDDEBUG + erts_fprintf(stderr, + "ets:new(%T,%T)=%T; Process: %T, initial: %T:%T/%bpu\n", + BIF_ARG_1, BIF_ARG_2, ret, BIF_P->id, + BIF_P->initial[0], BIF_P->initial[1], BIF_P->initial[2]); + erts_fprintf(stderr, "ets: new: meta_pid_to_tab common.memory_size = %ld\n", + erts_smp_atomic_read(&meta_pid_to_tab->common.memory_size)); + erts_fprintf(stderr, "ets: new: meta_pid_to_fixed_tab common.memory_size = %ld\n", + erts_smp_atomic_read(&meta_pid_to_fixed_tab->common.memory_size)); +#endif + + db_meta_lock(meta_pid_to_tab, LCK_WRITE_REC); + if (db_put_hash(meta_pid_to_tab, + TUPLE2(meta_tuple, BIF_P->id, make_small(slot)), + 0) != DB_ERROR_NONE) { + erl_exit(1,"Could not update ets metadata."); + } + db_meta_unlock(meta_pid_to_tab, LCK_WRITE_REC); + + BIF_RET(ret); +} + +/* +** The lookup BIF +*/ +BIF_RETTYPE ets_lookup_2(BIF_ALIST_2) +{ + DbTable* tb; + int cret; + Eterm ret; + + CHECK_TABLES(); + + if ((tb = db_get_table(BIF_P, BIF_ARG_1, DB_READ, LCK_READ)) == NULL) { + BIF_ERROR(BIF_P, BADARG); + } + + cret = tb->common.meth->db_get(BIF_P, tb, BIF_ARG_2, &ret); + + db_unlock(tb, LCK_READ); + + switch (cret) { + case DB_ERROR_NONE: + BIF_RET(ret); + case DB_ERROR_SYSRES: + BIF_ERROR(BIF_P, SYSTEM_LIMIT); + default: + BIF_ERROR(BIF_P, BADARG); + } + +} + +/* +** The lookup BIF +*/ +BIF_RETTYPE ets_member_2(BIF_ALIST_2) +{ + DbTable* tb; + int cret; + Eterm ret; + + CHECK_TABLES(); + + if ((tb = db_get_table(BIF_P, BIF_ARG_1, DB_READ, LCK_READ)) == NULL) { + BIF_ERROR(BIF_P, BADARG); + } + + cret = tb->common.meth->db_member(tb, BIF_ARG_2, &ret); + + db_unlock(tb, LCK_READ); + + switch (cret) { + case DB_ERROR_NONE: + BIF_RET(ret); + case DB_ERROR_SYSRES: + BIF_ERROR(BIF_P, SYSTEM_LIMIT); + default: + BIF_ERROR(BIF_P, BADARG); + } + +} + +/* +** Get an element from a term +** get_element_3(Tab, Key, Index) +** return the element or a list of elements if bag +*/ +BIF_RETTYPE ets_lookup_element_3(BIF_ALIST_3) +{ + DbTable* tb; + Sint index; + int cret; + Eterm ret; + + CHECK_TABLES(); + + if ((tb = db_get_table(BIF_P, BIF_ARG_1, DB_READ, LCK_READ)) == NULL) { + BIF_ERROR(BIF_P, BADARG); + } + + if (is_not_small(BIF_ARG_3) || ((index = signed_val(BIF_ARG_3)) < 1)) { + db_unlock(tb, LCK_READ); + BIF_ERROR(BIF_P, BADARG); + } + + cret = tb->common.meth->db_get_element(BIF_P, tb, + BIF_ARG_2, index, &ret); + db_unlock(tb, LCK_READ); + switch (cret) { + case DB_ERROR_NONE: + BIF_RET(ret); + case DB_ERROR_SYSRES: + BIF_ERROR(BIF_P, SYSTEM_LIMIT); + default: + BIF_ERROR(BIF_P, BADARG); + } +} + +/* + * BIF to erase a whole table and release all memory it holds + */ +BIF_RETTYPE ets_delete_1(BIF_ALIST_1) +{ + int trap; + DbTable* tb; + +#ifdef HARDDEBUG + erts_fprintf(stderr, + "ets:delete(%T); Process: %T, initial: %T:%T/%bpu\n", + BIF_ARG_1, BIF_P->id, + BIF_P->initial[0], BIF_P->initial[1], BIF_P->initial[2]); +#endif + + CHECK_TABLES(); + + if ((tb = db_get_table(BIF_P, BIF_ARG_1, DB_WRITE, LCK_WRITE)) == NULL) { + BIF_ERROR(BIF_P, BADARG); + } + + /* + * Clear all access bits to prevent any ets operation to access the + * table while it is being deleted. + */ + tb->common.status &= ~(DB_PROTECTED|DB_PUBLIC|DB_PRIVATE); + tb->common.status |= DB_DELETE; + + meta_main_tab_lock(tb->common.slot); + /* We must keep the slot, to be found by db_proc_dead() if process dies */ + MARK_SLOT_DEAD(tb->common.slot); + meta_main_tab_unlock(tb->common.slot); + if (is_atom(tb->common.id)) { + remove_named_tab(tb->common.id); + } + + if (tb->common.owner != BIF_P->id) { + Eterm meta_tuple[3]; + + /* + * The table is being deleted by a process other than its owner. + * To make sure that the table will be completely deleted if the + * current process will be killed (e.g. by an EXIT signal), we will + * now transfer the ownership to the current process. + */ + db_meta_lock(meta_pid_to_tab, LCK_WRITE_REC); + db_erase_bag_exact2(meta_pid_to_tab, tb->common.owner, + make_small(tb->common.slot)); + + BIF_P->flags |= F_USING_DB; + tb->common.owner = BIF_P->id; + + db_put_hash(meta_pid_to_tab, + TUPLE2(meta_tuple,BIF_P->id,make_small(tb->common.slot)), + 0); + db_meta_unlock(meta_pid_to_tab, LCK_WRITE_REC); + } + /* disable inheritance */ + free_heir_data(tb); + tb->common.heir = am_none; + + free_fixations_locked(tb); + + trap = free_table_cont(BIF_P, tb, 1, 1); + db_unlock(tb, LCK_WRITE); + if (trap) { + /* + * Package the DbTable* pointer into a bignum so that it can be safely + * passed through a trap. We used to pass the DbTable* pointer directly + * (it looks like an continuation pointer), but that is will crash the + * emulator if this BIF is call traced. + */ + Eterm *hp = HAlloc(BIF_P, 2); + hp[0] = make_pos_bignum_header(1); + hp[1] = (Eterm) tb; + BIF_TRAP1(&ets_delete_continue_exp, BIF_P, make_big(hp)); + } + else { + BIF_RET(am_true); + } +} + +/* +** BIF ets:give_away(Tab, Pid, GiftData) +*/ +BIF_RETTYPE ets_give_away_3(BIF_ALIST_3) +{ + Process* to_proc = NULL; + ErtsProcLocks to_locks = ERTS_PROC_LOCK_MAIN; + Eterm buf[5]; + Eterm to_pid = BIF_ARG_2; + Eterm from_pid; + DbTable* tb = NULL; + + if (!is_internal_pid(to_pid)) { + goto badarg; + } + to_proc = erts_pid2proc(BIF_P, ERTS_PROC_LOCK_MAIN, to_pid, to_locks); + if (to_proc == NULL) { + goto badarg; + } + + if ((tb = db_get_table(BIF_P, BIF_ARG_1, DB_WRITE, LCK_WRITE)) == NULL + || tb->common.owner != BIF_P->id) { + goto badarg; + } + from_pid = tb->common.owner; + if (to_pid == from_pid) { + goto badarg; /* or should we be idempotent? return false maybe */ + } + + db_meta_lock(meta_pid_to_tab, LCK_WRITE_REC); + db_erase_bag_exact2(meta_pid_to_tab, tb->common.owner, + make_small(tb->common.slot)); + + to_proc->flags |= F_USING_DB; + tb->common.owner = to_pid; + + db_put_hash(meta_pid_to_tab, + TUPLE2(buf,to_pid,make_small(tb->common.slot)), + 0); + db_meta_unlock(meta_pid_to_tab, LCK_WRITE_REC); + + db_unlock(tb,LCK_WRITE); + erts_send_message(BIF_P, to_proc, &to_locks, + TUPLE4(buf, am_ETS_TRANSFER, tb->common.id, from_pid, BIF_ARG_3), + 0); + erts_smp_proc_unlock(to_proc, to_locks); + BIF_RET(am_true); + +badarg: + if (to_proc != NULL && to_proc != BIF_P) erts_smp_proc_unlock(to_proc, to_locks); + if (tb != NULL) db_unlock(tb, LCK_WRITE); + BIF_ERROR(BIF_P, BADARG); +} + +BIF_RETTYPE ets_setopts_2(BIF_ALIST_2) +{ + DbTable* tb = NULL; + Eterm* tp; + Eterm opt; + Eterm heir = THE_NON_VALUE; + Eterm heir_data = THE_NON_VALUE; + Uint32 protection = 0; + Eterm fakelist[2]; + Eterm tail; + + for (tail = is_tuple(BIF_ARG_2) ? CONS(fakelist, BIF_ARG_2, NIL) : BIF_ARG_2; + is_list(tail); + tail = CDR(list_val(tail))) { + + opt = CAR(list_val(tail)); + if (!is_tuple(opt) || (tp = tuple_val(opt), arityval(tp[0]) < 2)) { + goto badarg; + } + + switch (tp[1]) { + case am_heir: + if (heir != THE_NON_VALUE) goto badarg; + heir = tp[2]; + if (arityval(tp[0]) == 2 && heir == am_none) { + heir_data = am_undefined; + } + else if (arityval(tp[0]) == 3 && is_internal_pid(heir)) { + heir_data = tp[3]; + } + else goto badarg; + break; + + case am_protection: + if (arityval(tp[0]) != 2 || protection != 0) goto badarg; + switch (tp[2]) { + case am_private: protection = DB_PRIVATE; break; + case am_protected: protection = DB_PROTECTED; break; + case am_public: protection = DB_PUBLIC; break; + default: goto badarg; + } + break; + + default: goto badarg; + } + } + + if (tail != NIL + || (tb = db_get_table(BIF_P, BIF_ARG_1, DB_WRITE, LCK_WRITE)) == NULL + || tb->common.owner != BIF_P->id) { + goto badarg; + } + + if (heir_data != THE_NON_VALUE) { + free_heir_data(tb); + set_heir(BIF_P, tb, heir, heir_data); + } + if (protection) { + tb->common.status &= ~(DB_PRIVATE|DB_PROTECTED|DB_PUBLIC); + tb->common.status |= protection; + } + + db_unlock (tb,LCK_WRITE); + BIF_RET(am_true); + +badarg: + if (tb != NULL) { + db_unlock(tb,LCK_WRITE); + } + BIF_ERROR(BIF_P, BADARG); +} + +/* +** BIF to erase a whole table and release all memory it holds +*/ +BIF_RETTYPE ets_delete_all_objects_1(BIF_ALIST_1) +{ + DbTable* tb; + + CHECK_TABLES(); + + if ((tb = db_get_table(BIF_P, BIF_ARG_1, DB_WRITE, LCK_WRITE)) == NULL) { + BIF_ERROR(BIF_P, BADARG); + } + + tb->common.meth->db_delete_all_objects(BIF_P, tb); + + db_unlock(tb, LCK_WRITE); + + BIF_RET(am_true); +} + +/* +** Erase an object with given key, or maybe several objects if we have a bag +** Called as db_erase(Tab, Key), where Key is element 1 of the +** object(s) we want to erase +*/ +BIF_RETTYPE ets_delete_2(BIF_ALIST_2) +{ + DbTable* tb; + int cret; + Eterm ret; + + CHECK_TABLES(); + + if ((tb = db_get_table(BIF_P, BIF_ARG_1, DB_WRITE, LCK_WRITE_REC)) == NULL) { + BIF_ERROR(BIF_P, BADARG); + } + + cret = tb->common.meth->db_erase(tb,BIF_ARG_2,&ret); + + db_unlock(tb, LCK_WRITE_REC); + + switch (cret) { + case DB_ERROR_NONE: + BIF_RET(ret); + case DB_ERROR_SYSRES: + BIF_ERROR(BIF_P, SYSTEM_LIMIT); + default: + BIF_ERROR(BIF_P, BADARG); + } +} + +/* +** Erase a specific object, or maybe several objects if we have a bag +*/ +BIF_RETTYPE ets_delete_object_2(BIF_ALIST_2) +{ + DbTable* tb; + int cret; + Eterm ret; + + CHECK_TABLES(); + + if ((tb = db_get_table(BIF_P, BIF_ARG_1, DB_WRITE, LCK_WRITE_REC)) == NULL) { + BIF_ERROR(BIF_P, BADARG); + } + if (is_not_tuple(BIF_ARG_2) || + (arityval(*tuple_val(BIF_ARG_2)) < tb->common.keypos)) { + db_unlock(tb, LCK_WRITE_REC); + BIF_ERROR(BIF_P, BADARG); + } + + cret = tb->common.meth->db_erase_object(tb, BIF_ARG_2, &ret); + db_unlock(tb, LCK_WRITE_REC); + + switch (cret) { + case DB_ERROR_NONE: + BIF_RET(ret); + case DB_ERROR_SYSRES: + BIF_ERROR(BIF_P, SYSTEM_LIMIT); + default: + BIF_ERROR(BIF_P, BADARG); + } +} + +/* +** This is for trapping, cannot be called directly. +*/ +static BIF_RETTYPE ets_select_delete_1(Process *p, Eterm a1) +{ + BIF_RETTYPE result; + DbTable* tb; + int cret; + Eterm ret; + Eterm *tptr; + db_lock_kind_t kind = LCK_WRITE_REC; + + CHECK_TABLES(); + ASSERT(is_tuple(a1)); + tptr = tuple_val(a1); + ASSERT(arityval(*tptr) >= 1); + + if ((tb = db_get_table(p, tptr[1], DB_WRITE, kind)) == NULL) { + BIF_ERROR(p,BADARG); + } + + cret = tb->common.meth->db_select_delete_continue(p,tb,a1,&ret); + + if(!DID_TRAP(p,ret) && ITERATION_SAFETY(p,tb) != ITER_SAFE) { + unfix_table_locked(p, tb, &kind); + } + + db_unlock(tb, kind); + + switch (cret) { + case DB_ERROR_NONE: + ERTS_BIF_PREP_RET(result, ret); + break; + default: + ERTS_BIF_PREP_ERROR(result, p, BADARG); + break; + } + erts_match_set_release_result(p); + + return result; +} + + +BIF_RETTYPE ets_select_delete_2(BIF_ALIST_2) +{ + BIF_RETTYPE result; + DbTable* tb; + int cret; + Eterm ret; + enum DbIterSafety safety; + + CHECK_TABLES(); + + if(eq(BIF_ARG_2, ms_delete_all)) { + int nitems; + if ((tb = db_get_table(BIF_P, BIF_ARG_1, DB_WRITE, LCK_WRITE)) == NULL) { + BIF_ERROR(BIF_P, BADARG); + } + nitems = erts_smp_atomic_read(&tb->common.nitems); + tb->common.meth->db_delete_all_objects(BIF_P, tb); + db_unlock(tb, LCK_WRITE); + BIF_RET(erts_make_integer(nitems,BIF_P)); + } + + if ((tb = db_get_table(BIF_P, BIF_ARG_1, DB_WRITE, LCK_WRITE_REC)) == NULL) { + BIF_ERROR(BIF_P, BADARG); + } + safety = ITERATION_SAFETY(BIF_P,tb); + if (safety == ITER_UNSAFE) { + local_fix_table(tb); + } + cret = tb->common.meth->db_select_delete(BIF_P, tb, BIF_ARG_2, &ret); + + if (DID_TRAP(BIF_P,ret) && safety != ITER_SAFE) { + fix_table_locked(BIF_P,tb); + } + if (safety == ITER_UNSAFE) { + local_unfix_table(tb); + } + db_unlock(tb, LCK_WRITE_REC); + + switch (cret) { + case DB_ERROR_NONE: + ERTS_BIF_PREP_RET(result, ret); + break; + case DB_ERROR_SYSRES: + ERTS_BIF_PREP_ERROR(result, BIF_P, SYSTEM_LIMIT); + break; + default: + ERTS_BIF_PREP_ERROR(result, BIF_P, BADARG); + break; + } + + erts_match_set_release_result(BIF_P); + + return result; +} + +/* +** Return a list of tables on this node +*/ +BIF_RETTYPE ets_all_0(BIF_ALIST_0) +{ + DbTable* tb; + Eterm previous; + int i, j; + Eterm* hp; + Eterm* hendp; + int t_tabs_cnt; + int t_max_tabs; + + erts_smp_spin_lock(&meta_main_tab_main_lock); + t_tabs_cnt = meta_main_tab_cnt; + t_max_tabs = db_max_tabs; + erts_smp_spin_unlock(&meta_main_tab_main_lock); + + hp = HAlloc(BIF_P, 2*t_tabs_cnt); + hendp = hp + 2*t_tabs_cnt; + + previous = NIL; + j = 0; + for(i = 0; (i < t_max_tabs && j < t_tabs_cnt); i++) { + meta_main_tab_lock(i); + if (IS_SLOT_ALIVE(i)) { + j++; + tb = meta_main_tab[i].u.tb; + previous = CONS(hp, tb->common.id, previous); + hp += 2; + } + meta_main_tab_unlock(i); + } + HRelease(BIF_P, hendp, hp); + BIF_RET(previous); +} + + +/* +** db_slot(Db, Slot) -> [Items]. +*/ +BIF_RETTYPE ets_slot_2(BIF_ALIST_2) +{ + DbTable* tb; + int cret; + Eterm ret; + + CHECK_TABLES(); + + if ((tb = db_get_table(BIF_P, BIF_ARG_1, DB_READ, LCK_READ)) == NULL) { + BIF_ERROR(BIF_P, BADARG); + } + /* The slot number is checked in table specific code. */ + cret = tb->common.meth->db_slot(BIF_P, tb, BIF_ARG_2, &ret); + db_unlock(tb, LCK_READ); + switch (cret) { + case DB_ERROR_NONE: + BIF_RET(ret); + case DB_ERROR_SYSRES: + BIF_ERROR(BIF_P, SYSTEM_LIMIT); + default: + BIF_ERROR(BIF_P, BADARG); + } +} + +/* +** The match BIF, called as ets:match(Table, Pattern), ets:match(Continuation) or ets:match(Table,Pattern,ChunkSize). +*/ + +BIF_RETTYPE ets_match_1(BIF_ALIST_1) +{ + return ets_select_1(BIF_P, BIF_ARG_1); +} + +BIF_RETTYPE ets_match_2(BIF_ALIST_2) +{ + Eterm ms; + Eterm buff[8]; + Eterm *hp = buff; + /*hp = HAlloc(BIF_P, 8);*/ + ms = CONS(hp, am_DollarDollar, NIL); + hp += 2; + ms = TUPLE3(hp, BIF_ARG_2, NIL, ms); + hp += 4; + ms = CONS(hp, ms, NIL); + return ets_select_2(BIF_P, BIF_ARG_1, ms); +} + +BIF_RETTYPE ets_match_3(BIF_ALIST_3) +{ + Eterm ms; + Eterm buff[8]; + Eterm *hp = buff; + /*hp = HAlloc(BIF_P, 8);*/ + ms = CONS(hp, am_DollarDollar, NIL); + hp += 2; + ms = TUPLE3(hp, BIF_ARG_2, NIL, ms); + hp += 4; + ms = CONS(hp, ms, NIL); + return ets_select_3(BIF_P, BIF_ARG_1, ms, BIF_ARG_3); +} + + +BIF_RETTYPE ets_select_3(BIF_ALIST_3) +{ + BIF_RETTYPE result; + DbTable* tb; + int cret; + Eterm ret; + Sint chunk_size; + enum DbIterSafety safety; + + CHECK_TABLES(); + + /* Chunk size strictly greater than 0 */ + if (is_not_small(BIF_ARG_3) || (chunk_size = signed_val(BIF_ARG_3)) <= 0) { + BIF_ERROR(BIF_P, BADARG); + } + if ((tb = db_get_table(BIF_P, BIF_ARG_1, DB_READ, LCK_READ)) == NULL) { + BIF_ERROR(BIF_P, BADARG); + } + safety = ITERATION_SAFETY(BIF_P,tb); + if (safety == ITER_UNSAFE) { + local_fix_table(tb); + } + cret = tb->common.meth->db_select_chunk(BIF_P, tb, + BIF_ARG_2, chunk_size, + 0 /* not reversed */, + &ret); + if (DID_TRAP(BIF_P,ret) && safety != ITER_SAFE) { + fix_table_locked(BIF_P, tb); + } + if (safety == ITER_UNSAFE) { + local_unfix_table(tb); + } + db_unlock(tb, LCK_READ); + + switch (cret) { + case DB_ERROR_NONE: + ERTS_BIF_PREP_RET(result, ret); + break; + case DB_ERROR_SYSRES: + ERTS_BIF_PREP_ERROR(result, BIF_P, SYSTEM_LIMIT); + break; + default: + ERTS_BIF_PREP_ERROR(result, BIF_P, BADARG); + break; + } + + erts_match_set_release_result(BIF_P); + + return result; +} + + +/* We get here instead of in the real BIF when trapping */ +static BIF_RETTYPE ets_select_trap_1(Process *p, Eterm a1) +{ + BIF_RETTYPE result; + DbTable* tb; + int cret; + Eterm ret; + Eterm *tptr; + db_lock_kind_t kind = LCK_READ; + + CHECK_TABLES(); + + tptr = tuple_val(a1); + ASSERT(arityval(*tptr) >= 1) + + if ((tb = db_get_table(p, tptr[1], DB_READ, kind)) == NULL) { + BIF_ERROR(p, BADARG); + } + + cret = tb->common.meth->db_select_continue(p, tb, a1, + &ret); + + if (!DID_TRAP(p,ret) && ITERATION_SAFETY(p,tb) != ITER_SAFE) { + unfix_table_locked(p, tb, &kind); + } + db_unlock(tb, kind); + + switch (cret) { + case DB_ERROR_NONE: + ERTS_BIF_PREP_RET(result, ret); + break; + case DB_ERROR_SYSRES: + ERTS_BIF_PREP_ERROR(result, p, SYSTEM_LIMIT); + break; + default: + ERTS_BIF_PREP_ERROR(result, p, BADARG); + break; + } + + erts_match_set_release_result(p); + + return result; +} + + +BIF_RETTYPE ets_select_1(BIF_ALIST_1) +{ + BIF_RETTYPE result; + DbTable* tb; + int cret; + Eterm ret; + Eterm *tptr; + enum DbIterSafety safety; + + CHECK_TABLES(); + + /* + * Make sure that the table exists. + */ + + if (!is_tuple(BIF_ARG_1)) { + if (BIF_ARG_1 == am_EOT) { + BIF_RET(am_EOT); + } + BIF_ERROR(BIF_P, BADARG); + } + tptr = tuple_val(BIF_ARG_1); + if (arityval(*tptr) < 1 || + (tb = db_get_table(BIF_P, tptr[1], DB_READ, LCK_READ)) == NULL) { + BIF_ERROR(BIF_P, BADARG); + } + + safety = ITERATION_SAFETY(BIF_P,tb); + if (safety == ITER_UNSAFE) { + local_fix_table(tb); + } + + cret = tb->common.meth->db_select_continue(BIF_P,tb, + BIF_ARG_1, &ret); + + if (DID_TRAP(BIF_P,ret) && safety != ITER_SAFE) { + fix_table_locked(BIF_P, tb); + } + if (safety == ITER_UNSAFE) { + local_unfix_table(tb); + } + db_unlock(tb, LCK_READ); + + switch (cret) { + case DB_ERROR_NONE: + ERTS_BIF_PREP_RET(result, ret); + break; + case DB_ERROR_SYSRES: + ERTS_BIF_PREP_ERROR(result, BIF_P, SYSTEM_LIMIT); + break; + default: + ERTS_BIF_PREP_ERROR(result, BIF_P, BADARG); + break; + } + + erts_match_set_release_result(BIF_P); + + return result; +} + +BIF_RETTYPE ets_select_2(BIF_ALIST_2) +{ + BIF_RETTYPE result; + DbTable* tb; + int cret; + enum DbIterSafety safety; + Eterm ret; + + CHECK_TABLES(); + + /* + * Make sure that the table exists. + */ + + if ((tb = db_get_table(BIF_P, BIF_ARG_1, DB_READ, LCK_READ)) == NULL) { + BIF_ERROR(BIF_P, BADARG); + } + safety = ITERATION_SAFETY(BIF_P,tb); + if (safety == ITER_UNSAFE) { + local_fix_table(tb); + } + + cret = tb->common.meth->db_select(BIF_P, tb, BIF_ARG_2, + 0, &ret); + + if (DID_TRAP(BIF_P,ret) && safety != ITER_SAFE) { + fix_table_locked(BIF_P, tb); + } + if (safety == ITER_UNSAFE) { + local_unfix_table(tb); + } + db_unlock(tb, LCK_READ); + + switch (cret) { + case DB_ERROR_NONE: + ERTS_BIF_PREP_RET(result, ret); + break; + case DB_ERROR_SYSRES: + ERTS_BIF_PREP_ERROR(result, BIF_P, SYSTEM_LIMIT); + break; + default: + ERTS_BIF_PREP_ERROR(result, BIF_P, BADARG); + break; + } + + erts_match_set_release_result(BIF_P); + + return result; +} + +/* We get here instead of in the real BIF when trapping */ +static BIF_RETTYPE ets_select_count_1(Process *p, Eterm a1) +{ + BIF_RETTYPE result; + DbTable* tb; + int cret; + Eterm ret; + Eterm *tptr; + db_lock_kind_t kind = LCK_READ; + + CHECK_TABLES(); + + tptr = tuple_val(a1); + ASSERT(arityval(*tptr) >= 1) + if ((tb = db_get_table(p, tptr[1], DB_READ, kind)) == NULL) { + BIF_ERROR(p, BADARG); + } + + cret = tb->common.meth->db_select_count_continue(p, tb, a1, &ret); + + if (!DID_TRAP(p,ret) && ITERATION_SAFETY(p,tb) != ITER_SAFE) { + unfix_table_locked(p, tb, &kind); + } + db_unlock(tb, kind); + + switch (cret) { + case DB_ERROR_NONE: + ERTS_BIF_PREP_RET(result, ret); + break; + case DB_ERROR_SYSRES: + ERTS_BIF_PREP_ERROR(result, p, SYSTEM_LIMIT); + break; + default: + ERTS_BIF_PREP_ERROR(result, p, BADARG); + break; + } + + erts_match_set_release_result(p); + + return result; +} + +BIF_RETTYPE ets_select_count_2(BIF_ALIST_2) +{ + BIF_RETTYPE result; + DbTable* tb; + int cret; + enum DbIterSafety safety; + Eterm ret; + + CHECK_TABLES(); + /* + * Make sure that the table exists. + */ + + if ((tb = db_get_table(BIF_P, BIF_ARG_1, DB_READ, LCK_READ)) == NULL) { + BIF_ERROR(BIF_P, BADARG); + } + safety = ITERATION_SAFETY(BIF_P,tb); + if (safety == ITER_UNSAFE) { + local_fix_table(tb); + } + cret = tb->common.meth->db_select_count(BIF_P,tb,BIF_ARG_2, &ret); + + if (DID_TRAP(BIF_P,ret) && safety != ITER_SAFE) { + fix_table_locked(BIF_P, tb); + } + if (safety == ITER_UNSAFE) { + local_unfix_table(tb); + } + db_unlock(tb, LCK_READ); + switch (cret) { + case DB_ERROR_NONE: + ERTS_BIF_PREP_RET(result, ret); + break; + case DB_ERROR_SYSRES: + ERTS_BIF_PREP_ERROR(result, BIF_P, SYSTEM_LIMIT); + break; + default: + ERTS_BIF_PREP_ERROR(result, BIF_P, BADARG); + break; + } + + erts_match_set_release_result(BIF_P); + + return result; +} + + +BIF_RETTYPE ets_select_reverse_3(BIF_ALIST_3) +{ + BIF_RETTYPE result; + DbTable* tb; + int cret; + enum DbIterSafety safety; + Eterm ret; + Sint chunk_size; + + CHECK_TABLES(); + /* + * Make sure that the table exists. + */ + + if ((tb = db_get_table(BIF_P, BIF_ARG_1, DB_READ, LCK_READ)) == NULL) { + BIF_ERROR(BIF_P, BADARG); + } + + /* Chunk size strictly greater than 0 */ + if (is_not_small(BIF_ARG_3) || (chunk_size = signed_val(BIF_ARG_3)) <= 0) { + db_unlock(tb, LCK_READ); + BIF_ERROR(BIF_P, BADARG); + } + safety = ITERATION_SAFETY(BIF_P,tb); + if (safety == ITER_UNSAFE) { + local_fix_table(tb); + } + cret = tb->common.meth->db_select_chunk(BIF_P,tb, + BIF_ARG_2, chunk_size, + 1 /* reversed */, &ret); + if (DID_TRAP(BIF_P,ret) && safety != ITER_SAFE) { + fix_table_locked(BIF_P, tb); + } + if (safety == ITER_UNSAFE) { + local_unfix_table(tb); + } + db_unlock(tb, LCK_READ); + switch (cret) { + case DB_ERROR_NONE: + ERTS_BIF_PREP_RET(result, ret); + break; + case DB_ERROR_SYSRES: + ERTS_BIF_PREP_ERROR(result, BIF_P, SYSTEM_LIMIT); + break; + default: + ERTS_BIF_PREP_ERROR(result, BIF_P, BADARG); + break; + } + erts_match_set_release_result(BIF_P); + return result; +} + +BIF_RETTYPE ets_select_reverse_1(BIF_ALIST_1) +{ + return ets_select_1(BIF_P, BIF_ARG_1); +} + +BIF_RETTYPE ets_select_reverse_2(BIF_ALIST_2) +{ + BIF_RETTYPE result; + DbTable* tb; + int cret; + enum DbIterSafety safety; + Eterm ret; + + CHECK_TABLES(); + /* + * Make sure that the table exists. + */ + + if ((tb = db_get_table(BIF_P, BIF_ARG_1, DB_READ, LCK_READ)) == NULL) { + BIF_ERROR(BIF_P, BADARG); + } + safety = ITERATION_SAFETY(BIF_P,tb); + if (safety == ITER_UNSAFE) { + local_fix_table(tb); + } + cret = tb->common.meth->db_select(BIF_P,tb,BIF_ARG_2, + 1 /*reversed*/, &ret); + + if (DID_TRAP(BIF_P,ret) && safety != ITER_SAFE) { + fix_table_locked(BIF_P, tb); + } + if (safety == ITER_UNSAFE) { + local_unfix_table(tb); + } + db_unlock(tb, LCK_READ); + switch (cret) { + case DB_ERROR_NONE: + ERTS_BIF_PREP_RET(result, ret); + break; + case DB_ERROR_SYSRES: + ERTS_BIF_PREP_ERROR(result, BIF_P, SYSTEM_LIMIT); + break; + default: + ERTS_BIF_PREP_ERROR(result, BIF_P, BADARG); + break; + } + erts_match_set_release_result(BIF_P); + return result; +} + + +/* +** ets:match_object(Continuation), ets:match_object(Table, Pattern), ets:match_object(Table,Pattern,ChunkSize) +*/ +BIF_RETTYPE ets_match_object_1(BIF_ALIST_1) +{ + return ets_select_1(BIF_P, BIF_ARG_1); +} + +BIF_RETTYPE ets_match_object_2(BIF_ALIST_2) +{ + Eterm ms; + Eterm buff[8]; + Eterm *hp = buff; + /*hp = HAlloc(BIF_P, 8);*/ + ms = CONS(hp, am_DollarUnderscore, NIL); + hp += 2; + ms = TUPLE3(hp, BIF_ARG_2, NIL, ms); + hp += 4; + ms = CONS(hp, ms, NIL); + return ets_select_2(BIF_P, BIF_ARG_1, ms); +} + +BIF_RETTYPE ets_match_object_3(BIF_ALIST_3) +{ + Eterm ms; + Eterm buff[8]; + Eterm *hp = buff; + /*hp = HAlloc(BIF_P, 8);*/ + ms = CONS(hp, am_DollarUnderscore, NIL); + hp += 2; + ms = TUPLE3(hp, BIF_ARG_2, NIL, ms); + hp += 4; + ms = CONS(hp, ms, NIL); + return ets_select_3(BIF_P, BIF_ARG_1, ms, BIF_ARG_3); +} + +/* + * BIF to extract information about a particular table. + */ + +BIF_RETTYPE ets_info_1(BIF_ALIST_1) +{ + static Eterm fields[] = {am_protection, am_keypos, am_type, am_named_table, + am_node, am_size, am_name, am_heir, am_owner, am_memory}; + Eterm results[sizeof(fields)/sizeof(Eterm)]; + DbTable* tb; + Eterm res; + int i; + Eterm* hp; + /*Process* rp = NULL;*/ + Eterm owner; + + if ((tb = db_get_table(BIF_P, BIF_ARG_1, DB_INFO, LCK_READ)) == NULL) { + if (is_atom(BIF_ARG_1) || is_small(BIF_ARG_1)) { + BIF_RET(am_undefined); + } + BIF_ERROR(BIF_P, BADARG); + } + + owner = tb->common.owner; + + /* If/when we implement lockless private tables: + if ((tb->common.status & DB_PRIVATE) && owner != BIF_P->id) { + db_unlock(tb, LCK_READ); + rp = erts_pid2proc_not_running(BIF_P, ERTS_PROC_LOCK_MAIN, + owner, ERTS_PROC_LOCK_MAIN); + if (rp == NULL) { + BIF_RET(am_undefined); + } + if (rp == ERTS_PROC_LOCK_BUSY) { + ERTS_BIF_YIELD1(bif_export[BIF_ets_info_1], BIF_P, BIF_ARG_1); + } + if ((tb = db_get_table(BIF_P, BIF_ARG_1, DB_INFO, LCK_READ)) == NULL + || tb->common.owner != owner) { + if (BIF_P != rp) + erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_MAIN); + if (is_atom(BIF_ARG_1) || is_small(BIF_ARG_1)) { + BIF_RET(am_undefined); + } + BIF_ERROR(BIF_P, BADARG); + } + }*/ + for (i = 0; i < sizeof(fields)/sizeof(Eterm); i++) { + results[i] = table_info(BIF_P, tb, fields[i]); + ASSERT(is_value(results[i])); + } + db_unlock(tb, LCK_READ); + + /*if (rp != NULL && rp != BIF_P) + erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_MAIN);*/ + + hp = HAlloc(BIF_P, 5*sizeof(fields)/sizeof(Eterm)); + res = NIL; + for (i = 0; i < sizeof(fields)/sizeof(Eterm); i++) { + Eterm tuple; + tuple = TUPLE2(hp, fields[i], results[i]); + hp += 3; + res = CONS(hp, tuple, res); + hp += 2; + } + BIF_RET(res); +} + +/* + * BIF to extract information about a particular table. + */ + +BIF_RETTYPE ets_info_2(BIF_ALIST_2) +{ + DbTable* tb; + Eterm ret = THE_NON_VALUE; + + if ((tb = db_get_table(BIF_P, BIF_ARG_1, DB_INFO, LCK_READ)) == NULL) { + if (is_atom(BIF_ARG_1) || is_small(BIF_ARG_1)) { + BIF_RET(am_undefined); + } + BIF_ERROR(BIF_P, BADARG); + } + ret = table_info(BIF_P, tb, BIF_ARG_2); + db_unlock(tb, LCK_READ); + if (is_non_value(ret)) { + BIF_ERROR(BIF_P, BADARG); + } + BIF_RET(ret); +} + + +BIF_RETTYPE ets_is_compiled_ms_1(BIF_ALIST_1) +{ + if (erts_db_is_compiled_ms(BIF_ARG_1)) { + BIF_RET(am_true); + } else { + BIF_RET(am_false); + } +} + +BIF_RETTYPE ets_match_spec_compile_1(BIF_ALIST_1) +{ + Binary *mp = db_match_set_compile(BIF_P, BIF_ARG_1, DCOMP_TABLE); + Eterm *hp; + if (mp == NULL) { + BIF_ERROR(BIF_P, BADARG); + } + + hp = HAlloc(BIF_P, PROC_BIN_SIZE); + + BIF_RET(erts_mk_magic_binary_term(&hp, &MSO(BIF_P), mp)); +} + +BIF_RETTYPE ets_match_spec_run_r_3(BIF_ALIST_3) +{ + Eterm ret = BIF_ARG_3; + int i = 0; + Eterm *hp; + Eterm lst; + ProcBin *bp; + Binary *mp; + Eterm res; + Uint32 dummy; + Uint sz; + + if (!(is_list(BIF_ARG_1) || BIF_ARG_1 == NIL) || !is_binary(BIF_ARG_2)) { + error: + BIF_ERROR(BIF_P, BADARG); + } + + bp = (ProcBin*) binary_val(BIF_ARG_2); + if (thing_subtag(bp->thing_word) != REFC_BINARY_SUBTAG) { + goto error; + } + mp = bp->val; + if (!IsMatchProgBinary(mp)) { + goto error; + } + + if (BIF_ARG_1 == NIL) { + BIF_RET(BIF_ARG_3); + } + for (lst = BIF_ARG_1; is_list(lst); lst = CDR(list_val(lst))) { + if (++i > CONTEXT_REDS) { + BUMP_ALL_REDS(BIF_P); + BIF_TRAP3(bif_export[BIF_ets_match_spec_run_r_3], + BIF_P,lst,BIF_ARG_2,ret); + } + res = db_prog_match(BIF_P, mp, CAR(list_val(lst)), 0, &dummy); + if (is_value(res)) { + sz = size_object(res); + hp = HAlloc(BIF_P, sz + 2); + res = copy_struct(res, sz, &hp, &MSO(BIF_P)); + ret = CONS(hp,res,ret); + /*hp += 2;*/ + } + } + if (lst != NIL) { + goto error; + } + BIF_RET2(ret,i); +} + + +/* +** External interface (NOT BIF's) +*/ + + +/* Init the db */ + +void init_db(void) +{ + DbTable init_tb; + int i; + extern Eterm* em_apply_bif; + Eterm *hp; + unsigned bits; + size_t size; + +#ifdef ERTS_SMP + for (i=0; i SMALL_BITS) { + erl_exit(1,"Max limit for ets tabled too high %u (max %u).", + db_max_tabs, 1L<common.memory_size, + erts_smp_atomic_read(&init_tb.common.memory_size)); + + meta_pid_to_tab->common.id = NIL; + meta_pid_to_tab->common.the_name = am_true; + meta_pid_to_tab->common.status = (DB_NORMAL | DB_BAG | DB_PUBLIC | DB_FINE_LOCKED); +#ifdef ERTS_SMP + meta_pid_to_tab->common.type + = meta_pid_to_tab->common.status & ERTS_ETS_TABLE_TYPES; + /* Note, 'type' is *read only* from now on... */ + meta_pid_to_tab->common.is_thread_safe = 0; +#endif + meta_pid_to_tab->common.keypos = 1; + meta_pid_to_tab->common.owner = NIL; + erts_smp_atomic_init(&meta_pid_to_tab->common.nitems, 0); + meta_pid_to_tab->common.slot = -1; + meta_pid_to_tab->common.meth = &db_hash; + + erts_refc_init(&meta_pid_to_tab->common.ref, 1); + erts_refc_init(&meta_pid_to_tab->common.fixref, 0); + /* Neither rwlock or fixlock used + db_init_lock(meta_pid_to_tab, "meta_pid_to_tab", "meta_pid_to_tab_FIX");*/ + + if (db_create_hash(NULL, meta_pid_to_tab) != DB_ERROR_NONE) { + erl_exit(1,"Unable to create ets metadata tables."); + } + + erts_smp_atomic_set(&init_tb.common.memory_size, 0); + meta_pid_to_fixed_tab = (DbTable*) erts_db_alloc(ERTS_ALC_T_DB_TABLE, + &init_tb, + sizeof(DbTable)); + ERTS_ETS_MISC_MEM_ADD(sizeof(DbTable)); + erts_smp_atomic_init(&meta_pid_to_fixed_tab->common.memory_size, + erts_smp_atomic_read(&init_tb.common.memory_size)); + + meta_pid_to_fixed_tab->common.id = NIL; + meta_pid_to_fixed_tab->common.the_name = am_true; + meta_pid_to_fixed_tab->common.status = (DB_NORMAL | DB_BAG | DB_PUBLIC | DB_FINE_LOCKED); +#ifdef ERTS_SMP + meta_pid_to_fixed_tab->common.type + = meta_pid_to_fixed_tab->common.status & ERTS_ETS_TABLE_TYPES; + /* Note, 'type' is *read only* from now on... */ + meta_pid_to_fixed_tab->common.is_thread_safe = 0; +#endif + meta_pid_to_fixed_tab->common.keypos = 1; + meta_pid_to_fixed_tab->common.owner = NIL; + erts_smp_atomic_init(&meta_pid_to_fixed_tab->common.nitems, 0); + meta_pid_to_fixed_tab->common.slot = -1; + meta_pid_to_fixed_tab->common.meth = &db_hash; + + erts_refc_init(&meta_pid_to_fixed_tab->common.ref, 1); + erts_refc_init(&meta_pid_to_fixed_tab->common.fixref, 0); + /* Neither rwlock or fixlock used + db_init_lock(meta_pid_to_fixed_tab, "meta_pid_to_fixed_tab", "meta_pid_to_fixed_tab_FIX");*/ + + if (db_create_hash(NULL, meta_pid_to_fixed_tab) != DB_ERROR_NONE) { + erl_exit(1,"Unable to create ets metadata tables."); + } + + /* Non visual BIF to trap to. */ + memset(&ets_select_delete_continue_exp, 0, sizeof(Export)); + ets_select_delete_continue_exp.address = + &ets_select_delete_continue_exp.code[3]; + ets_select_delete_continue_exp.code[0] = am_ets; + ets_select_delete_continue_exp.code[1] = am_atom_put("delete_trap",11); + ets_select_delete_continue_exp.code[2] = 1; + ets_select_delete_continue_exp.code[3] = + (Eterm) em_apply_bif; + ets_select_delete_continue_exp.code[4] = + (Eterm) &ets_select_delete_1; + + /* Non visual BIF to trap to. */ + memset(&ets_select_count_continue_exp, 0, sizeof(Export)); + ets_select_count_continue_exp.address = + &ets_select_count_continue_exp.code[3]; + ets_select_count_continue_exp.code[0] = am_ets; + ets_select_count_continue_exp.code[1] = am_atom_put("count_trap",11); + ets_select_count_continue_exp.code[2] = 1; + ets_select_count_continue_exp.code[3] = + (Eterm) em_apply_bif; + ets_select_count_continue_exp.code[4] = + (Eterm) &ets_select_count_1; + + /* Non visual BIF to trap to. */ + memset(&ets_select_continue_exp, 0, sizeof(Export)); + ets_select_continue_exp.address = + &ets_select_continue_exp.code[3]; + ets_select_continue_exp.code[0] = am_ets; + ets_select_continue_exp.code[1] = am_atom_put("select_trap",11); + ets_select_continue_exp.code[2] = 1; + ets_select_continue_exp.code[3] = + (Eterm) em_apply_bif; + ets_select_continue_exp.code[4] = + (Eterm) &ets_select_trap_1; + + /* Non visual BIF to trap to. */ + memset(&ets_delete_continue_exp, 0, sizeof(Export)); + ets_delete_continue_exp.address = &ets_delete_continue_exp.code[3]; + ets_delete_continue_exp.code[0] = am_ets; + ets_delete_continue_exp.code[1] = am_atom_put("delete_trap",11); + ets_delete_continue_exp.code[2] = 1; + ets_delete_continue_exp.code[3] = (Eterm) em_apply_bif; + ets_delete_continue_exp.code[4] = (Eterm) &ets_delete_trap; + + hp = ms_delete_all_buff; + ms_delete_all = CONS(hp, am_true, NIL); + hp += 2; + ms_delete_all = TUPLE3(hp,am_Underscore,NIL,ms_delete_all); + hp +=4; + ms_delete_all = CONS(hp, ms_delete_all,NIL); +} + +#define ARRAY_CHUNK 100 + +typedef enum { + ErtsDbProcCleanupProgressTables, + ErtsDbProcCleanupProgressFixations, + ErtsDbProcCleanupProgressDone, +} ErtsDbProcCleanupProgress; + +typedef enum { + ErtsDbProcCleanupOpGetTables, + ErtsDbProcCleanupOpDeleteTables, + ErtsDbProcCleanupOpGetFixations, + ErtsDbProcCleanupOpDeleteFixations, + ErtsDbProcCleanupOpDone +} ErtsDbProcCleanupOperation; + +typedef struct { + ErtsDbProcCleanupProgress progress; + ErtsDbProcCleanupOperation op; + struct { + Eterm arr[ARRAY_CHUNK]; + int size; + int ix; + int clean_ix; + } slots; +} ErtsDbProcCleanupState; + + +static void +proc_exit_cleanup_tables_meta_data(Eterm pid, ErtsDbProcCleanupState *state) +{ + ASSERT(state->slots.clean_ix <= state->slots.ix); + if (state->slots.clean_ix < state->slots.ix) { + db_meta_lock(meta_pid_to_tab, LCK_WRITE_REC); + if (state->slots.size < ARRAY_CHUNK + && state->slots.ix == state->slots.size) { + Eterm dummy; + db_erase_hash(meta_pid_to_tab,pid,&dummy); + } + else { + int ix; + /* Need to erase each explicitly */ + for (ix = state->slots.clean_ix; ix < state->slots.ix; ix++) + db_erase_bag_exact2(meta_pid_to_tab, + pid, + state->slots.arr[ix]); + } + db_meta_unlock(meta_pid_to_tab, LCK_WRITE_REC); + state->slots.clean_ix = state->slots.ix; + } +} + +static void +proc_exit_cleanup_fixations_meta_data(Eterm pid, ErtsDbProcCleanupState *state) +{ + ASSERT(state->slots.clean_ix <= state->slots.ix); + if (state->slots.clean_ix < state->slots.ix) { + db_meta_lock(meta_pid_to_fixed_tab, LCK_WRITE_REC); + if (state->slots.size < ARRAY_CHUNK + && state->slots.ix == state->slots.size) { + Eterm dummy; + db_erase_hash(meta_pid_to_fixed_tab,pid,&dummy); + } + else { + int ix; + /* Need to erase each explicitly */ + for (ix = state->slots.clean_ix; ix < state->slots.ix; ix++) + db_erase_bag_exact2(meta_pid_to_fixed_tab, + pid, + state->slots.arr[ix]); + } + db_meta_unlock(meta_pid_to_fixed_tab, LCK_WRITE_REC); + state->slots.clean_ix = state->slots.ix; + } +} + +/* In: Table LCK_WRITE +** Return TRUE : ok, table not mine and NOT locked anymore. +** Return FALSE: failed, table still mine (LCK_WRITE) +*/ +static int give_away_to_heir(Process* p, DbTable* tb) +{ + Process* to_proc; + ErtsProcLocks to_locks = ERTS_PROC_LOCK_MAIN; + Eterm buf[5]; + Eterm to_pid; + Eterm heir_data; + + ASSERT(tb->common.owner == p->id); + ASSERT(is_internal_pid(tb->common.heir)); + ASSERT(tb->common.heir != p->id); +retry: + to_pid = tb->common.heir; + to_proc = erts_pid2proc_opt(p, ERTS_PROC_LOCK_MAIN, + to_pid, to_locks, + ERTS_P2P_FLG_TRY_LOCK); + if (to_proc == ERTS_PROC_LOCK_BUSY) { + db_ref(tb); /* while unlocked */ + db_unlock(tb,LCK_WRITE); + to_proc = erts_pid2proc(p, ERTS_PROC_LOCK_MAIN, + to_pid, to_locks); + db_lock(tb,LCK_WRITE); + tb = db_unref(tb); + ASSERT(tb != NULL); + + if (tb->common.owner != p->id) { + if (to_proc != NULL ) { + erts_smp_proc_unlock(to_proc, to_locks); + } + db_unlock(tb,LCK_WRITE); + return !0; /* ok, someone already gave my table away */ + } + if (tb->common.heir != to_pid) { /* someone changed the heir */ + if (to_proc != NULL ) { + erts_smp_proc_unlock(to_proc, to_locks); + } + if (to_pid == p->id || to_pid == am_none) { + return 0; /* no real heir, table still mine */ + } + goto retry; + } + } + if (to_proc == NULL) { + return 0; /* heir not alive, table still mine */ + } + if (erts_cmp_timeval(&to_proc->started, &tb->common.heir_started) != 0) { + erts_smp_proc_unlock(to_proc, to_locks); + return 0; /* heir dead and pid reused, table still mine */ + } + db_meta_lock(meta_pid_to_tab, LCK_WRITE_REC); + db_erase_bag_exact2(meta_pid_to_tab, tb->common.owner, + make_small(tb->common.slot)); + + to_proc->flags |= F_USING_DB; + tb->common.owner = to_pid; + + db_put_hash(meta_pid_to_tab, + TUPLE2(buf,to_pid,make_small(tb->common.slot)), + 0); + db_meta_unlock(meta_pid_to_tab, LCK_WRITE_REC); + + db_unlock(tb,LCK_WRITE); + heir_data = tb->common.heir_data; + if (!is_immed(heir_data)) { + Eterm* tpv = DBTERM_BUF((DbTerm*)heir_data); /* tuple_val */ + ASSERT(arityval(*tpv) == 1); + heir_data = tpv[1]; + } + erts_send_message(p, to_proc, &to_locks, + TUPLE4(buf, am_ETS_TRANSFER, tb->common.id, p->id, heir_data), + 0); + erts_smp_proc_unlock(to_proc, to_locks); + return !0; +} + +/* + * erts_db_process_exiting() is called when a process terminates. + * It returns 0 when completely done, and !0 when it wants to + * yield. c_p->u.exit_data can hold a pointer to a state while + * yielding. + */ +#define ERTS_DB_INTERNAL_ERROR(LSTR) \ + erl_exit(ERTS_ABORT_EXIT, "%s:%d:erts_db_process_exiting(): " LSTR "\n", \ + __FILE__, __LINE__) + +int +erts_db_process_exiting(Process *c_p, ErtsProcLocks c_p_locks) +{ + ErtsDbProcCleanupState *state = (ErtsDbProcCleanupState *) c_p->u.exit_data; + Eterm pid = c_p->id; + ErtsDbProcCleanupState default_state; + int ret; + + if (!state) { + state = &default_state; + state->progress = ErtsDbProcCleanupProgressTables; + state->op = ErtsDbProcCleanupOpGetTables; + } + + while (!0) { + switch (state->op) { + case ErtsDbProcCleanupOpGetTables: + state->slots.size = ARRAY_CHUNK; + db_meta_lock(meta_pid_to_tab, LCK_READ); + ret = db_get_element_array(meta_pid_to_tab, + pid, + 2, + state->slots.arr, + &state->slots.size); + db_meta_unlock(meta_pid_to_tab, LCK_READ); + if (ret == DB_ERROR_BADKEY) { + /* Done with tables; now fixations */ + state->progress = ErtsDbProcCleanupProgressFixations; + state->op = ErtsDbProcCleanupOpGetFixations; + break; + } else if (ret != DB_ERROR_NONE) { + ERTS_DB_INTERNAL_ERROR("Inconsistent ets table metadata"); + } + + state->slots.ix = 0; + state->slots.clean_ix = 0; + state->op = ErtsDbProcCleanupOpDeleteTables; + /* Fall through */ + + case ErtsDbProcCleanupOpDeleteTables: + + while (state->slots.ix < state->slots.size) { + DbTable *tb = NULL; + Sint ix = unsigned_val(state->slots.arr[state->slots.ix]); + meta_main_tab_lock(ix); + if (!IS_SLOT_FREE(ix)) { + tb = db_ref(GET_ANY_SLOT_TAB(ix)); + ASSERT(tb); + } + meta_main_tab_unlock(ix); + if (tb) { + int do_yield; + db_lock_take_over_ref(tb, LCK_WRITE); + /* Ownership may have changed since + we looked up the table. */ + if (tb->common.owner != pid) { + do_yield = 0; + db_unlock(tb, LCK_WRITE); + } + else if (tb->common.heir != am_none + && tb->common.heir != pid + && give_away_to_heir(c_p, tb)) { + do_yield = 0; + } + else { + int first_call; +#ifdef HARDDEBUG + erts_fprintf(stderr, + "erts_db_process_exiting(); Table: %T, " + "Process: %T\n", + tb->common.id, pid); +#endif + first_call = (tb->common.status & DB_DELETE) == 0; + if (first_call) { + /* Clear all access bits. */ + tb->common.status &= ~(DB_PROTECTED + | DB_PUBLIC + | DB_PRIVATE); + tb->common.status |= DB_DELETE; + + if (is_atom(tb->common.id)) + remove_named_tab(tb->common.id); + + free_heir_data(tb); + free_fixations_locked(tb); + } + + do_yield = free_table_cont(c_p, tb, first_call, 0); + db_unlock(tb, LCK_WRITE); + } + if (do_yield) + goto yield; + } + state->slots.ix++; + if (ERTS_BIF_REDS_LEFT(c_p) <= 0) + goto yield; + } + + proc_exit_cleanup_tables_meta_data(pid, state); + state->op = ErtsDbProcCleanupOpGetTables; + break; + + case ErtsDbProcCleanupOpGetFixations: + state->slots.size = ARRAY_CHUNK; + db_meta_lock(meta_pid_to_fixed_tab, LCK_READ); + ret = db_get_element_array(meta_pid_to_fixed_tab, + pid, + 2, + state->slots.arr, + &state->slots.size); + db_meta_unlock(meta_pid_to_fixed_tab, LCK_READ); + + if (ret == DB_ERROR_BADKEY) { + /* Done */ + state->progress = ErtsDbProcCleanupProgressDone; + state->op = ErtsDbProcCleanupOpDone; + break; + } else if (ret != DB_ERROR_NONE) { + ERTS_DB_INTERNAL_ERROR("Inconsistent ets fix table metadata"); + } + + state->slots.ix = 0; + state->slots.clean_ix = 0; + state->op = ErtsDbProcCleanupOpDeleteFixations; + /* Fall through */ + + case ErtsDbProcCleanupOpDeleteFixations: + + while (state->slots.ix < state->slots.size) { + DbTable *tb = NULL; + Sint ix = unsigned_val(state->slots.arr[state->slots.ix]); + meta_main_tab_lock(ix); + if (IS_SLOT_ALIVE(ix)) { + tb = db_ref(meta_main_tab[ix].u.tb); + ASSERT(tb); + } + meta_main_tab_unlock(ix); + if (tb) { + int reds; + DbFixation** pp; + + db_lock_take_over_ref(tb, LCK_WRITE_REC); + #ifdef ERTS_SMP + erts_smp_mtx_lock(&tb->common.fixlock); + #endif + reds = 10; + + for (pp = &tb->common.fixations; *pp != NULL; + pp = &(*pp)->next) { + if ((*pp)->pid == pid) { + DbFixation* fix = *pp; + erts_refc_add(&tb->common.fixref,-fix->counter,0); + *pp = fix->next; + erts_db_free(ERTS_ALC_T_DB_FIXATION, + tb, fix, sizeof(DbFixation)); + ERTS_ETS_MISC_MEM_ADD(-sizeof(DbFixation)); + break; + } + } + #ifdef ERTS_SMP + erts_smp_mtx_unlock(&tb->common.fixlock); + #endif + if (!IS_FIXED(tb) && IS_HASH_TABLE(tb->common.status)) { + db_unfix_table_hash(&(tb->hash)); + reds += 40; + } + db_unlock(tb, LCK_WRITE_REC); + BUMP_REDS(c_p, reds); + } + state->slots.ix++; + if (ERTS_BIF_REDS_LEFT(c_p) <= 0) + goto yield; + } + + proc_exit_cleanup_fixations_meta_data(pid, state); + state->op = ErtsDbProcCleanupOpGetFixations; + break; + + case ErtsDbProcCleanupOpDone: + + if (state != &default_state) + erts_free(ERTS_ALC_T_DB_PROC_CLEANUP, state); + c_p->u.exit_data = NULL; + return 0; + + default: + ERTS_DB_INTERNAL_ERROR("Bad internal state"); + } + } + + yield: + + switch (state->progress) { + case ErtsDbProcCleanupProgressTables: + proc_exit_cleanup_tables_meta_data(pid, state); + break; + case ErtsDbProcCleanupProgressFixations: + proc_exit_cleanup_fixations_meta_data(pid, state); + break; + default: + break; + } + + ASSERT(c_p->u.exit_data == (void *) state + || state == &default_state); + + if (state == &default_state) { + c_p->u.exit_data = erts_alloc(ERTS_ALC_T_DB_PROC_CLEANUP, + sizeof(ErtsDbProcCleanupState)); + sys_memcpy(c_p->u.exit_data, + (void*) state, + sizeof(ErtsDbProcCleanupState)); + } + + return !0; +} + +/* SMP note: table only need to be LCK_READ locked */ +static void fix_table_locked(Process* p, DbTable* tb) +{ + DbFixation *fix; + Eterm meta_tuple[3]; + +#ifdef ERTS_SMP + erts_smp_mtx_lock(&tb->common.fixlock); +#endif + erts_refc_inc(&tb->common.fixref,1); + fix = tb->common.fixations; + if (fix == NULL) { + get_now(&(tb->common.megasec), + &(tb->common.sec), + &(tb->common.microsec)); + } + else { + for (; fix != NULL; fix = fix->next) { + if (fix->pid == p->id) { + ++(fix->counter); +#ifdef ERTS_SMP + erts_smp_mtx_unlock(&tb->common.fixlock); +#endif + return; + } + } + } + fix = (DbFixation *) erts_db_alloc(ERTS_ALC_T_DB_FIXATION, + tb, sizeof(DbFixation)); + ERTS_ETS_MISC_MEM_ADD(sizeof(DbFixation)); + fix->pid = p->id; + fix->counter = 1; + fix->next = tb->common.fixations; + tb->common.fixations = fix; +#ifdef ERTS_SMP + erts_smp_mtx_unlock(&tb->common.fixlock); +#endif + p->flags |= F_USING_DB; + db_meta_lock(meta_pid_to_fixed_tab, LCK_WRITE_REC); + if (db_put_hash(meta_pid_to_fixed_tab, + TUPLE2(meta_tuple, p->id, make_small(tb->common.slot)), + 0) != DB_ERROR_NONE) { + erl_exit(1,"Could not insert ets metadata in safe_fixtable."); + } + db_meta_unlock(meta_pid_to_fixed_tab, LCK_WRITE_REC); +} + +/* SMP note: May re-lock table +*/ +static void unfix_table_locked(Process* p, DbTable* tb, + db_lock_kind_t* kind_p) +{ + DbFixation** pp; + +#ifdef ERTS_SMP + erts_smp_mtx_lock(&tb->common.fixlock); +#endif + for (pp = &tb->common.fixations; *pp != NULL; pp = &(*pp)->next) { + if ((*pp)->pid == p->id) { + DbFixation* fix = *pp; + erts_refc_dec(&tb->common.fixref,0); + --(fix->counter); + ASSERT(fix->counter >= 0); + if (fix->counter > 0) { + break; + } + *pp = fix->next; +#ifdef ERTS_SMP + erts_smp_mtx_unlock(&tb->common.fixlock); +#endif + db_meta_lock(meta_pid_to_fixed_tab, LCK_WRITE_REC); + db_erase_bag_exact2(meta_pid_to_fixed_tab, + p->id, make_small(tb->common.slot)); + db_meta_unlock(meta_pid_to_fixed_tab, LCK_WRITE_REC); + erts_db_free(ERTS_ALC_T_DB_FIXATION, + tb, (void *) fix, sizeof(DbFixation)); + ERTS_ETS_MISC_MEM_ADD(-sizeof(DbFixation)); + goto unlocked; + } + } +#ifdef ERTS_SMP + erts_smp_mtx_unlock(&tb->common.fixlock); +#endif +unlocked: + + if (!IS_FIXED(tb) && IS_HASH_TABLE(tb->common.status) + && erts_smp_atomic_read(&tb->hash.fixdel) != (long)NULL) { +#ifdef ERTS_SMP + if (*kind_p == LCK_READ && tb->common.is_thread_safe) { + /* Must have write lock while purging pseudo-deleted (OTP-8166) */ + erts_smp_rwmtx_runlock(&tb->common.rwlock); + erts_smp_rwmtx_rwlock(&tb->common.rwlock); + *kind_p = LCK_WRITE; + if (tb->common.status & DB_DELETE) return; + } +#endif + db_unfix_table_hash(&(tb->hash)); + } +} + +/* Assume that tb is WRITE locked */ +static void free_fixations_locked(DbTable *tb) +{ + DbFixation *fix; + DbFixation *next_fix; + + fix = tb->common.fixations; + while (fix != NULL) { + next_fix = fix->next; + db_meta_lock(meta_pid_to_fixed_tab, LCK_WRITE_REC); + db_erase_bag_exact2(meta_pid_to_fixed_tab, + fix->pid, + make_small(tb->common.slot)); + db_meta_unlock(meta_pid_to_fixed_tab, LCK_WRITE_REC); + erts_db_free(ERTS_ALC_T_DB_FIXATION, + tb, (void *) fix, sizeof(DbFixation)); + ERTS_ETS_MISC_MEM_ADD(-sizeof(DbFixation)); + + fix = next_fix; + } + tb->common.fixations = NULL; +} + +static void set_heir(Process* me, DbTable* tb, Eterm heir, Eterm heir_data) +{ + tb->common.heir = heir; + if (heir == am_none) { + return; + } + if (heir == me->id) { + tb->common.heir_started = me->started; + } + else { + Process* heir_proc= erts_pid2proc_opt(me, ERTS_PROC_LOCK_MAIN, heir, + 0, ERTS_P2P_FLG_SMP_INC_REFC); + if (heir_proc != NULL) { + tb->common.heir_started = heir_proc->started; + erts_smp_proc_dec_refc(heir_proc); + } else { + tb->common.heir = am_none; + } + } + + if (!is_immed(heir_data)) { + Eterm tmp[2]; + /* Make a dummy 1-tuple around data to use db_get_term() */ + heir_data = (Eterm) db_get_term(&tb->common, NULL, 0, + TUPLE1(tmp,heir_data)); + ASSERT(!is_immed(heir_data)); + } + tb->common.heir_data = heir_data; +} + +static void free_heir_data(DbTable* tb) +{ + if (tb->common.heir != am_none && !is_immed(tb->common.heir_data)) { + DbTerm* p = (DbTerm*) tb->common.heir_data; + db_free_term_data(p); + erts_db_free(ERTS_ALC_T_DB_TERM, tb, (void *)p, + sizeof(DbTerm) + (p->size-1)*sizeof(Eterm)); + } + #ifdef DEBUG + tb->common.heir_data = am_undefined; + #endif +} + +static BIF_RETTYPE ets_delete_trap(Process *p, Eterm cont) +{ + int trap; + Eterm* ptr = big_val(cont); + DbTable *tb = (DbTable *) ptr[1]; + + ASSERT(*ptr == make_pos_bignum_header(1)); + + db_lock(tb, LCK_WRITE); + trap = free_table_cont(p, tb, 0, 1); + db_unlock(tb, LCK_WRITE); + + if (trap) { + BIF_TRAP1(&ets_delete_continue_exp, p, cont); + } + else { + BIF_RET(am_true); + } +} + + +/* + * free_table_cont() returns 0 when done and !0 when more work is needed. + */ +static int free_table_cont(Process *p, + DbTable *tb, + int first, + int clean_meta_tab) +{ + Eterm result; + +#ifdef HARDDEBUG + if (!first) { + erts_fprintf(stderr,"ets: free_table_cont %T (continue)\r\n", + tb->common.id); + } +#endif + + result = tb->common.meth->db_free_table_continue(tb); + + if (result == 0) { +#ifdef HARDDEBUG + erts_fprintf(stderr,"ets: free_table_cont %T (continue begin)\r\n", + tb->common.id); +#endif + /* More work to be done. Let other processes work and call us again. */ + BUMP_ALL_REDS(p); + return !0; + } + else { +#ifdef HARDDEBUG + erts_fprintf(stderr,"ets: free_table_cont %T (continue end)\r\n", + tb->common.id); +#endif + /* Completely done - we will not get called again. */ + meta_main_tab_lock(tb->common.slot); + free_slot(tb->common.slot); + meta_main_tab_unlock(tb->common.slot); + + if (clean_meta_tab) { + db_meta_lock(meta_pid_to_tab, LCK_WRITE_REC); + db_erase_bag_exact2(meta_pid_to_tab,tb->common.owner, + make_small(tb->common.slot)); + db_meta_unlock(meta_pid_to_tab, LCK_WRITE_REC); + } + db_unref(tb); + BUMP_REDS(p, 100); + return 0; + } +} + +static Eterm table_info(Process* p, DbTable* tb, Eterm What) +{ + Eterm ret = THE_NON_VALUE; + + if (What == am_size) { + ret = make_small(erts_smp_atomic_read(&tb->common.nitems)); + } else if (What == am_type) { + if (tb->common.status & DB_SET) { + ret = am_set; + } else if (tb->common.status & DB_DUPLICATE_BAG) { + ret = am_duplicate_bag; + } else if (tb->common.status & DB_ORDERED_SET) { + ret = am_ordered_set; + } else { /*TT*/ + ASSERT(tb->common.status & DB_BAG); + ret = am_bag; + } + } else if (What == am_memory) { + Uint words = (Uint) ((erts_smp_atomic_read(&tb->common.memory_size) + + sizeof(Uint) + - 1) + / sizeof(Uint)); + ret = erts_make_integer(words, p); + } else if (What == am_owner) { + ret = tb->common.owner; + } else if (What == am_heir) { + ret = tb->common.heir; + } else if (What == am_protection) { + if (tb->common.status & DB_PRIVATE) + ret = am_private; + else if (tb->common.status & DB_PROTECTED) + ret = am_protected; + else if (tb->common.status & DB_PUBLIC) + ret = am_public; + } else if (What == am_name) { + ret = tb->common.the_name; + } else if (What == am_keypos) { + ret = make_small(tb->common.keypos); + } else if (What == am_node) { + ret = erts_this_dist_entry->sysname; + } else if (What == am_named_table) { + ret = is_atom(tb->common.id) ? am_true : am_false; + /* + * For debugging purposes + */ + } else if (What == am_data) { + print_table(ERTS_PRINT_STDOUT, NULL, 1, tb); + ret = am_true; + } else if (What == am_atom_put("fixed",5)) { + if (IS_FIXED(tb)) + ret = am_true; + else + ret = am_false; + } else if (What == am_atom_put("kept_objects",12)) { + ret = make_small(IS_HASH_TABLE(tb->common.status) + ? db_kept_items_hash(&tb->hash) : 0); + } else if (What == am_atom_put("safe_fixed",10)) { +#ifdef ERTS_SMP + erts_smp_mtx_lock(&tb->common.fixlock); +#endif + if (IS_FIXED(tb)) { + Uint need; + Eterm *hp; + Eterm tpl, lst; + DbFixation *fix; + need = 7; + for (fix = tb->common.fixations; fix != NULL; fix = fix->next) { + need += 5; + } + hp = HAlloc(p, need); + lst = NIL; + for (fix = tb->common.fixations; fix != NULL; fix = fix->next) { + tpl = TUPLE2(hp,fix->pid,make_small(fix->counter)); + hp += 3; + lst = CONS(hp,tpl,lst); + hp += 2; + } + tpl = TUPLE3(hp, + make_small(tb->common.megasec), + make_small(tb->common.sec), + make_small(tb->common.microsec)); + hp += 4; + ret = TUPLE2(hp, tpl, lst); + } else { + ret = am_false; + } +#ifdef ERTS_SMP + erts_smp_mtx_unlock(&tb->common.fixlock); +#endif + } else if (What == am_atom_put("stats",5)) { + if (IS_HASH_TABLE(tb->common.status)) { + FloatDef f; + DbHashStats stats; + Eterm avg, std_dev_real, std_dev_exp; + Eterm* hp; + + db_calc_stats_hash(&tb->hash, &stats); + hp = HAlloc(p, 1 + 6 + FLOAT_SIZE_OBJECT*3); + f.fd = stats.avg_chain_len; + avg = make_float(hp); + PUT_DOUBLE(f, hp); + hp += FLOAT_SIZE_OBJECT; + + f.fd = stats.std_dev_chain_len; + std_dev_real = make_float(hp); + PUT_DOUBLE(f, hp); + hp += FLOAT_SIZE_OBJECT; + + f.fd = stats.std_dev_expected; + std_dev_exp = make_float(hp); + PUT_DOUBLE(f, hp); + hp += FLOAT_SIZE_OBJECT; + ret = TUPLE6(hp, make_small(erts_smp_atomic_read(&tb->hash.nactive)), + avg, std_dev_real, std_dev_exp, + make_small(stats.min_chain_len), + make_small(stats.max_chain_len)); + } + else { + ret = am_false; + } + } + return ret; +} + +static void print_table(int to, void *to_arg, int show, DbTable* tb) +{ + erts_print(to, to_arg, "Table: %T\n", tb->common.id); + erts_print(to, to_arg, "Name: %T\n", tb->common.the_name); + + tb->common.meth->db_print(to, to_arg, show, tb); + + erts_print(to, to_arg, "Objects: %d\n", (int)erts_smp_atomic_read(&tb->common.nitems)); + erts_print(to, to_arg, "Words: %bpu\n", + (Uint) ((erts_smp_atomic_read(&tb->common.memory_size) + + sizeof(Uint) + - 1) + / sizeof(Uint))); +} + +void db_info(int to, void *to_arg, int show) /* Called by break handler */ +{ + int i; + for (i=0; i < db_max_tabs; i++) + if (IS_SLOT_ALIVE(i)) { + erts_print(to, to_arg, "=ets:%T\n", meta_main_tab[i].u.tb->common.owner); + erts_print(to, to_arg, "Slot: %d\n", i); + print_table(to, to_arg, show, meta_main_tab[i].u.tb); + } +#ifdef DEBUG + erts_print(to, to_arg, "=internal_ets: Process to table index\n"); + print_table(to, to_arg, show, meta_pid_to_tab); + erts_print(to, to_arg, "=internal_ets: Process to fixation index\n"); + print_table(to, to_arg, show, meta_pid_to_fixed_tab); +#endif +} + +Uint +erts_get_ets_misc_mem_size(void) +{ + /* Memory not allocated in ets_alloc */ + return (Uint) erts_smp_atomic_read(&erts_ets_misc_mem_size); +} + +/* SMP Note: May only be used when system is locked */ +void +erts_db_foreach_table(void (*func)(DbTable *, void *), void *arg) +{ + int i, j; + j = 0; + for(i = 0; (i < db_max_tabs && j < meta_main_tab_cnt); i++) { + if (IS_SLOT_ALIVE(i)) { + j++; + (*func)(meta_main_tab[i].u.tb, arg); + } + } + ASSERT(j == meta_main_tab_cnt); +} + +/* SMP Note: May only be used when system is locked */ +void +erts_db_foreach_offheap(DbTable *tb, + void (*func)(ErlOffHeap *, void *), + void *arg) +{ + tb->common.meth->db_foreach_offheap(tb, func, arg); +} + +/* + * For testing of meta tables only. + * + * Given a name atom (as returned from ets:new/2), return a list of 'cnt' + * number of other names that will hash to the same bucket in meta_name_tab. + * + * WARNING: Will bloat the atom table! + */ +Eterm +erts_ets_colliding_names(Process* p, Eterm name, Uint cnt) +{ + Eterm list = NIL; + Eterm* hp = HAlloc(p,cnt*2); + Uint index = atom_val(name) & meta_name_tab_mask; + + while (cnt) { + if (index != atom_val(name)) { + while (index >= atom_table_size()) { + char tmp[20]; + erts_snprintf(tmp, sizeof(tmp), "am%x", atom_table_size()); + am_atom_put(tmp,strlen(tmp)); + } + list = CONS(hp, make_atom(index), list); + hp += 2; + --cnt; + } + index += meta_name_tab_mask + 1; + } + return list; +} + + +#ifdef HARDDEBUG /* Here comes some debug functions */ + +void db_check_tables(void) +{ +#ifdef ERTS_SMP + return; +#else + int i; + + for (i = 0; i < db_max_tabs; i++) { + if (IS_SLOT_ALIVE(i)) { + DbTable* tb = meta_main_tab[i].t; + tb->common.meth->db_check_table(tb); + } + } +#endif +} + +#endif /* HARDDEBUG */ diff --git a/erts/emulator/beam/erl_db.h b/erts/emulator/beam/erl_db.h new file mode 100644 index 0000000000..7da28fad29 --- /dev/null +++ b/erts/emulator/beam/erl_db.h @@ -0,0 +1,247 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* + * This file now contains only the definitions needed for the + * meta table. + * + */ + +#ifndef __DB_H__ +#define __DB_H__ + +#include "sys.h" +#include "bif.h" + +#include "erl_db_util.h" /* Flags */ +#include "erl_db_hash.h" /* DbTableHash */ +#include "erl_db_tree.h" /* DbTableTree */ +/*TT*/ + +Uint erts_get_ets_misc_mem_size(void); + +/* + * So, the structure for a database table, NB this is only + * interesting in db.c. + */ +union db_table { + DbTableCommon common; /* Any type of db table */ + DbTableHash hash; /* Linear hash array specific data */ + DbTableTree tree; /* AVL tree specific data */ + /*TT*/ +}; + +#define DB_DEF_MAX_TABS 2053 /* Superseeded by environment variable + "ERL_MAX_ETS_TABLES" */ +#define ERL_MAX_ETS_TABLES_ENV "ERL_MAX_ETS_TABLES" + +void init_db(void); +int erts_db_process_exiting(Process *, ErtsProcLocks); +void db_info(int, void *, int); +void erts_db_foreach_table(void (*)(DbTable *, void *), void *); +void erts_db_foreach_offheap(DbTable *, + void (*func)(ErlOffHeap *, void *), + void *); + +extern int user_requested_db_max_tabs; /* set in erl_init */ +extern int erts_ets_realloc_always_moves; /* set in erl_init */ +extern Export ets_select_delete_continue_exp; +extern Export ets_select_count_continue_exp; +extern Export ets_select_continue_exp; +extern erts_smp_atomic_t erts_ets_misc_mem_size; + +Eterm erts_ets_colliding_names(Process*, Eterm name, Uint cnt); + +#endif + +#if defined(ERTS_WANT_DB_INTERNAL__) && !defined(ERTS_HAVE_DB_INTERNAL__) +#define ERTS_HAVE_DB_INTERNAL__ + +#include "erl_alloc.h" + +/* + * _fnf : Failure Not Fatal (same as for erts_alloc/erts_realloc/erts_free) + * _nt : No Table (i.e. memory not associated with a specific table) + */ + +#define ERTS_DB_ALC_MEM_UPDATE_(TAB, FREE_SZ, ALLOC_SZ) \ +do { \ + long sz__ = ((long) (ALLOC_SZ)) - ((long) (FREE_SZ)); \ + ASSERT((TAB)); \ + erts_smp_atomic_add(&(TAB)->common.memory_size, sz__); \ +} while (0) + +#define ERTS_ETS_MISC_MEM_ADD(SZ) \ + erts_smp_atomic_add(&erts_ets_misc_mem_size, (SZ)); + +ERTS_GLB_INLINE void *erts_db_alloc(ErtsAlcType_t type, + DbTable *tab, + Uint size); +ERTS_GLB_INLINE void *erts_db_alloc_fnf(ErtsAlcType_t type, + DbTable *tab, + Uint size); +ERTS_GLB_INLINE void *erts_db_alloc_nt(ErtsAlcType_t type, Uint size); +ERTS_GLB_INLINE void *erts_db_alloc_fnf_nt(ErtsAlcType_t type, Uint size); + +#if ERTS_GLB_INLINE_INCL_FUNC_DEF + +ERTS_GLB_INLINE void * +erts_db_alloc(ErtsAlcType_t type, DbTable *tab, Uint size) +{ + void *res = erts_alloc(type, size); + ERTS_DB_ALC_MEM_UPDATE_(tab, 0, size); + return res; +} + +ERTS_GLB_INLINE void * +erts_db_alloc_fnf(ErtsAlcType_t type, DbTable *tab, Uint size) +{ + void *res = erts_alloc_fnf(type, size); + if (!res) + return NULL; + ERTS_DB_ALC_MEM_UPDATE_(tab, 0, size); + return res; +} + +ERTS_GLB_INLINE void * +erts_db_alloc_nt(ErtsAlcType_t type, Uint size) +{ + void *res = erts_alloc(type, size); + return res; +} + +ERTS_GLB_INLINE void * +erts_db_alloc_fnf_nt(ErtsAlcType_t type, Uint size) +{ + void *res = erts_alloc_fnf(type, size); + if (!res) + return NULL; + return res; +} + +#endif /* #if ERTS_GLB_INLINE_INCL_FUNC_DEF */ + +ERTS_GLB_INLINE void *erts_db_realloc(ErtsAlcType_t type, + DbTable *tab, + void *ptr, + Uint old_size, + Uint size); +ERTS_GLB_INLINE void *erts_db_realloc_fnf(ErtsAlcType_t type, + DbTable *tab, + void *ptr, + Uint old_size, + Uint size); +ERTS_GLB_INLINE void *erts_db_realloc_nt(ErtsAlcType_t type, + void *ptr, + Uint old_size, + Uint size); +ERTS_GLB_INLINE void *erts_db_realloc_fnf_nt(ErtsAlcType_t type, + void *ptr, + Uint old_size, + Uint size); + +#if ERTS_GLB_INLINE_INCL_FUNC_DEF + +ERTS_GLB_INLINE void * +erts_db_realloc(ErtsAlcType_t type, DbTable *tab, void *ptr, + Uint old_size, Uint size) +{ + void *res; + ASSERT(!ptr || old_size == ERTS_ALC_DBG_BLK_SZ(ptr)); + res = erts_realloc(type, ptr, size); + ERTS_DB_ALC_MEM_UPDATE_(tab, old_size, size); + return res; +} + +ERTS_GLB_INLINE void * +erts_db_realloc_fnf(ErtsAlcType_t type, DbTable *tab, void *ptr, + Uint old_size, Uint size) +{ + void *res; + ASSERT(!ptr || old_size == ERTS_ALC_DBG_BLK_SZ(ptr)); + res = erts_realloc_fnf(type, ptr, size); + if (!res) + return NULL; + ERTS_DB_ALC_MEM_UPDATE_(tab, old_size, size); + return res; +} + +ERTS_GLB_INLINE void * +erts_db_realloc_nt(ErtsAlcType_t type, void *ptr, + Uint old_size, Uint size) +{ + void *res; + ASSERT(!ptr || old_size == ERTS_ALC_DBG_BLK_SZ(ptr)); + res = erts_realloc(type, ptr, size); + return res; +} + +ERTS_GLB_INLINE void * +erts_db_realloc_fnf_nt(ErtsAlcType_t type, void *ptr, + Uint old_size, Uint size) +{ + void *res; + ASSERT(!ptr || old_size == ERTS_ALC_DBG_BLK_SZ(ptr)); + res = erts_realloc_fnf(type, ptr, size); + if (!res) + return NULL; + return res; +} + +#endif /* #if ERTS_GLB_INLINE_INCL_FUNC_DEF */ + +ERTS_GLB_INLINE void erts_db_free(ErtsAlcType_t type, + DbTable *tab, + void *ptr, + Uint size); + +ERTS_GLB_INLINE void erts_db_free_nt(ErtsAlcType_t type, + void *ptr, + Uint size); + +#if ERTS_GLB_INLINE_INCL_FUNC_DEF + +ERTS_GLB_INLINE void +erts_db_free(ErtsAlcType_t type, DbTable *tab, void *ptr, Uint size) +{ + ASSERT(ptr != 0); + ASSERT(size == ERTS_ALC_DBG_BLK_SZ(ptr)); + ERTS_DB_ALC_MEM_UPDATE_(tab, size, 0); + + ASSERT(((void *) tab) != ptr + || erts_smp_atomic_read(&tab->common.memory_size) == 0); + + erts_free(type, ptr); +} + +ERTS_GLB_INLINE void +erts_db_free_nt(ErtsAlcType_t type, void *ptr, Uint size) +{ + ASSERT(ptr != 0); + ASSERT(size == ERTS_ALC_DBG_BLK_SZ(ptr)); + + erts_free(type, ptr); +} + +#endif /* #if ERTS_GLB_INLINE_INCL_FUNC_DEF */ + +#undef ERTS_DB_ALC_MEM_UPDATE_ + +#endif /* #if defined(ERTS_WANT_DB_INTERNAL__) && !defined(ERTS_HAVE_DB_INTERNAL__) */ + diff --git a/erts/emulator/beam/erl_db_hash.c b/erts/emulator/beam/erl_db_hash.c new file mode 100644 index 0000000000..dea45053df --- /dev/null +++ b/erts/emulator/beam/erl_db_hash.c @@ -0,0 +1,2868 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1998-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* +** Implementation of unordered ETS tables. +** The tables are implemented as linear dynamic hash tables. +*/ + +/* SMP: +** The hash table supports two different locking "modes", +** coarse grained and fine grained locking. +** +** Coarse grained locking relies entirely on the caller (erl_db.c) to obtain +** the right kind of lock on the entire table depending on operation (reading +** or writing). No further locking is then done by the table itself. +** +** Fine grained locking is supported by this code to allow concurrent updates +** (and reading) to different parts of the table. This works by keeping one +** rw-mtx for every N'th bucket. Even dynamic growing and shrinking by +** rehashing buckets can be done without exclusive table lock. +** +** A table will support fine grained locking if it is created with flag +** DB_FINE_LOCKED set. The table variable is_thread_safe will then indicate +** if operations need to obtain fine grained locks or not. Some operations +** will for example always use exclusive table lock to guarantee +** a higher level of atomicy. +*/ + +/* FIXATION: +** Fixating the table, by ets:safe_fixtable or as done by select-operations, +** guarantees two things in current implementation. +** (1) Keys will not *totaly* disappear from the table. A key can thus be used +** as an iterator to find the next key in iteration sequence. Note however +** that this does not mean that (pointers to) table objects are guaranteed +** to be maintained while the table is fixated. A BAG or DBAG may actually +** remove objects as long as there is at least one object left in the table +** with the same key (alive or pseudo-deleted). +** (2) Objects will not be moved between buckets due to table grow/shrink. +** This will guarantee that iterations do not miss keys or get double-hits. +** +** With fine grained locking, a concurrent thread can fixate the table at any +** time. A "dangerous" operation (delete or move) therefore needs to check +** if the table is fixated while write-locking the bucket. +*/ + +/* +#ifdef DEBUG +#define HARDDEBUG 1 +#endif +*/ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "erl_process.h" +#include "error.h" +#define ERTS_WANT_DB_INTERNAL__ +#include "erl_db.h" +#include "bif.h" +#include "big.h" +#include "export.h" +#include "erl_binary.h" + +#include "erl_db_hash.h" + +#ifdef MYDEBUG /* Will fail test case ets_SUITE:memory */ +# define IF_DEBUG(x) x +# define MY_ASSERT(x) ASSERT(x) +#else +# define IF_DEBUG(x) +# define MY_ASSERT(x) +#endif + +/* + * The following symbols can be manipulated to "tune" the linear hash array + */ +#define CHAIN_LEN 6 /* Medium bucket chain len */ + +/* Number of slots per segment */ +#define SEGSZ_EXP 8 +#define SEGSZ (1 << SEGSZ_EXP) +#define SEGSZ_MASK (SEGSZ-1) + +#define NSEG_1 2 /* Size of first segment table (must be at least 2) */ +#define NSEG_2 256 /* Size of second segment table */ +#define NSEG_INC 128 /* Number of segments to grow after that */ + +#define SEGTAB(tb) ((struct segment**)erts_smp_atomic_read(&(tb)->segtab)) +#define NACTIVE(tb) ((int)erts_smp_atomic_read(&(tb)->nactive)) +#define NITEMS(tb) ((int)erts_smp_atomic_read(&(tb)->common.nitems)) + +#define BUCKET(tb, i) SEGTAB(tb)[(i) >> SEGSZ_EXP]->buckets[(i) & SEGSZ_MASK] + +/* + * When deleting a table, the number of records to delete. + * Approximate number, because we must delete entire buckets. + */ +#define DELETE_RECORD_LIMIT 10000 + +/* Calculate slot index from hash value. +** RLOCK_HASH or WLOCK_HASH must be done before. +*/ +static ERTS_INLINE Uint hash_to_ix(DbTableHash* tb, HashValue hval) +{ + Uint mask = erts_smp_atomic_read(&tb->szm); + Uint ix = hval & mask; + if (ix >= erts_smp_atomic_read(&tb->nactive)) { + ix &= mask>>1; + ASSERT(ix < erts_smp_atomic_read(&tb->nactive)); + } + return ix; +} + +/* Remember a slot containing a pseudo-deleted item (INVALID_HASH) +*/ +static ERTS_INLINE void add_fixed_deletion(DbTableHash* tb, int ix) +{ + long was_next; + long exp_next; + FixedDeletion* fixd = (FixedDeletion*) erts_db_alloc(ERTS_ALC_T_DB_FIX_DEL, + (DbTable *) tb, + sizeof(FixedDeletion)); + ERTS_ETS_MISC_MEM_ADD(sizeof(FixedDeletion)); + fixd->slot = ix; + was_next = erts_smp_atomic_read(&tb->fixdel); + do { /* Lockless atomic insertion in linked list: */ + exp_next = was_next; + fixd->next = (FixedDeletion*) exp_next; + was_next = erts_smp_atomic_cmpxchg(&tb->fixdel, (long)fixd, exp_next); + }while (was_next != exp_next); +} + + +#define MAX_HASH 0xEFFFFFFFUL +#define INVALID_HASH 0xFFFFFFFFUL + +/* optimised version of make_hash (normal case? atomic key) */ +#define MAKE_HASH(term) \ + ((is_atom(term) ? (atom_tab(atom_val(term))->slot.bucket.hvalue) : \ + make_hash2(term)) % MAX_HASH) + +#ifdef ERTS_SMP +# define DB_HASH_LOCK_MASK (DB_HASH_LOCK_CNT-1) +# define GET_LOCK(tb,hval) (&(tb)->locks->lck_vec[(hval) & DB_HASH_LOCK_MASK].lck) + +/* Fine grained read lock */ +static ERTS_INLINE erts_smp_rwmtx_t* RLOCK_HASH(DbTableHash* tb, HashValue hval) +{ + if (tb->common.is_thread_safe) { + return NULL; + } else { + erts_smp_rwmtx_t* lck = GET_LOCK(tb,hval); + ASSERT(tb->common.type & DB_FINE_LOCKED); + erts_smp_rwmtx_rlock(lck); + return lck; + } +} +/* Fine grained write lock */ +static ERTS_INLINE erts_smp_rwmtx_t* WLOCK_HASH(DbTableHash* tb, HashValue hval) +{ + if (tb->common.is_thread_safe) { + return NULL; + } else { + erts_smp_rwmtx_t* lck = GET_LOCK(tb,hval); + ASSERT(tb->common.type & DB_FINE_LOCKED); + erts_smp_rwmtx_rwlock(lck); + return lck; + } +} + +static ERTS_INLINE void RUNLOCK_HASH(erts_smp_rwmtx_t* lck) +{ + if (lck != NULL) { + erts_smp_rwmtx_runlock(lck); + } +} + +static ERTS_INLINE void WUNLOCK_HASH(erts_smp_rwmtx_t* lck) +{ + if (lck != NULL) { + erts_smp_rwmtx_rwunlock(lck); + } +} +#else /* ERTS_SMP */ +# define RLOCK_HASH(tb,hval) NULL +# define WLOCK_HASH(tb,hval) NULL +# define RUNLOCK_HASH(lck) ((void)lck) +# define WUNLOCK_HASH(lck) ((void)lck) +#endif /* ERTS_SMP */ + + +#ifdef ERTS_ENABLE_LOCK_CHECK +# define IFN_EXCL(tb,cmd) (((tb)->common.is_thread_safe) || (cmd)) +# define IS_HASH_RLOCKED(tb,hval) IFN_EXCL(tb,erts_smp_lc_rwmtx_is_rlocked(GET_LOCK(tb,hval))) +# define IS_HASH_WLOCKED(tb,lck) IFN_EXCL(tb,erts_smp_lc_rwmtx_is_rwlocked(lck)) +# define IS_TAB_WLOCKED(tb) erts_smp_lc_rwmtx_is_rwlocked(&(tb)->common.rwlock) +#else +# define IS_HASH_RLOCKED(tb,hval) (1) +# define IS_HASH_WLOCKED(tb,hval) (1) +# define IS_TAB_WLOCKED(tb) (1) +#endif + + +/* Iteration helper +** Returns "next" slot index or 0 if EOT reached. +** Slot READ locks updated accordingly, unlocked if EOT. +*/ +static ERTS_INLINE Sint next_slot(DbTableHash* tb, Uint ix, + erts_smp_rwmtx_t** lck_ptr) +{ +#ifdef ERTS_SMP + ix += DB_HASH_LOCK_CNT; + if (ix < NACTIVE(tb)) return ix; + RUNLOCK_HASH(*lck_ptr); + ix = (ix + 1) & DB_HASH_LOCK_MASK; + if (ix != 0) *lck_ptr = RLOCK_HASH(tb,ix); + return ix; +#else + return (++ix < NACTIVE(tb)) ? ix : 0; +#endif +} +/* Same as next_slot but with WRITE locking */ +static ERTS_INLINE Sint next_slot_w(DbTableHash* tb, Uint ix, + erts_smp_rwmtx_t** lck_ptr) +{ +#ifdef ERTS_SMP + ix += DB_HASH_LOCK_CNT; + if (ix < NACTIVE(tb)) return ix; + WUNLOCK_HASH(*lck_ptr); + ix = (ix + 1) & DB_HASH_LOCK_MASK; + if (ix != 0) *lck_ptr = WLOCK_HASH(tb,ix); + return ix; +#else + return next_slot(tb,ix,lck_ptr); +#endif +} + + +/* + * tplp is an untagged pointer to a tuple we know is large enough + * and dth is a pointer to a DbTableHash. + */ +#define GETKEY(dth, tplp) (*((tplp) + (dth)->common.keypos)) + +/* + * Some special binary flags + */ +#define BIN_FLAG_ALL_OBJECTS BIN_FLAG_USR1 + +/* + * Size calculations + */ +#define SIZ_OVERHEAD ((sizeof(HashDbTerm)/sizeof(Eterm)) - 1) +#define SIZ_DBTERM(HDT) (SIZ_OVERHEAD + (HDT)->dbterm.size) + +/* + * Local types + */ +struct mp_prefound { + HashDbTerm** bucket; + int ix; +}; + +struct mp_info { + int all_objects; /* True if complete objects are always + * returned from the match_spec (can use + * copy_shallow on the return value) */ + int something_can_match; /* The match_spec is not "impossible" */ + int key_given; + struct mp_prefound dlists[10]; /* Default list of "pre-found" buckets */ + struct mp_prefound* lists; /* Buckets to search if keys are given, + * = dlists initially */ + unsigned num_lists; /* Number of elements in "lists", + * = 0 initially */ + Binary *mp; /* The compiled match program */ +}; + +/* A table segment */ +struct segment { + HashDbTerm* buckets[SEGSZ]; +#ifdef MYDEBUG + int is_ext_segment; +#endif +}; + +/* A segment that also contains a segment table */ +struct ext_segment { + struct segment s; /* The segment itself. Must be first */ + + struct segment** prev_segtab; /* Used when table is shrinking */ + int nsegs; /* Size of segtab */ + struct segment* segtab[1]; /* The segment table */ +}; +#define SIZEOF_EXTSEG(NSEGS) \ + (sizeof(struct ext_segment) - sizeof(struct segment*) + sizeof(struct segment*)*(NSEGS)) + +#ifdef DEBUG +# include /* offsetof */ +# define EXTSEG(SEGTAB_PTR) \ + ((struct ext_segment*) (((char*)(SEGTAB_PTR)) - offsetof(struct ext_segment,segtab))) +#endif + + +/* How the table segments relate to each other: + + ext_segment: ext_segment: "plain" segment + #=================# #================# #=============# + | bucket[0] |<--+ +------->| bucket[256] | +->| bucket[512] | + | bucket[1] | | | | [257] | | | [513] | + : : | | : : | : : + | bucket[255] | | | | [511] | | | [767] | + |-----------------| | | |----------------| | #=============# + | prev_segtab=NULL| | | +--<---prev_segtab | | + | nsegs = 2 | | | | | nsegs = 256 | | ++->| segtab[0] -->-------+---|---|--<---segtab[0] |<-+ | +| | segtab[1] -->-----------+---|--<---segtab[1] | | | +| #=================# | | segtab[2] -->-----|--+ ext_segment: +| | : : | #================# ++----------------<---------------+ | segtab[255] ->----|----->| bucket[255*256]| + #================# | | | + | : : + | |----------------| + +----<---prev_segtab | + : : +*/ + + +/* +** Forward decl's (static functions) +*/ +static struct ext_segment* alloc_ext_seg(DbTableHash* tb, unsigned seg_ix, + struct segment** old_segtab); +static int alloc_seg(DbTableHash *tb); +static int free_seg(DbTableHash *tb, int free_records); +static HashDbTerm* next(DbTableHash *tb, Uint *iptr, erts_smp_rwmtx_t** lck_ptr, + HashDbTerm *list); +static HashDbTerm* search_list(DbTableHash* tb, Eterm key, + HashValue hval, HashDbTerm *list); +static void shrink(DbTableHash* tb, int nactive); +static void grow(DbTableHash* tb, int nactive); +static void free_term(DbTableHash *tb, HashDbTerm* p); +static Eterm put_term_list(Process* p, HashDbTerm* ptr1, HashDbTerm* ptr2); +static HashDbTerm* get_term(DbTableHash* tb, HashDbTerm* old, + Eterm obj, HashValue hval); +static int analyze_pattern(DbTableHash *tb, Eterm pattern, + struct mp_info *mpi); + +/* + * Method interface functions + */ +static int db_first_hash(Process *p, + DbTable *tbl, + Eterm *ret); + +static int db_next_hash(Process *p, + DbTable *tbl, + Eterm key, + Eterm *ret); + +static int db_member_hash(DbTable *tbl, Eterm key, Eterm *ret); + +static int db_get_element_hash(Process *p, DbTable *tbl, + Eterm key, int ndex, Eterm *ret); + +static int db_erase_object_hash(DbTable *tbl, Eterm object,Eterm *ret); + +static int db_slot_hash(Process *p, DbTable *tbl, + Eterm slot_term, Eterm *ret); + +static int db_select_chunk_hash(Process *p, DbTable *tbl, + Eterm pattern, Sint chunk_size, + int reverse, Eterm *ret); +static int db_select_hash(Process *p, DbTable *tbl, + Eterm pattern, int reverse, Eterm *ret); +static int db_select_count_hash(Process *p, DbTable *tbl, + Eterm pattern, Eterm *ret); +static int db_select_delete_hash(Process *p, DbTable *tbl, + Eterm pattern, Eterm *ret); + +static int db_select_continue_hash(Process *p, DbTable *tbl, + Eterm continuation, Eterm *ret); + +static int db_select_count_continue_hash(Process *p, DbTable *tbl, + Eterm continuation, Eterm *ret); + +static int db_select_delete_continue_hash(Process *p, DbTable *tbl, + Eterm continuation, Eterm *ret); +static void db_print_hash(int to, + void *to_arg, + int show, + DbTable *tbl); +static int db_free_table_hash(DbTable *tbl); + +static int db_free_table_continue_hash(DbTable *tbl); + + +static void db_foreach_offheap_hash(DbTable *, + void (*)(ErlOffHeap *, void *), + void *); + +static int db_delete_all_objects_hash(Process* p, DbTable* tbl); +#ifdef HARDDEBUG +static void db_check_table_hash(DbTableHash *tb); +#endif +static int db_lookup_dbterm_hash(DbTable *tbl, Eterm key, DbUpdateHandle* handle); +static void db_finalize_dbterm_hash(DbUpdateHandle* handle); + +static ERTS_INLINE void try_shrink(DbTableHash* tb) +{ + int nactive = NACTIVE(tb); + if (nactive > SEGSZ && NITEMS(tb) < (nactive * CHAIN_LEN) + && !IS_FIXED(tb)) { + shrink(tb, nactive); + } +} + +/* Is this a live object (not pseodo-deleted) with the specified key? +*/ +static ERTS_INLINE int has_live_key(DbTableHash* tb, HashDbTerm* b, + Eterm key, HashValue hval) +{ + if (b->hvalue != hval) return 0; + else { + Eterm itemKey = GETKEY(tb, b->dbterm.tpl); + return EQ(key,itemKey); + } +} + +/* Has this object the specified key? Can be pseudo-deleted. +*/ +static ERTS_INLINE int has_key(DbTableHash* tb, HashDbTerm* b, + Eterm key, HashValue hval) +{ + if (b->hvalue != hval && b->hvalue != INVALID_HASH) return 0; + else { + Eterm itemKey = GETKEY(tb, b->dbterm.tpl); + return EQ(key,itemKey); + } +} + + +/* +** External interface +*/ +DbTableMethod db_hash = +{ + db_create_hash, + db_first_hash, + db_next_hash, + db_first_hash, /* last == first */ + db_next_hash, /* prev == next */ + db_put_hash, + db_get_hash, + db_get_element_hash, + db_member_hash, + db_erase_hash, + db_erase_object_hash, + db_slot_hash, + db_select_chunk_hash, + db_select_hash, + db_select_delete_hash, + db_select_continue_hash, /* hmm continue_hash? */ + db_select_delete_continue_hash, + db_select_count_hash, + db_select_count_continue_hash, + db_delete_all_objects_hash, + db_free_table_hash, + db_free_table_continue_hash, + db_print_hash, + db_foreach_offheap_hash, +#ifdef HARDDEBUG + db_check_table_hash, +#else + NULL, +#endif + db_lookup_dbterm_hash, + db_finalize_dbterm_hash +}; + +#ifdef DEBUG +/* Wait a while to provoke race and get code coverage */ +static void DEBUG_WAIT(void) +{ + unsigned long spin = 1UL << 20; + while (--spin); +} +#else +# define DEBUG_WAIT() +#endif + +/* Rare case of restoring the rest of the fixdel list + when "unfixer" gets interrupted by "fixer" */ +static void restore_fixdel(DbTableHash* tb, FixedDeletion* fixdel) +{ + /*int tries = 0;*/ + DEBUG_WAIT(); + if (erts_smp_atomic_cmpxchg(&tb->fixdel, (long)fixdel, + (long)NULL) != (long)NULL) { + /* Oboy, must join lists */ + FixedDeletion* last = fixdel; + long was_tail; + long exp_tail; + + while (last->next != NULL) last = last->next; + was_tail = erts_smp_atomic_read(&tb->fixdel); + do { /* Lockless atomic list insertion */ + exp_tail = was_tail; + last->next = (FixedDeletion*) exp_tail; + /*++tries;*/ + DEBUG_WAIT(); + was_tail = erts_smp_atomic_cmpxchg(&tb->fixdel, (long)fixdel, + exp_tail); + }while (was_tail != exp_tail); + } + /*erts_fprintf(stderr,"erl_db_hash: restore_fixdel tries=%d\r\n", tries);*/ +} +/* +** Table interface routines ie what's called by the bif's +*/ + +void db_unfix_table_hash(DbTableHash *tb) +{ + FixedDeletion* fixdel; + + ERTS_SMP_LC_ASSERT(erts_smp_lc_rwmtx_is_rwlocked(&tb->common.rwlock) + || (erts_smp_lc_rwmtx_is_rlocked(&tb->common.rwlock) + && !tb->common.is_thread_safe)); +restart: + fixdel = (FixedDeletion*) erts_smp_atomic_xchg(&tb->fixdel, (long)NULL); + while (fixdel != NULL) { + FixedDeletion *fx = fixdel; + int ix = fx->slot; + HashDbTerm **bp; + HashDbTerm *b; + erts_smp_rwmtx_t* lck = WLOCK_HASH(tb,ix); + + if (IS_FIXED(tb)) { /* interrupted by fixer */ + WUNLOCK_HASH(lck); + restore_fixdel(tb,fixdel); + if (!IS_FIXED(tb)) { + goto restart; /* unfixed again! */ + } + return; + } + if (ix < NACTIVE(tb)) { + bp = &BUCKET(tb, ix); + b = *bp; + + while (b != NULL) { + if (b->hvalue == INVALID_HASH) { + *bp = b->next; + free_term(tb, b); + b = *bp; + } else { + bp = &b->next; + b = b->next; + } + } + } + /* else slot has been joined and purged by shrink() */ + WUNLOCK_HASH(lck); + fixdel = fx->next; + erts_db_free(ERTS_ALC_T_DB_FIX_DEL, + (DbTable *) tb, + (void *) fx, + sizeof(FixedDeletion)); + ERTS_ETS_MISC_MEM_ADD(-sizeof(FixedDeletion)); + } + + /* ToDo: Maybe try grow/shrink the table as well */ +} + +/* Only used by tests +*/ +Uint db_kept_items_hash(DbTableHash *tb) +{ + Uint kept_items = 0; + Uint ix = 0; + erts_smp_rwmtx_t* lck = RLOCK_HASH(tb,ix); + HashDbTerm* b; + do { + for (b = BUCKET(tb, ix); b != NULL; b = b->next) { + if (b->hvalue == INVALID_HASH) { + ++kept_items; + } + } + ix = next_slot(tb, ix, &lck); + }while (ix); + return kept_items; +} + +int db_create_hash(Process *p, DbTable *tbl) +{ + DbTableHash *tb = &tbl->hash; + + erts_smp_atomic_init(&tb->szm, SEGSZ_MASK); + erts_smp_atomic_init(&tb->nactive, SEGSZ); + erts_smp_atomic_init(&tb->fixdel, (long)NULL); + erts_smp_atomic_init(&tb->segtab, (long) alloc_ext_seg(tb,0,NULL)->segtab); + tb->nsegs = NSEG_1; + tb->nslots = SEGSZ; + + erts_smp_atomic_init(&tb->is_resizing, 0); +#ifdef ERTS_SMP + if (tb->common.type & DB_FINE_LOCKED) { + int i; + tb->locks = (DbTableHashFineLocks*) erts_db_alloc_fnf(ERTS_ALC_T_DB_SEG, /* Other type maybe? */ + (DbTable *) tb, + sizeof(DbTableHashFineLocks)); + for (i=0; ilocks->lck_vec[i].lck, "db_hash_slot", tb->common.the_name); + #else + erts_rwmtx_init(&tb->locks->lck_vec[i].lck, "db_hash_slot"); + #endif + } + /* This important property is needed to guarantee that the buckets + * involved in a grow/shrink operation it protected by the same lock: + */ + ASSERT(erts_smp_atomic_read(&tb->nactive) % DB_HASH_LOCK_CNT == 0); + } + else { /* coarse locking */ + tb->locks = NULL; + } +#endif /* ERST_SMP */ + return DB_ERROR_NONE; +} + +static int db_first_hash(Process *p, DbTable *tbl, Eterm *ret) +{ + DbTableHash *tb = &tbl->hash; + Uint ix = 0; + erts_smp_rwmtx_t* lck = RLOCK_HASH(tb,ix); + HashDbTerm* list; + + for (;;) { + list = BUCKET(tb,ix); + if (list != NULL) { + if (list->hvalue == INVALID_HASH) { + list = next(tb,&ix,&lck,list); + } + break; + } + if ((ix=next_slot(tb,ix,&lck)) == 0) { + list = NULL; + break; + } + } + if (list != NULL) { + Eterm key = GETKEY(tb, list->dbterm.tpl); + + COPY_OBJECT(key, p, ret); + RUNLOCK_HASH(lck); + } + else { + *ret = am_EOT; + } + return DB_ERROR_NONE; +} + + +static int db_next_hash(Process *p, DbTable *tbl, Eterm key, Eterm *ret) +{ + DbTableHash *tb = &tbl->hash; + HashValue hval; + Uint ix; + HashDbTerm* b; + erts_smp_rwmtx_t* lck; + + hval = MAKE_HASH(key); + lck = RLOCK_HASH(tb,hval); + ix = hash_to_ix(tb, hval); + b = BUCKET(tb, ix); + + for (;;) { + if (b == NULL) { + RUNLOCK_HASH(lck); + return DB_ERROR_BADKEY; + } + if (has_key(tb, b, key, hval)) { + break; + } + b = b->next; + } + /* Key found */ + + b = next(tb, &ix, &lck, b); + if (tb->common.status & (DB_BAG | DB_DUPLICATE_BAG)) { + while (b != 0) { + if (!has_live_key(tb, b, key, hval)) { + break; + } + b = next(tb, &ix, &lck, b); + } + } + if (b == NULL) { + *ret = am_EOT; + } + else { + COPY_OBJECT(GETKEY(tb, b->dbterm.tpl), p, ret); + RUNLOCK_HASH(lck); + } + return DB_ERROR_NONE; +} + +int db_put_hash(DbTable *tbl, Eterm obj, int key_clash_fail) +{ + DbTableHash *tb = &tbl->hash; + HashValue hval; + int ix; + Eterm key; + HashDbTerm** bp; + HashDbTerm* b; + HashDbTerm* q; + erts_smp_rwmtx_t* lck; + int nitems; + int ret = DB_ERROR_NONE; + + key = GETKEY(tb, tuple_val(obj)); + hval = MAKE_HASH(key); + lck = WLOCK_HASH(tb, hval); + ix = hash_to_ix(tb, hval); + bp = &BUCKET(tb, ix); + b = *bp; + + for (;;) { + if (b == NULL) { + goto Lnew; + } + if (has_key(tb,b,key,hval)) { + break; + } + bp = &b->next; + b = b->next; + } + /* Key found + */ + if (tb->common.status & DB_SET) { + HashDbTerm* bnext = b->next; + if (b->hvalue == INVALID_HASH) { + erts_smp_atomic_inc(&tb->common.nitems); + } + else if (key_clash_fail) { + ret = DB_ERROR_BADKEY; + goto Ldone; + } + q = get_term(tb, b, obj, hval); + q->next = bnext; + q->hvalue = hval; /* In case of INVALID_HASH */ + *bp = q; + goto Ldone; + } + else if (key_clash_fail) { /* && (DB_BAG || DB_DUPLICATE_BAG) */ + q = b; + do { + if (q->hvalue != INVALID_HASH) { + ret = DB_ERROR_BADKEY; + goto Ldone; + } + q = q->next; + }while (q != NULL && has_key(tb,q,key,hval)); + } + else if (tb->common.status & DB_BAG) { + HashDbTerm** qp = bp; + q = b; + do { + if (eq(make_tuple(q->dbterm.tpl), obj)) { + if (q->hvalue == INVALID_HASH) { + erts_smp_atomic_inc(&tb->common.nitems); + q->hvalue = hval; + if (q != b) { /* must move to preserve key insertion order */ + *qp = q->next; + q->next = b; + *bp = q; + } + } + goto Ldone; + } + qp = &q->next; + q = *qp; + }while (q != NULL && has_key(tb,q,key,hval)); + } + /*else DB_DUPLICATE_BAG */ + +Lnew: + q = get_term(tb, NULL, obj, hval); + q->next = b; + *bp = q; + nitems = erts_smp_atomic_inctest(&tb->common.nitems); + WUNLOCK_HASH(lck); + { + int nactive = NACTIVE(tb); + if (nitems > nactive * (CHAIN_LEN+1) && !IS_FIXED(tb)) { + grow(tb, nactive); + } + } + CHECK_TABLES(); + return DB_ERROR_NONE; + +Ldone: + WUNLOCK_HASH(lck); + return ret; +} + +int db_get_hash(Process *p, DbTable *tbl, Eterm key, Eterm *ret) +{ + DbTableHash *tb = &tbl->hash; + HashValue hval; + int ix; + HashDbTerm* b1; + erts_smp_rwmtx_t* lck; + + hval = MAKE_HASH(key); + lck = RLOCK_HASH(tb,hval); + ix = hash_to_ix(tb, hval); + b1 = BUCKET(tb, ix); + + while(b1 != 0) { + if (has_live_key(tb,b1,key,hval)) { + HashDbTerm* b2 = b1->next; + Eterm copy; + + if (tb->common.status & (DB_BAG | DB_DUPLICATE_BAG)) { + while(b2 != NULL && has_key(tb,b2,key,hval)) + b2 = b2->next; + } + copy = put_term_list(p, b1, b2); + CHECK_TABLES(); + *ret = copy; + goto done; + } + b1 = b1->next; + } + *ret = NIL; +done: + RUNLOCK_HASH(lck); + return DB_ERROR_NONE; +} + +int db_get_element_array(DbTable *tbl, + Eterm key, + int ndex, + Eterm *ret, + int *num_ret) +{ + DbTableHash *tb = &tbl->hash; + HashValue hval; + int ix; + HashDbTerm* b1; + int num = 0; + int retval; + erts_smp_rwmtx_t* lck; + + ASSERT(!IS_FIXED(tbl)); /* no support for fixed tables here */ + + hval = MAKE_HASH(key); + lck = RLOCK_HASH(tb, hval); + ix = hash_to_ix(tb, hval); + b1 = BUCKET(tb, ix); + + while(b1 != 0) { + if (has_live_key(tb,b1,key,hval)) { + if (tb->common.status & (DB_BAG | DB_DUPLICATE_BAG)) { + HashDbTerm* b; + HashDbTerm* b2 = b1->next; + + while(b2 != NULL && has_live_key(tb,b2,key,hval)) { + if (ndex > arityval(b2->dbterm.tpl[0])) { + retval = DB_ERROR_BADITEM; + goto done; + } + b2 = b2->next; + } + + b = b1; + while(b != b2) { + if (num < *num_ret) { + ret[num++] = b->dbterm.tpl[ndex]; + } else { + retval = DB_ERROR_NONE; + goto done; + } + b = b->next; + } + *num_ret = num; + } + else { + ASSERT(*num_ret > 0); + ret[0] = b1->dbterm.tpl[ndex]; + *num_ret = 1; + } + retval = DB_ERROR_NONE; + goto done; + } + b1 = b1->next; + } + retval = DB_ERROR_BADKEY; +done: + RUNLOCK_HASH(lck); + return retval; +} + + +static int db_member_hash(DbTable *tbl, Eterm key, Eterm *ret) +{ + DbTableHash *tb = &tbl->hash; + HashValue hval; + int ix; + HashDbTerm* b1; + erts_smp_rwmtx_t* lck; + + hval = MAKE_HASH(key); + ix = hash_to_ix(tb, hval); + lck = RLOCK_HASH(tb, hval); + b1 = BUCKET(tb, ix); + + while(b1 != 0) { + if (has_live_key(tb,b1,key,hval)) { + *ret = am_true; + goto done; + } + b1 = b1->next; + } + *ret = am_false; +done: + RUNLOCK_HASH(lck); + return DB_ERROR_NONE; +} + +static int db_get_element_hash(Process *p, DbTable *tbl, + Eterm key, + int ndex, + Eterm *ret) +{ + DbTableHash *tb = &tbl->hash; + HashValue hval; + int ix; + HashDbTerm* b1; + erts_smp_rwmtx_t* lck; + int retval; + + hval = MAKE_HASH(key); + lck = RLOCK_HASH(tb, hval); + ix = hash_to_ix(tb, hval); + b1 = BUCKET(tb, ix); + + + while(b1 != 0) { + if (has_live_key(tb,b1,key,hval)) { + Eterm copy; + + if (ndex > arityval(b1->dbterm.tpl[0])) { + retval = DB_ERROR_BADITEM; + goto done; + } + + if (tb->common.status & (DB_BAG | DB_DUPLICATE_BAG)) { + HashDbTerm* b; + HashDbTerm* b2 = b1->next; + Eterm elem_list = NIL; + + while(b2 != NULL && has_key(tb,b2,key,hval)) { + if (ndex > arityval(b2->dbterm.tpl[0]) + && b2->hvalue != INVALID_HASH) { + retval = DB_ERROR_BADITEM; + goto done; + } + b2 = b2->next; + } + + b = b1; + while(b != b2) { + if (b->hvalue != INVALID_HASH) { + Eterm *hp; + Uint sz = size_object(b->dbterm.tpl[ndex])+2; + + hp = HAlloc(p, sz); + copy = copy_struct(b->dbterm.tpl[ndex], sz-2, &hp, &MSO(p)); + elem_list = CONS(hp, copy, elem_list); + hp += 2; + } + b = b->next; + } + *ret = elem_list; + } + else { + COPY_OBJECT(b1->dbterm.tpl[ndex], p, ©); + *ret = copy; + } + retval = DB_ERROR_NONE; + goto done; + } + b1 = b1->next; + } + retval = DB_ERROR_BADKEY; +done: + RUNLOCK_HASH(lck); + return retval; +} + +/* + * Very internal interface, removes elements of arity two from + * BAG. Used for the PID meta table + */ +int db_erase_bag_exact2(DbTable *tbl, Eterm key, Eterm value) +{ + DbTableHash *tb = &tbl->hash; + HashValue hval; + int ix; + HashDbTerm** bp; + HashDbTerm* b; + erts_smp_rwmtx_t* lck; + int found = 0; + + hval = MAKE_HASH(key); + lck = WLOCK_HASH(tb,hval); + ix = hash_to_ix(tb, hval); + bp = &BUCKET(tb, ix); + b = *bp; + + ASSERT(!IS_FIXED(tb)); + ASSERT((tb->common.status & DB_BAG)); + + while(b != 0) { + if (has_live_key(tb,b,key,hval)) { + found = 1; + if ((arityval(b->dbterm.tpl[0]) == 2) && + EQ(value, b->dbterm.tpl[2])) { + *bp = b->next; + free_term(tb, b); + erts_smp_atomic_dec(&tb->common.nitems); + b = *bp; + break; + } + } else if (found) { + break; + } + bp = &b->next; + b = b->next; + } + WUNLOCK_HASH(lck); + if (found) { + try_shrink(tb); + } + return DB_ERROR_NONE; +} + +/* +** NB, this is for the db_erase/2 bif. +*/ +int db_erase_hash(DbTable *tbl, Eterm key, Eterm *ret) +{ + DbTableHash *tb = &tbl->hash; + HashValue hval; + int ix; + HashDbTerm** bp; + HashDbTerm* b; + erts_smp_rwmtx_t* lck; + int nitems_diff = 0; + + hval = MAKE_HASH(key); + lck = WLOCK_HASH(tb,hval); + ix = hash_to_ix(tb, hval); + bp = &BUCKET(tb, ix); + b = *bp; + + while(b != 0) { + if (has_live_key(tb,b,key,hval)) { + --nitems_diff; + if (nitems_diff == -1 && IS_FIXED(tb)) { + /* Pseudo remove (no need to keep several of same key) */ + add_fixed_deletion(tb, ix); + b->hvalue = INVALID_HASH; + } else { + *bp = b->next; + free_term(tb, b); + b = *bp; + continue; + } + } + else { + if (nitems_diff && b->hvalue != INVALID_HASH) + break; + } + bp = &b->next; + b = b->next; + } + WUNLOCK_HASH(lck); + if (nitems_diff) { + erts_smp_atomic_add(&tb->common.nitems, nitems_diff); + try_shrink(tb); + } + *ret = am_true; + return DB_ERROR_NONE; +} + +/* +** This is for the ets:delete_object BIF +*/ +static int db_erase_object_hash(DbTable *tbl, Eterm object, Eterm *ret) +{ + DbTableHash *tb = &tbl->hash; + HashValue hval; + int ix; + HashDbTerm** bp; + HashDbTerm* b; + erts_smp_rwmtx_t* lck; + int nitems_diff = 0; + int nkeys = 0; + Eterm key; + + key = GETKEY(tb, tuple_val(object)); + hval = MAKE_HASH(key); + lck = WLOCK_HASH(tb,hval); + ix = hash_to_ix(tb, hval); + bp = &BUCKET(tb, ix); + b = *bp; + + while(b != 0) { + if (has_live_key(tb,b,key,hval)) { + ++nkeys; + if (eq(object, make_tuple(b->dbterm.tpl))) { + --nitems_diff; + if (nkeys==1 && IS_FIXED(tb)) { /* Pseudo remove */ + add_fixed_deletion(tb,ix); + b->hvalue = INVALID_HASH; + bp = &b->next; + b = b->next; + } else { + *bp = b->next; + free_term(tb, b); + b = *bp; + } + if (tb->common.status & (DB_DUPLICATE_BAG)) { + continue; + } else { + break; + } + } + } + else if (nitems_diff && b->hvalue != INVALID_HASH) { + break; + } + bp = &b->next; + b = b->next; + } + WUNLOCK_HASH(lck); + if (nitems_diff) { + erts_smp_atomic_add(&tb->common.nitems, nitems_diff); + try_shrink(tb); + } + *ret = am_true; + return DB_ERROR_NONE; +} + + +static int db_slot_hash(Process *p, DbTable *tbl, Eterm slot_term, Eterm *ret) +{ + DbTableHash *tb = &tbl->hash; + erts_smp_rwmtx_t* lck; + Sint slot; + int retval; + int nactive; + + if (is_not_small(slot_term) || ((slot = signed_val(slot_term)) < 0)) { + return DB_ERROR_BADPARAM; + } + lck = RLOCK_HASH(tb, slot); + nactive = NACTIVE(tb); + if (slot < nactive) { + *ret = put_term_list(p, BUCKET(tb, slot), 0); + retval = DB_ERROR_NONE; + } + else if (slot == nactive) { + *ret = am_EOT; + retval = DB_ERROR_NONE; + } + else { + retval = DB_ERROR_BADPARAM; + } + RUNLOCK_HASH(lck); + return retval; +} + + +/* + * This is just here so I can take care of the return value + * that is to be sent during a trap (the BIF_TRAP macros explicitly returns) + */ +static BIF_RETTYPE bif_trap1(Export *bif, + Process *p, + Eterm p1) +{ + BIF_TRAP1(bif, p, p1); +} + +/* + * Continue collecting select matches, this may happen either due to a trap + * or when the user calls ets:select/1 + */ +static int db_select_continue_hash(Process *p, + DbTable *tbl, + Eterm continuation, + Eterm *ret) +{ + DbTableHash *tb = &tbl->hash; + Sint slot_ix; + Sint save_slot_ix; + Sint chunk_size; + int all_objects; + Binary *mp; + int num_left = 1000; + HashDbTerm *current = 0; + Eterm match_list; + Uint32 dummy; + unsigned sz; + Eterm *hp; + Eterm match_res; + Sint got; + Eterm *tptr; + erts_smp_rwmtx_t* lck; + +#define RET_TO_BIF(Term, State) do { *ret = (Term); return State; } while(0); + + /* Decode continuation. We know it's a tuple but not the arity or anything else */ + + tptr = tuple_val(continuation); + + if (arityval(*tptr) != 6) + RET_TO_BIF(NIL,DB_ERROR_BADPARAM); + + if (!is_small(tptr[2]) || !is_small(tptr[3]) || !is_binary(tptr[4]) || + !(is_list(tptr[5]) || tptr[5] == NIL) || !is_small(tptr[6])) + RET_TO_BIF(NIL,DB_ERROR_BADPARAM); + if ((chunk_size = signed_val(tptr[3])) < 0) + RET_TO_BIF(NIL,DB_ERROR_BADPARAM); + if (!(thing_subtag(*binary_val(tptr[4])) == REFC_BINARY_SUBTAG)) + RET_TO_BIF(NIL,DB_ERROR_BADPARAM); + mp = ((ProcBin *) binary_val(tptr[4]))->val; + if (!IsMatchProgBinary(mp)) + RET_TO_BIF(NIL,DB_ERROR_BADPARAM); + all_objects = mp->flags & BIN_FLAG_ALL_OBJECTS; + match_list = tptr[5]; + if ((got = signed_val(tptr[6])) < 0) + RET_TO_BIF(NIL,DB_ERROR_BADPARAM); + + slot_ix = signed_val(tptr[2]); + if (slot_ix < 0 /* EOT */ + || (chunk_size && got >= chunk_size)) { + goto done; /* Already got all or enough in the match_list */ + } + + lck = RLOCK_HASH(tb,slot_ix); + if (slot_ix >= NACTIVE(tb)) { + RUNLOCK_HASH(lck); + RET_TO_BIF(NIL,DB_ERROR_BADPARAM); + } + + while ((current = BUCKET(tb,slot_ix)) == NULL) { + slot_ix = next_slot(tb, slot_ix, &lck); + if (slot_ix == 0) { + slot_ix = -1; /* EOT */ + goto done; + } + } + for(;;) { + if (current->hvalue != INVALID_HASH && + (match_res = + db_prog_match(p,mp, + make_tuple(current->dbterm.tpl), + 0,&dummy), + is_value(match_res))) { + if (all_objects) { + hp = HAlloc(p, current->dbterm.size + 2); + match_res = copy_shallow(DBTERM_BUF(¤t->dbterm), + current->dbterm.size, + &hp, + &MSO(p)); + } else { + sz = size_object(match_res); + + hp = HAlloc(p, sz + 2); + match_res = copy_struct(match_res, sz, &hp, &MSO(p)); + } + match_list = CONS(hp, match_res, match_list); + ++got; + } + --num_left; + save_slot_ix = slot_ix; + if ((current = next(tb, (Uint*)&slot_ix, &lck, current)) == NULL) { + slot_ix = -1; /* EOT */ + break; + } + if (slot_ix != save_slot_ix) { + if (chunk_size && got >= chunk_size) { + RUNLOCK_HASH(lck); + break; + } + if (num_left <= 0 || MBUF(p)) { + /* + * We have either reached our limit, or just created some heap fragments. + * Since many heap fragments will make the GC slower, trap and GC now. + */ + RUNLOCK_HASH(lck); + goto trap; + } + } + } +done: + BUMP_REDS(p, 1000 - num_left); + if (chunk_size) { + Eterm continuation; + Eterm rest = NIL; + Sint rest_size = 0; + + if (got > chunk_size) { /* Cannot write destructively here, + the list may have + been in user space */ + rest = NIL; + hp = HAlloc(p, (got - chunk_size) * 2); + while (got-- > chunk_size) { + rest = CONS(hp, CAR(list_val(match_list)), rest); + hp += 2; + match_list = CDR(list_val(match_list)); + ++rest_size; + } + } + if (rest != NIL || slot_ix >= 0) { + hp = HAlloc(p,3+7); + continuation = TUPLE6(hp, tptr[1], make_small(slot_ix), + tptr[3], tptr[4], rest, + make_small(rest_size)); + hp += 7; + RET_TO_BIF(TUPLE2(hp, match_list, continuation),DB_ERROR_NONE); + } else { + if (match_list != NIL) { + hp = HAlloc(p, 3); + RET_TO_BIF(TUPLE2(hp, match_list, am_EOT),DB_ERROR_NONE); + } else { + RET_TO_BIF(am_EOT, DB_ERROR_NONE); + } + } + } + RET_TO_BIF(match_list,DB_ERROR_NONE); + +trap: + BUMP_ALL_REDS(p); + + hp = HAlloc(p,7); + continuation = TUPLE6(hp, tptr[1], make_small(slot_ix), tptr[3], + tptr[4], match_list, make_small(got)); + RET_TO_BIF(bif_trap1(&ets_select_continue_exp, p, + continuation), + DB_ERROR_NONE); + +#undef RET_TO_BIF + +} + +static int db_select_hash(Process *p, DbTable *tbl, + Eterm pattern, int reverse, + Eterm *ret) +{ + return db_select_chunk_hash(p, tbl, pattern, 0, reverse, ret); +} + +static int db_select_chunk_hash(Process *p, DbTable *tbl, + Eterm pattern, Sint chunk_size, + int reverse, /* not used */ + Eterm *ret) +{ + DbTableHash *tb = &tbl->hash; + struct mp_info mpi; + Sint slot_ix; + HashDbTerm *current = 0; + unsigned current_list_pos = 0; + Eterm match_list; + Uint32 dummy; + Eterm match_res; + unsigned sz; + Eterm *hp; + int num_left = 1000; + Uint got = 0; + Eterm continuation; + int errcode; + Eterm mpb; + erts_smp_rwmtx_t* lck; + + +#define RET_TO_BIF(Term,RetVal) do { \ + if (mpi.mp != NULL) { \ + erts_bin_free(mpi.mp); \ + } \ + if (mpi.lists != mpi.dlists) { \ + erts_free(ERTS_ALC_T_DB_SEL_LIST, \ + (void *) mpi.lists); \ + } \ + *ret = (Term); \ + return RetVal; \ + } while(0) + + + if ((errcode = analyze_pattern(tb, pattern, &mpi)) != DB_ERROR_NONE) { + RET_TO_BIF(NIL,errcode); + } + + if (!mpi.something_can_match) { + if (chunk_size) { + RET_TO_BIF(am_EOT, DB_ERROR_NONE); /* We're done */ + } + RET_TO_BIF(NIL, DB_ERROR_NONE); + /* can't possibly match anything */ + } + + if (!mpi.key_given) { + /* Run this code if pattern is variable or GETKEY(pattern) */ + /* is a variable */ + slot_ix = 0; + lck = RLOCK_HASH(tb,slot_ix); + for (;;) { + ASSERT(slot_ix < NACTIVE(tb)); + if ((current = BUCKET(tb,slot_ix)) != NULL) { + break; + } + slot_ix = next_slot(tb,slot_ix,&lck); + if (slot_ix == 0) { + if (chunk_size) { + RET_TO_BIF(am_EOT, DB_ERROR_NONE); /* We're done */ + } + RET_TO_BIF(NIL,DB_ERROR_NONE); + } + } + } else { + /* We have at least one */ + slot_ix = mpi.lists[current_list_pos].ix; + lck = RLOCK_HASH(tb, slot_ix); + current = *(mpi.lists[current_list_pos].bucket); + ASSERT(current == BUCKET(tb,slot_ix)); + ++current_list_pos; + } + + match_list = NIL; + + for(;;) { + if (current != NULL) { + if (current->hvalue != INVALID_HASH) { + match_res = db_prog_match(p,mpi.mp, + make_tuple(current->dbterm.tpl), + 0,&dummy); + if (is_value(match_res)) { + if (mpi.all_objects) { + hp = HAlloc(p, current->dbterm.size + 2); + match_res = copy_shallow(DBTERM_BUF(¤t->dbterm), + current->dbterm.size, + &hp, + &MSO(p)); + } else { + sz = size_object(match_res); + + hp = HAlloc(p, sz + 2); + match_res = copy_struct(match_res, sz, &hp, &MSO(p)); + } + match_list = CONS(hp, match_res, match_list); + ++got; + } + } + current = current->next; + } + else if (mpi.key_given) { /* Key is bound */ + RUNLOCK_HASH(lck); + if (current_list_pos == mpi.num_lists) { + slot_ix = -1; /* EOT */ + goto done; + } else { + slot_ix = mpi.lists[current_list_pos].ix; + lck = RLOCK_HASH(tb, slot_ix); + current = *(mpi.lists[current_list_pos].bucket); + ASSERT(mpi.lists[current_list_pos].bucket == &BUCKET(tb,slot_ix)); + ++current_list_pos; + } + } + else { /* Key is variable */ + --num_left; + + if ((slot_ix=next_slot(tb,slot_ix,&lck)) == 0) { + slot_ix = -1; + break; + } + if (chunk_size && got >= chunk_size) { + RUNLOCK_HASH(lck); + break; + } + if (num_left <= 0 || MBUF(p)) { + /* + * We have either reached our limit, or just created some heap fragments. + * Since many heap fragments will make the GC slower, trap and GC now. + */ + RUNLOCK_HASH(lck); + goto trap; + } + current = BUCKET(tb,slot_ix); + } + } +done: + BUMP_REDS(p, 1000 - num_left); + if (chunk_size) { + Eterm continuation; + Eterm rest = NIL; + Sint rest_size = 0; + + if (mpi.all_objects) + (mpi.mp)->flags |= BIN_FLAG_ALL_OBJECTS; + if (got > chunk_size) { /* Split list in return value and 'rest' */ + Eterm tmp = match_list; + rest = match_list; + while (got-- > chunk_size + 1) { + tmp = CDR(list_val(tmp)); + ++rest_size; + } + ++rest_size; + match_list = CDR(list_val(tmp)); + CDR(list_val(tmp)) = NIL; /* Destructive, the list has never + been in 'user space' */ + } + if (rest != NIL || slot_ix >= 0) { /* Need more calls */ + hp = HAlloc(p,3+7+PROC_BIN_SIZE); + mpb =db_make_mp_binary(p,(mpi.mp),&hp); + if (mpi.all_objects) + (mpi.mp)->flags |= BIN_FLAG_ALL_OBJECTS; + continuation = TUPLE6(hp, tb->common.id,make_small(slot_ix), + make_small(chunk_size), + mpb, rest, + make_small(rest_size)); + mpi.mp = NULL; /*otherwise the return macro will destroy it */ + hp += 7; + RET_TO_BIF(TUPLE2(hp, match_list, continuation),DB_ERROR_NONE); + } else { /* All data is exhausted */ + if (match_list != NIL) { /* No more data to search but still a + result to return to the caller */ + hp = HAlloc(p, 3); + RET_TO_BIF(TUPLE2(hp, match_list, am_EOT),DB_ERROR_NONE); + } else { /* Reached the end of the ttable with no data to return */ + RET_TO_BIF(am_EOT, DB_ERROR_NONE); + } + } + } + RET_TO_BIF(match_list,DB_ERROR_NONE); +trap: + BUMP_ALL_REDS(p); + if (mpi.all_objects) + (mpi.mp)->flags |= BIN_FLAG_ALL_OBJECTS; + hp = HAlloc(p,7+PROC_BIN_SIZE); + mpb =db_make_mp_binary(p,(mpi.mp),&hp); + continuation = TUPLE6(hp, tb->common.id, make_small(slot_ix), + make_small(chunk_size), + mpb, match_list, + make_small(got)); + mpi.mp = NULL; /*otherwise the return macro will destroy it */ + RET_TO_BIF(bif_trap1(&ets_select_continue_exp, p, + continuation), + DB_ERROR_NONE); + +#undef RET_TO_BIF + +} + +static int db_select_count_hash(Process *p, + DbTable *tbl, + Eterm pattern, + Eterm *ret) +{ + DbTableHash *tb = &tbl->hash; + struct mp_info mpi; + Uint slot_ix = 0; + HashDbTerm* current = NULL; + unsigned current_list_pos = 0; + Uint32 dummy; + Eterm *hp; + int num_left = 1000; + Uint got = 0; + Eterm continuation; + int errcode; + Eterm egot; + Eterm mpb; + erts_smp_rwmtx_t* lck; + +#define RET_TO_BIF(Term,RetVal) do { \ + if (mpi.mp != NULL) { \ + erts_bin_free(mpi.mp); \ + } \ + if (mpi.lists != mpi.dlists) { \ + erts_free(ERTS_ALC_T_DB_SEL_LIST, \ + (void *) mpi.lists); \ + } \ + *ret = (Term); \ + return RetVal; \ + } while(0) + + + if ((errcode = analyze_pattern(tb, pattern, &mpi)) != DB_ERROR_NONE) { + RET_TO_BIF(NIL,errcode); + } + + if (!mpi.something_can_match) { + RET_TO_BIF(make_small(0), DB_ERROR_NONE); + /* can't possibly match anything */ + } + + if (!mpi.key_given) { + /* Run this code if pattern is variable or GETKEY(pattern) */ + /* is a variable */ + slot_ix = 0; + lck = RLOCK_HASH(tb,slot_ix); + current = BUCKET(tb,slot_ix); + } else { + /* We have at least one */ + slot_ix = mpi.lists[current_list_pos].ix; + lck = RLOCK_HASH(tb, slot_ix); + current = *(mpi.lists[current_list_pos].bucket); + ASSERT(current == BUCKET(tb,slot_ix)); + ++current_list_pos; + } + + for(;;) { + if (current != NULL) { + if (current->hvalue != INVALID_HASH) { + if (db_prog_match(p, mpi.mp, make_tuple(current->dbterm.tpl), + 0, &dummy) == am_true) { + ++got; + } + --num_left; + } + current = current->next; + } + else { /* next bucket */ + if (mpi.key_given) { /* Key is bound */ + RUNLOCK_HASH(lck); + if (current_list_pos == mpi.num_lists) { + goto done; + } else { + slot_ix = mpi.lists[current_list_pos].ix; + lck = RLOCK_HASH(tb, slot_ix); + current = *(mpi.lists[current_list_pos].bucket); + ASSERT(mpi.lists[current_list_pos].bucket == &BUCKET(tb,slot_ix)); + ++current_list_pos; + } + } + else { + if ((slot_ix=next_slot(tb,slot_ix,&lck)) == 0) { + goto done; + } + if (num_left <= 0) { + RUNLOCK_HASH(lck); + goto trap; + } + current = BUCKET(tb,slot_ix); + } + } + } +done: + BUMP_REDS(p, 1000 - num_left); + RET_TO_BIF(erts_make_integer(got,p),DB_ERROR_NONE); +trap: + BUMP_ALL_REDS(p); + if (IS_USMALL(0, got)) { + hp = HAlloc(p, PROC_BIN_SIZE + 5); + egot = make_small(got); + } + else { + hp = HAlloc(p, BIG_UINT_HEAP_SIZE + PROC_BIN_SIZE + 5); + egot = uint_to_big(got, hp); + hp += BIG_UINT_HEAP_SIZE; + } + mpb = db_make_mp_binary(p,mpi.mp,&hp); + continuation = TUPLE4(hp, tb->common.id, make_small(slot_ix), + mpb, + egot); + mpi.mp = NULL; /*otherwise the return macro will destroy it */ + RET_TO_BIF(bif_trap1(&ets_select_count_continue_exp, p, + continuation), + DB_ERROR_NONE); + +#undef RET_TO_BIF +} + +static int db_select_delete_hash(Process *p, + DbTable *tbl, + Eterm pattern, + Eterm *ret) +{ + DbTableHash *tb = &tbl->hash; + struct mp_info mpi; + Uint slot_ix = 0; + HashDbTerm **current = NULL; + unsigned current_list_pos = 0; + Uint32 dummy; + Eterm *hp; + int num_left = 1000; + Uint got = 0; + Eterm continuation; + int errcode; + Uint last_pseudo_delete = (Uint)-1; + Eterm mpb; + Eterm egot; +#ifdef ERTS_SMP + int fixated_by_me = tb->common.is_thread_safe ? 0 : 1; /* ToDo: something nicer */ +#else + int fixated_by_me = 0; +#endif + erts_smp_rwmtx_t* lck; + +#define RET_TO_BIF(Term,RetVal) do { \ + if (mpi.mp != NULL) { \ + erts_bin_free(mpi.mp); \ + } \ + if (mpi.lists != mpi.dlists) { \ + erts_free(ERTS_ALC_T_DB_SEL_LIST, \ + (void *) mpi.lists); \ + } \ + *ret = (Term); \ + return RetVal; \ + } while(0) + + + if ((errcode = analyze_pattern(tb, pattern, &mpi)) != DB_ERROR_NONE) { + RET_TO_BIF(NIL,errcode); + } + + if (!mpi.something_can_match) { + RET_TO_BIF(make_small(0), DB_ERROR_NONE); + /* can't possibly match anything */ + } + + if (!mpi.key_given) { + /* Run this code if pattern is variable or GETKEY(pattern) */ + /* is a variable */ + lck = WLOCK_HASH(tb,slot_ix); + current = &BUCKET(tb,slot_ix); + } else { + /* We have at least one */ + slot_ix = mpi.lists[current_list_pos].ix; + lck = WLOCK_HASH(tb, slot_ix); + current = mpi.lists[current_list_pos++].bucket; + ASSERT(*current == BUCKET(tb,slot_ix)); + } + + + for(;;) { + if ((*current) == NULL) { + if (mpi.key_given) { /* Key is bound */ + WUNLOCK_HASH(lck); + if (current_list_pos == mpi.num_lists) { + goto done; + } else { + slot_ix = mpi.lists[current_list_pos].ix; + lck = WLOCK_HASH(tb, slot_ix); + current = mpi.lists[current_list_pos].bucket; + ASSERT(mpi.lists[current_list_pos].bucket == &BUCKET(tb,slot_ix)); + ++current_list_pos; + } + } else { + if ((slot_ix=next_slot_w(tb,slot_ix,&lck)) == 0) { + goto done; + } + if (num_left <= 0) { + WUNLOCK_HASH(lck); + goto trap; + } + current = &BUCKET(tb,slot_ix); + } + } + else if ((*current)->hvalue == INVALID_HASH) { + current = &((*current)->next); + } + else { + int did_erase = 0; + if ((db_prog_match(p,mpi.mp, + make_tuple((*current)->dbterm.tpl), + 0,&dummy)) == am_true) { + if (NFIXED(tb) > fixated_by_me) { /* fixated by others? */ + if (slot_ix != last_pseudo_delete) { + add_fixed_deletion(tb, slot_ix); + last_pseudo_delete = slot_ix; + } + (*current)->hvalue = INVALID_HASH; + } else { + HashDbTerm *del = *current; + *current = (*current)->next; + free_term(tb, del); + did_erase = 1; + } + erts_smp_atomic_dec(&tb->common.nitems); + ++got; + } + --num_left; + if (!did_erase) { + current = &((*current)->next); + } + } + } +done: + BUMP_REDS(p, 1000 - num_left); + if (got) { + try_shrink(tb); + } + RET_TO_BIF(erts_make_integer(got,p),DB_ERROR_NONE); +trap: + BUMP_ALL_REDS(p); + if (IS_USMALL(0, got)) { + hp = HAlloc(p, PROC_BIN_SIZE + 5); + egot = make_small(got); + } + else { + hp = HAlloc(p, BIG_UINT_HEAP_SIZE + PROC_BIN_SIZE + 5); + egot = uint_to_big(got, hp); + hp += BIG_UINT_HEAP_SIZE; + } + mpb = db_make_mp_binary(p,mpi.mp,&hp); + continuation = TUPLE4(hp, tb->common.id, make_small(slot_ix), + mpb, + egot); + mpi.mp = NULL; /*otherwise the return macro will destroy it */ + RET_TO_BIF(bif_trap1(&ets_select_delete_continue_exp, p, + continuation), + DB_ERROR_NONE); + +#undef RET_TO_BIF + +} +/* +** This is called when select_delete traps +*/ +static int db_select_delete_continue_hash(Process *p, + DbTable *tbl, + Eterm continuation, + Eterm *ret) +{ + DbTableHash *tb = &tbl->hash; + Uint slot_ix; + Uint last_pseudo_delete = (Uint)-1; + HashDbTerm **current = NULL; + Uint32 dummy; + Eterm *hp; + int num_left = 1000; + Uint got; + Eterm *tptr; + Binary *mp; + Eterm egot; + int fixated_by_me = ONLY_WRITER(p,tb) ? 0 : 1; /* ToDo: something nicer */ + erts_smp_rwmtx_t* lck; + +#define RET_TO_BIF(Term,RetVal) do { \ + *ret = (Term); \ + return RetVal; \ + } while(0) + + + tptr = tuple_val(continuation); + slot_ix = unsigned_val(tptr[2]); + mp = ((ProcBin *) binary_val(tptr[3]))->val; + if (is_big(tptr[4])) { + got = big_to_uint32(tptr[4]); + } else { + got = unsigned_val(tptr[4]); + } + + lck = WLOCK_HASH(tb,slot_ix); + if (slot_ix >= NACTIVE(tb)) { + WUNLOCK_HASH(lck); + goto done; + } + current = &BUCKET(tb,slot_ix); + + for(;;) { + if ((*current) == NULL) { + if ((slot_ix=next_slot_w(tb,slot_ix,&lck)) == 0) { + goto done; + } + if (num_left <= 0) { + WUNLOCK_HASH(lck); + goto trap; + } + current = &BUCKET(tb,slot_ix); + } + else if ((*current)->hvalue == INVALID_HASH) { + current = &((*current)->next); + } + else { + int did_erase = 0; + if ((db_prog_match(p,mp,make_tuple((*current)->dbterm.tpl), + 0,&dummy)) == am_true) { + if (NFIXED(tb) > fixated_by_me) { /* fixated by others? */ + if (slot_ix != last_pseudo_delete) { + add_fixed_deletion(tb, slot_ix); + last_pseudo_delete = slot_ix; + } + (*current)->hvalue = INVALID_HASH; + } else { + HashDbTerm *del = *current; + *current = (*current)->next; + free_term(tb, del); + did_erase = 1; + } + erts_smp_atomic_dec(&tb->common.nitems); + ++got; + } + + --num_left; + if (!did_erase) { + current = &((*current)->next); + } + } + } +done: + BUMP_REDS(p, 1000 - num_left); + if (got) { + try_shrink(tb); + } + RET_TO_BIF(erts_make_integer(got,p),DB_ERROR_NONE); +trap: + BUMP_ALL_REDS(p); + if (IS_USMALL(0, got)) { + hp = HAlloc(p, 5); + egot = make_small(got); + } + else { + hp = HAlloc(p, BIG_UINT_HEAP_SIZE + 5); + egot = uint_to_big(got, hp); + hp += BIG_UINT_HEAP_SIZE; + } + continuation = TUPLE4(hp, tb->common.id, make_small(slot_ix), + tptr[3], + egot); + RET_TO_BIF(bif_trap1(&ets_select_delete_continue_exp, p, + continuation), + DB_ERROR_NONE); + +#undef RET_TO_BIF + +} + +/* +** This is called when select_count traps +*/ +static int db_select_count_continue_hash(Process *p, + DbTable *tbl, + Eterm continuation, + Eterm *ret) +{ + DbTableHash *tb = &tbl->hash; + Uint slot_ix; + HashDbTerm* current; + Uint32 dummy; + Eterm *hp; + int num_left = 1000; + Uint got; + Eterm *tptr; + Binary *mp; + Eterm egot; + erts_smp_rwmtx_t* lck; + +#define RET_TO_BIF(Term,RetVal) do { \ + *ret = (Term); \ + return RetVal; \ + } while(0) + + + tptr = tuple_val(continuation); + slot_ix = unsigned_val(tptr[2]); + mp = ((ProcBin *) binary_val(tptr[3]))->val; + if (is_big(tptr[4])) { + got = big_to_uint32(tptr[4]); + } else { + got = unsigned_val(tptr[4]); + } + + + lck = RLOCK_HASH(tb, slot_ix); + if (slot_ix >= NACTIVE(tb)) { /* Is this posible? */ + RUNLOCK_HASH(lck); + goto done; + } + current = BUCKET(tb,slot_ix); + + for(;;) { + if (current != NULL) { + if (current->hvalue == INVALID_HASH) { + current = current->next; + continue; + } + if (db_prog_match(p, mp, make_tuple(current->dbterm.tpl), + 0,&dummy) == am_true) { + ++got; + } + --num_left; + current = current->next; + } + else { /* next bucket */ + if ((slot_ix = next_slot(tb,slot_ix,&lck)) == 0) { + goto done; + } + if (num_left <= 0) { + RUNLOCK_HASH(lck); + goto trap; + } + current = BUCKET(tb,slot_ix); + } + } +done: + BUMP_REDS(p, 1000 - num_left); + RET_TO_BIF(erts_make_integer(got,p),DB_ERROR_NONE); +trap: + BUMP_ALL_REDS(p); + if (IS_USMALL(0, got)) { + hp = HAlloc(p, 5); + egot = make_small(got); + } + else { + hp = HAlloc(p, BIG_UINT_HEAP_SIZE + 5); + egot = uint_to_big(got, hp); + hp += BIG_UINT_HEAP_SIZE; + } + continuation = TUPLE4(hp, tb->common.id, make_small(slot_ix), + tptr[3], + egot); + RET_TO_BIF(bif_trap1(&ets_select_count_continue_exp, p, + continuation), + DB_ERROR_NONE); + +#undef RET_TO_BIF + +} + +/* +** Other interface routines (not directly coupled to one bif) +*/ + +void db_initialize_hash(void) +{ +} + + +int db_mark_all_deleted_hash(DbTable *tbl) +{ + DbTableHash *tb = &tbl->hash; + HashDbTerm* list; + int i; + + ERTS_SMP_LC_ASSERT(IS_TAB_WLOCKED(tb)); + + for (i = 0; i < NACTIVE(tb); i++) { + if ((list = BUCKET(tb,i)) != NULL) { + add_fixed_deletion(tb, i); + do { + list->hvalue = INVALID_HASH; + list = list->next; + }while(list != NULL); + } + } + erts_smp_atomic_set(&tb->common.nitems, 0); + return DB_ERROR_NONE; +} + + +/* Display hash table contents (for dump) */ +static void db_print_hash(int to, void *to_arg, int show, DbTable *tbl) +{ + DbTableHash *tb = &tbl->hash; + int i; + + erts_print(to, to_arg, "Buckets: %d \n", NACTIVE(tb)); + + if (show) { + for (i = 0; i < NACTIVE(tb); i++) { + HashDbTerm* list = BUCKET(tb,i); + if (list == NULL) + continue; + erts_print(to, to_arg, "%d: [", i); + while(list != 0) { + if (list->hvalue == INVALID_HASH) + erts_print(to, to_arg, "*"); + erts_print(to, to_arg, "%T", make_tuple(list->dbterm.tpl)); + if (list->next != 0) + erts_print(to, to_arg, ","); + list = list->next; + } + erts_print(to, to_arg, "]\n"); + } + } +} + +/* release all memory occupied by a single table */ +static int db_free_table_hash(DbTable *tbl) +{ + while (!db_free_table_continue_hash(tbl)) + ; + return 0; +} + +static int db_free_table_continue_hash(DbTable *tbl) +{ + DbTableHash *tb = &tbl->hash; + int done; + FixedDeletion* fixdel = (FixedDeletion*) erts_smp_atomic_read(&tb->fixdel); + ERTS_SMP_LC_ASSERT(IS_TAB_WLOCKED(tb)); + + done = 0; + while (fixdel != NULL) { + FixedDeletion *fx = fixdel; + + fixdel = fx->next; + erts_db_free(ERTS_ALC_T_DB_FIX_DEL, + (DbTable *) tb, + (void *) fx, + sizeof(FixedDeletion)); + ERTS_ETS_MISC_MEM_ADD(-sizeof(FixedDeletion)); + if (++done >= 2*DELETE_RECORD_LIMIT) { + erts_smp_atomic_set(&tb->fixdel, (long)fixdel); + return 0; /* Not done */ + } + } + erts_smp_atomic_set(&tb->fixdel, (long)NULL); + + done /= 2; + while(tb->nslots != 0) { + free_seg(tb, 1); + + /* + * If we have done enough work, get out here. + */ + if (++done >= (DELETE_RECORD_LIMIT / CHAIN_LEN / SEGSZ)) { + return 0; /* Not done */ + } + } +#ifdef ERTS_SMP + if (tb->locks != NULL) { + int i; + for (i=0; ilocks, sizeof(DbTableHashFineLocks)); + tb->locks = NULL; + } +#endif + ASSERT(erts_smp_atomic_read(&tb->common.memory_size) == sizeof(DbTable)); + return 1; /* Done */ +} + + + +/* +** Utility routines. (static) +*/ +/* +** For the select functions, analyzes the pattern and determines which +** slots should be searched. Also compiles the match program +*/ +static int analyze_pattern(DbTableHash *tb, Eterm pattern, + struct mp_info *mpi) +{ + Eterm *ptpl; + Eterm lst, tpl, ttpl; + Eterm *matches,*guards, *bodies; + Eterm sbuff[30]; + Eterm *buff = sbuff; + Eterm key = NIL; + HashValue hval = NIL; + int num_heads = 0; + int i; + + mpi->lists = mpi->dlists; + mpi->num_lists = 0; + mpi->key_given = 1; + mpi->something_can_match = 0; + mpi->all_objects = 1; + mpi->mp = NULL; + + for (lst = pattern; is_list(lst); lst = CDR(list_val(lst))) + ++num_heads; + + if (lst != NIL) {/* proper list... */ + return DB_ERROR_BADPARAM; + } + + if (num_heads > 10) { + buff = erts_alloc(ERTS_ALC_T_DB_TMP, sizeof(Eterm) * num_heads * 3); + mpi->lists = erts_alloc(ERTS_ALC_T_DB_SEL_LIST, + sizeof(*(mpi->lists)) * num_heads); + } + + matches = buff; + guards = buff + num_heads; + bodies = buff + (num_heads * 2); + + i = 0; + for(lst = pattern; is_list(lst); lst = CDR(list_val(lst))) { + Eterm body; + ttpl = CAR(list_val(lst)); + if (!is_tuple(ttpl)) { + if (buff != sbuff) { + erts_free(ERTS_ALC_T_DB_TMP, buff); + } + return DB_ERROR_BADPARAM; + } + ptpl = tuple_val(ttpl); + if (ptpl[0] != make_arityval(3U)) { + if (buff != sbuff) { + erts_free(ERTS_ALC_T_DB_TMP, buff); + } + return DB_ERROR_BADPARAM; + } + matches[i] = tpl = ptpl[1]; + guards[i] = ptpl[2]; + bodies[i] = body = ptpl[3]; + if (!is_list(body) || CDR(list_val(body)) != NIL || + CAR(list_val(body)) != am_DollarUnderscore) { + mpi->all_objects = 0; + } + ++i; + if (!(mpi->key_given)) { + continue; + } + if (tpl == am_Underscore || db_is_variable(tpl) != -1) { + (mpi->key_given) = 0; + (mpi->something_can_match) = 1; + } else { + key = db_getkey(tb->common.keypos, tpl); + if (is_value(key)) { + if (!db_has_variable(key)) { /* Bound key */ + int ix, search_slot; + HashDbTerm** bp; + erts_smp_rwmtx_t* lck; + hval = MAKE_HASH(key); + lck = RLOCK_HASH(tb,hval); + ix = hash_to_ix(tb, hval); + bp = &BUCKET(tb,ix); + if (lck == NULL) { + search_slot = search_list(tb,key,hval,*bp) != NULL; + } else { + /* No point to verify if key exist now as there may be + concurrent inserters/deleters anyway */ + RUNLOCK_HASH(lck); + search_slot = 1; + } + if (search_slot) { + int j; + for (j=0; ; ++j) { + if (j == mpi->num_lists) { + mpi->lists[mpi->num_lists].bucket = bp; + mpi->lists[mpi->num_lists].ix = ix; + ++mpi->num_lists; + break; + } + if (mpi->lists[j].bucket == bp) { + ASSERT(mpi->lists[j].ix == ix); + break; + } + ASSERT(mpi->lists[j].ix != ix); + } + mpi->something_can_match = 1; + } + } else { + mpi->key_given = 0; + mpi->something_can_match = 1; + } + } + } + } + + /* + * It would be nice not to compile the match_spec if nothing could match, + * but then the select calls would not fail like they should on bad + * match specs that happen to specify non existent keys etc. + */ + if ((mpi->mp = db_match_compile(matches, guards, bodies, + num_heads, DCOMP_TABLE, NULL)) + == NULL) { + if (buff != sbuff) { + erts_free(ERTS_ALC_T_DB_TMP, buff); + } + return DB_ERROR_BADPARAM; + } + if (buff != sbuff) { + erts_free(ERTS_ALC_T_DB_TMP, buff); + } + return DB_ERROR_NONE; +} + +static struct ext_segment* alloc_ext_seg(DbTableHash* tb, unsigned seg_ix, + struct segment** old_segtab) +{ + int nsegs; + struct ext_segment* eseg; + + switch (seg_ix) { + case 0: nsegs = NSEG_1; break; + case 1: nsegs = NSEG_2; break; + default: nsegs = seg_ix + NSEG_INC; break; + } + eseg = (struct ext_segment*) erts_db_alloc_fnf(ERTS_ALC_T_DB_SEG, + (DbTable *) tb, + SIZEOF_EXTSEG(nsegs)); + ASSERT(eseg != NULL); + sys_memset(&eseg->s, 0, sizeof(struct segment)); + IF_DEBUG(eseg->s.is_ext_segment = 1); + eseg->prev_segtab = old_segtab; + eseg->nsegs = nsegs; + if (old_segtab) { + ASSERT(nsegs > tb->nsegs); + sys_memcpy(eseg->segtab, old_segtab, tb->nsegs*sizeof(struct segment*)); + } +#ifdef DEBUG + sys_memset(&eseg->segtab[seg_ix], 0, (nsegs-seg_ix)*sizeof(struct segment*)); +#endif + eseg->segtab[seg_ix] = &eseg->s; + return eseg; +} + +/* Extend table with one new segment +*/ +static int alloc_seg(DbTableHash *tb) +{ + int seg_ix = tb->nslots >> SEGSZ_EXP; + + if (seg_ix+1 == tb->nsegs) { /* New segtab needed (extended segment) */ + struct segment** segtab = SEGTAB(tb); + struct ext_segment* seg = alloc_ext_seg(tb, seg_ix, segtab); + if (seg == NULL) return 0; + segtab[seg_ix] = &seg->s; + /* We don't use the new segtab until next call (see "shrink race") */ + } + else { /* Just a new plain segment */ + struct segment** segtab; + if (seg_ix == tb->nsegs) { /* Time to start use segtab from last call */ + struct ext_segment* eseg; + eseg = (struct ext_segment*) SEGTAB(tb)[seg_ix-1]; + MY_ASSERT(eseg!=NULL && eseg->s.is_ext_segment); + erts_smp_atomic_set(&tb->segtab, (long) eseg->segtab); + tb->nsegs = eseg->nsegs; + } + ASSERT(seg_ix < tb->nsegs); + segtab = SEGTAB(tb); + ASSERT(segtab[seg_ix] == NULL); + segtab[seg_ix] = (struct segment*) erts_db_alloc_fnf(ERTS_ALC_T_DB_SEG, + (DbTable *) tb, + sizeof(struct segment)); + if (segtab[seg_ix] == NULL) return 0; + sys_memset(segtab[seg_ix], 0, sizeof(struct segment)); + } + tb->nslots += SEGSZ; + return 1; +} + +/* Shrink table by freeing the top segment +** free_records: 1=free any records in segment, 0=assume segment is empty +*/ +static int free_seg(DbTableHash *tb, int free_records) +{ + int seg_ix = (tb->nslots >> SEGSZ_EXP) - 1; + int bytes; + struct segment** segtab = SEGTAB(tb); + struct ext_segment* top = (struct ext_segment*) segtab[seg_ix]; + int nrecords = 0; + + ASSERT(top != NULL); +#ifndef DEBUG + if (free_records) +#endif + { + int i; + for (i=0; is.buckets[i]; + while(p != 0) { + HashDbTerm* nxt = p->next; + ASSERT(free_records); /* segment not empty as assumed? */ + free_term(tb, p); + p = nxt; + ++nrecords; + } + } + } + + /* The "shrink race": + * We must avoid deallocating an extended segment while its segtab may + * still be used by other threads. + * The trick is to stop use a segtab one call earlier. That is, stop use + * a segtab when the segment above it is deallocated. When the segtab is + * later deallocated, it has not been used for a very long time. + * It is even theoretically safe as we have by then rehashed the entire + * segment, seizing *all* locks, so there cannot exist any retarded threads + * still hanging in BUCKET macro with an old segtab pointer. + * For this to work, we must of course allocate a new segtab one call + * earlier in alloc_seg() as well. And this is also the reason why + * the minimum size of the first segtab is 2 and not 1 (NSEG_1). + */ + + if (seg_ix == tb->nsegs-1 || seg_ix==0) { /* Dealloc extended segment */ + MY_ASSERT(top->s.is_ext_segment); + ASSERT(segtab != top->segtab || seg_ix==0); + bytes = SIZEOF_EXTSEG(top->nsegs); + } + else { /* Dealloc plain segment */ + struct ext_segment* newtop = (struct ext_segment*) segtab[seg_ix-1]; + MY_ASSERT(!top->s.is_ext_segment); + + if (segtab == newtop->segtab) { /* New top segment is extended */ + MY_ASSERT(newtop->s.is_ext_segment); + if (newtop->prev_segtab != NULL) { + /* Time to use a smaller segtab */ + erts_smp_atomic_set(&tb->segtab, (long)newtop->prev_segtab); + tb->nsegs = seg_ix; + ASSERT(tb->nsegs == EXTSEG(SEGTAB(tb))->nsegs); + } + else { + ASSERT(NSEG_1 > 2 && seg_ix==1); + } + } + bytes = sizeof(struct segment); + } + + erts_db_free(ERTS_ALC_T_DB_SEG, (DbTable *)tb, + (void*)top, bytes); +#ifdef DEBUG + if (seg_ix > 0) { + if (seg_ix < tb->nsegs) SEGTAB(tb)[seg_ix] = NULL; + } else { + erts_smp_atomic_set(&tb->segtab, (long)NULL); + } +#endif + tb->nslots -= SEGSZ; + ASSERT(tb->nslots >= 0); + return nrecords; +} + + +static HashDbTerm* get_term(DbTableHash* tb, HashDbTerm* old, + Eterm obj, HashValue hval) +{ + HashDbTerm* p = db_get_term((DbTableCommon *) tb, + (old != NULL) ? &(old->dbterm) : NULL, + ((char *) &(old->dbterm)) - ((char *) old), + obj); + p->hvalue = hval; + /*p->next = NULL;*/ /*No Need */ + return p; +} + + +/* +** Copy terms from ptr1 until ptr2 +** works for ptr1 == ptr2 == 0 => [] +** or ptr2 == 0 +*/ +static Eterm put_term_list(Process* p, HashDbTerm* ptr1, HashDbTerm* ptr2) +{ + int sz = 0; + HashDbTerm* ptr; + Eterm list = NIL; + Eterm copy; + Eterm *hp; + + ptr = ptr1; + while(ptr != ptr2) { + + if (ptr->hvalue != INVALID_HASH) + sz += ptr->dbterm.size + 2; + + ptr = ptr->next; + } + + hp = HAlloc(p, sz); + + ptr = ptr1; + while(ptr != ptr2) { + if (ptr->hvalue != INVALID_HASH) { + copy = copy_shallow(DBTERM_BUF(&ptr->dbterm), ptr->dbterm.size, &hp, &MSO(p)); + list = CONS(hp, copy, list); + hp += 2; + } + ptr = ptr->next; + } + return list; +} + +static void free_term(DbTableHash *tb, HashDbTerm* p) +{ + db_free_term_data(&(p->dbterm)); + erts_db_free(ERTS_ALC_T_DB_TERM, + (DbTable *) tb, + (void *) p, + SIZ_DBTERM(p)*sizeof(Eterm)); +} + +/* Grow table with one new bucket. +** Allocate new segment if needed. +*/ +static void grow(DbTableHash* tb, int nactive) +{ + HashDbTerm** pnext; + HashDbTerm** to_pnext; + HashDbTerm* p; + erts_smp_rwmtx_t* lck; + int from_ix; + int szm; + + if (erts_smp_atomic_xchg(&tb->is_resizing, 1)) { + return; /* already in progress */ + } + if (NACTIVE(tb) != nactive) { + goto abort; /* already done (race) */ + } + + /* Ensure that the slot nactive exists */ + if (nactive == tb->nslots) { + /* Time to get a new segment */ + ASSERT((nactive & SEGSZ_MASK) == 0); + if (!alloc_seg(tb)) goto abort; + } + ASSERT(nactive < tb->nslots); + + szm = erts_smp_atomic_read(&tb->szm); + if (nactive <= szm) { + from_ix = nactive & (szm >> 1); + } else { + ASSERT(nactive == szm+1); + from_ix = 0; + szm = (szm<<1) | 1; + } + + lck = WLOCK_HASH(tb, from_ix); + /* Now a final double check (with the from_ix lock held) + * that we did not get raced by a table fixer. + */ + if (IS_FIXED(tb)) { + WUNLOCK_HASH(lck); + goto abort; + } + erts_smp_atomic_inc(&tb->nactive); + if (from_ix == 0) { + erts_smp_atomic_set(&tb->szm, szm); + } + erts_smp_atomic_set(&tb->is_resizing, 0); + + /* Finally, let's split the bucket. We try to do it in a smart way + to keep link order and avoid unnecessary updates of next-pointers */ + pnext = &BUCKET(tb, from_ix); + p = *pnext; + to_pnext = &BUCKET(tb, nactive); + while (p != NULL) { + if (p->hvalue == INVALID_HASH) { /* rare but possible with fine locking */ + *pnext = p->next; + free_term(tb, p); + p = *pnext; + } + else { + int ix = p->hvalue & szm; + if (ix != from_ix) { + ASSERT(ix == (from_ix ^ ((szm+1)>>1))); + *to_pnext = p; + /* Swap "from" and "to": */ + from_ix = ix; + to_pnext = pnext; + } + pnext = &p->next; + p = *pnext; + } + } + *to_pnext = NULL; + + WUNLOCK_HASH(lck); + return; + +abort: + erts_smp_atomic_set(&tb->is_resizing, 0); +} + + +/* Shrink table by joining top bucket. +** Remove top segment if it gets empty. +*/ +static void shrink(DbTableHash* tb, int nactive) +{ + if (erts_smp_atomic_xchg(&tb->is_resizing, 1)) { + return; /* already in progress */ + } + if (NACTIVE(tb) == nactive) { + erts_smp_rwmtx_t* lck; + int src_ix = nactive - 1; + int low_szm = erts_smp_atomic_read(&tb->szm) >> 1; + int dst_ix = src_ix & low_szm; + + ASSERT(dst_ix < src_ix); + ASSERT(nactive > SEGSZ); + lck = WLOCK_HASH(tb, dst_ix); + /* Double check for racing table fixers */ + if (!IS_FIXED(tb)) { + HashDbTerm** src_bp = &BUCKET(tb, src_ix); + HashDbTerm** dst_bp = &BUCKET(tb, dst_ix); + HashDbTerm** bp = src_bp; + + /* Q: Why join lists by appending "dst" at the end of "src"? + A: Must step through "src" anyway to purge pseudo deleted. */ + while(*bp != NULL) { + if ((*bp)->hvalue == INVALID_HASH) { + HashDbTerm* deleted = *bp; + *bp = deleted->next; + free_term(tb, deleted); + } else { + bp = &(*bp)->next; + } + } + *bp = *dst_bp; + *dst_bp = *src_bp; + *src_bp = NULL; + + erts_smp_atomic_set(&tb->nactive, src_ix); + if (dst_ix == 0) { + erts_smp_atomic_set(&tb->szm, low_szm); + } + WUNLOCK_HASH(lck); + + if (tb->nslots - src_ix >= SEGSZ) { + free_seg(tb, 0); + } + } + else { + WUNLOCK_HASH(lck); + } + + } + /*else already done */ + erts_smp_atomic_set(&tb->is_resizing, 0); +} + + +/* Search a list of tuples for a matching key */ + +static HashDbTerm* search_list(DbTableHash* tb, Eterm key, + HashValue hval, HashDbTerm *list) +{ + while (list != 0) { + if (has_live_key(tb,list,key,hval)) + return list; + list = list->next; + } + return 0; +} + + +/* This function is called by the next AND the select BIF */ +/* It return the next live object in a table, NULL if no more */ +/* In-bucket: RLOCKED */ +/* Out-bucket: RLOCKED unless NULL */ +static HashDbTerm* next(DbTableHash *tb, Uint *iptr, erts_smp_rwmtx_t** lck_ptr, + HashDbTerm *list) +{ + int i; + + ERTS_SMP_LC_ASSERT(IS_HASH_RLOCKED(tb,*iptr)); + + for (list = list->next; list != NULL; list = list->next) { + if (list->hvalue != INVALID_HASH) + return list; + } + + i = *iptr; + while ((i=next_slot(tb, i, lck_ptr)) != 0) { + + list = BUCKET(tb,i); + while (list != NULL) { + if (list->hvalue != INVALID_HASH) { + *iptr = i; + return list; + } + list = list->next; + } + } + /* *iptr = ??? */ + return NULL; +} + +static int db_lookup_dbterm_hash(DbTable *tbl, Eterm key, DbUpdateHandle* handle) +{ + DbTableHash *tb = &tbl->hash; + HashDbTerm* b; + HashDbTerm** prevp; + int ix; + HashValue hval; + erts_smp_rwmtx_t* lck; + + hval = MAKE_HASH(key); + lck = WLOCK_HASH(tb,hval); + ix = hash_to_ix(tb, hval); + prevp = &BUCKET(tb, ix); + b = *prevp; + + while (b != 0) { + if (has_live_key(tb,b,key,hval)) { + handle->tb = tbl; + handle->bp = (void**) prevp; + handle->dbterm = &b->dbterm; + handle->new_size = b->dbterm.size; + handle->mustResize = 0; + handle->lck = lck; + /* KEEP hval WLOCKED, db_finalize_dbterm_hash will WUNLOCK */ + return 1; + } + prevp = &b->next; + b = *prevp; + } + WUNLOCK_HASH(lck); + return 0; +} + +/* Must be called after call to db_lookup_dbterm +*/ +static void db_finalize_dbterm_hash(DbUpdateHandle* handle) +{ + DbTable* tbl = handle->tb; + HashDbTerm* oldp = (HashDbTerm*) *(handle->bp); + erts_smp_rwmtx_t* lck = (erts_smp_rwmtx_t*) handle->lck; + + ERTS_SMP_LC_ASSERT(IS_HASH_WLOCKED(&tbl->hash,lck)); /* locked by db_lookup_dbterm_hash */ + ASSERT(&oldp->dbterm == handle->dbterm); + + if (handle->mustResize) { + Eterm* top; + Eterm copy; + DbTerm* newDbTerm; + HashDbTerm* newp = erts_db_alloc(ERTS_ALC_T_DB_TERM, tbl, + sizeof(HashDbTerm)+sizeof(Eterm)*(handle->new_size-1)); + sys_memcpy(newp, oldp, sizeof(HashDbTerm)-sizeof(DbTerm)); /* copy only hashtab header */ + *(handle->bp) = newp; + newDbTerm = &newp->dbterm; + + newDbTerm->size = handle->new_size; + newDbTerm->off_heap.mso = NULL; + newDbTerm->off_heap.externals = NULL; + #ifndef HYBRID /* FIND ME! */ + newDbTerm->off_heap.funs = NULL; + #endif + newDbTerm->off_heap.overhead = 0; + + /* make a flat copy */ + top = DBTERM_BUF(newDbTerm); + copy = copy_struct(make_tuple(handle->dbterm->tpl), + handle->new_size, + &top, &newDbTerm->off_heap); + DBTERM_SET_TPL(newDbTerm,tuple_val(copy)); + + WUNLOCK_HASH(lck); + + db_free_term_data(handle->dbterm); + erts_db_free(ERTS_ALC_T_DB_TERM, tbl, + (void *) (((char *) handle->dbterm) - (sizeof(HashDbTerm) - sizeof(DbTerm))), + sizeof(HashDbTerm) + sizeof(Eterm)*(handle->dbterm->size-1)); + } + else { + WUNLOCK_HASH(lck); + } +#ifdef DEBUG + handle->dbterm = 0; +#endif + return; +} + +static int db_delete_all_objects_hash(Process* p, DbTable* tbl) +{ + if (IS_FIXED(tbl)) { + db_mark_all_deleted_hash(tbl); + } else { + db_free_table_hash(tbl); + db_create_hash(p, tbl); + erts_smp_atomic_set(&tbl->hash.common.nitems, 0); + } + return 0; +} + +void db_foreach_offheap_hash(DbTable *tbl, + void (*func)(ErlOffHeap *, void *), + void * arg) +{ + DbTableHash *tb = &tbl->hash; + HashDbTerm* list; + int i; + int nactive = NACTIVE(tb); + + for (i = 0; i < nactive; i++) { + list = BUCKET(tb,i); + while(list != 0) { + (*func)(&(list->dbterm.off_heap), arg); + list = list->next; + } + } +} + +void db_calc_stats_hash(DbTableHash* tb, DbHashStats* stats) +{ + HashDbTerm* b; + erts_smp_rwmtx_t* lck; + int sum = 0; + int sq_sum = 0; + int ix; + int len; + + stats->min_chain_len = INT_MAX; + stats->max_chain_len = 0; + ix = 0; + lck = RLOCK_HASH(tb,ix); + do { + len = 0; + for (b = BUCKET(tb,ix); b!=NULL; b=b->next) { + len++; + } + sum += len; + sq_sum += len*len; + if (len < stats->min_chain_len) stats->min_chain_len = len; + if (len > stats->max_chain_len) stats->max_chain_len = len; + ix = next_slot(tb,ix,&lck); + }while (ix); + stats->avg_chain_len = (float)sum / NACTIVE(tb); + stats->std_dev_chain_len = sqrt((sq_sum - stats->avg_chain_len*sum) / NACTIVE(tb)); + /* Expected standard deviation from a good uniform hash function, + ie binomial distribution (not taking the linear hashing into acount) */ + stats->std_dev_expected = sqrt(stats->avg_chain_len * (1 - 1.0/NACTIVE(tb))); +} +#ifdef HARDDEBUG + +void db_check_table_hash(DbTable *tbl) +{ + DbTableHash *tb = &tbl->hash; + HashDbTerm* list; + int j; + + for (j = 0; j < tb->nactive; j++) { + if ((list = BUCKET(tb,j)) != 0) { + while (list != 0) { + if (!is_tuple(make_tuple(list->dbterm.tpl))) { + erl_exit(1, "Bad term in slot %d of ets table", j); + } + list = list->next; + } + } + } +} + +#endif diff --git a/erts/emulator/beam/erl_db_hash.h b/erts/emulator/beam/erl_db_hash.h new file mode 100644 index 0000000000..e0285fa5ed --- /dev/null +++ b/erts/emulator/beam/erl_db_hash.h @@ -0,0 +1,103 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1998-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifndef _DB_HASH_H +#define _DB_HASH_H + +#include "erl_db_util.h" /* DbTerm & DbTableCommon */ + +typedef struct fixed_deletion { + int slot; + struct fixed_deletion *next; +} FixedDeletion; + +typedef struct hash_db_term { + struct hash_db_term* next; /* next bucket */ + HashValue hvalue; /* stored hash value */ + DbTerm dbterm; /* The actual term */ +} HashDbTerm; + +#define DB_HASH_LOCK_CNT 16 +typedef struct db_table_hash_fine_locks { + union { + erts_smp_rwmtx_t lck; + byte _cache_line_alignment[64]; + }lck_vec[DB_HASH_LOCK_CNT]; +} DbTableHashFineLocks; + +typedef struct db_table_hash { + DbTableCommon common; + + erts_smp_atomic_t segtab; /* The segment table (struct segment**) */ + erts_smp_atomic_t szm; /* current size mask. */ + + /* SMP: nslots and nsegs are protected by is_resizing or table write lock */ + int nslots; /* Total number of slots */ + int nsegs; /* Size of segment table */ + + /* List of slots where elements have been deleted while table was fixed */ + erts_smp_atomic_t fixdel; /* (FixedDeletion*) */ + erts_smp_atomic_t nactive; /* Number of "active" slots */ + erts_smp_atomic_t is_resizing; /* grow/shrink in progress */ +#ifdef ERTS_SMP + DbTableHashFineLocks* locks; +#endif +} DbTableHash; + + +/* +** Function prototypes, looks the same (except the suffix) for all +** table types. The process is always an [in out] parameter. +*/ +void db_initialize_hash(void); +void db_unfix_table_hash(DbTableHash *tb /* [in out] */); +Uint db_kept_items_hash(DbTableHash *tb); + +/* Interface for meta pid table */ +int db_create_hash(Process *p, + DbTable *tbl /* [in out] */); + +int db_put_hash(DbTable *tbl, Eterm obj, int key_clash_fail); + +int db_get_hash(Process *p, DbTable *tbl, Eterm key, Eterm *ret); + +int db_erase_hash(DbTable *tbl, Eterm key, Eterm *ret); + +int db_get_element_array(DbTable *tbl, + Eterm key, + int ndex, + Eterm *ret, + int *num_ret); + +int db_erase_bag_exact2(DbTable *tbl, Eterm key, Eterm value); + +/* not yet in method table */ +int db_mark_all_deleted_hash(DbTable *tbl); + +typedef struct { + float avg_chain_len; + float std_dev_chain_len; + float std_dev_expected; + int max_chain_len; + int min_chain_len; +}DbHashStats; + +void db_calc_stats_hash(DbTableHash* tb, DbHashStats*); + +#endif /* _DB_HASH_H */ diff --git a/erts/emulator/beam/erl_db_tree.c b/erts/emulator/beam/erl_db_tree.c new file mode 100644 index 0000000000..d3a916d2d9 --- /dev/null +++ b/erts/emulator/beam/erl_db_tree.c @@ -0,0 +1,3289 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1998-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* +** Implementation of ordered ETS tables. +** The tables are implemented as AVL trees (Published by Adelson-Velski +** and Landis). A nice source for learning about these trees is +** Wirth's Algorithms + Datastructures = Programs. +** The implementation here is however not made with recursion +** as the examples in Wirths book are. +*/ + +/* +#ifdef DEBUG +#define HARDDEBUG 1 +#endif +*/ +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "erl_process.h" +#include "error.h" +#define ERTS_WANT_DB_INTERNAL__ +#include "erl_db.h" +#include "bif.h" +#include "big.h" +#include "erl_binary.h" + +#include "erl_db_tree.h" + + + +#define GETKEY(dtt, tplp) (*((tplp) + (dtt)->common.keypos)) +#define GETKEY_WITH_POS(Keypos, Tplp) (*((Tplp) + Keypos)) +#define NITEMS(tb) ((int)erts_smp_atomic_read(&(tb)->common.nitems)) + +/* +** A stack of this size is enough for an AVL tree with more than +** 0xFFFFFFFF elements. May be subject to change if +** the datatype of the element counter is changed to a 64 bit integer. +** The Maximal height of an AVL tree is calculated as: +** h(n) <= 1.4404 * log(n + 2) - 0.328 +** Where n denotes the number of nodes, h(n) the height of the tree +** with n nodes and log is the binary logarithm. +*/ + +#define STACK_NEED 50 +#define TREE_MAX_ELEMENTS 0xFFFFFFFFUL + +#define PUSH_NODE(Dtt, Tdt) \ + ((Dtt)->array[(Dtt)->pos++] = Tdt) + +#define POP_NODE(Dtt) \ + (((Dtt)->pos) ? \ + (Dtt)->array[--((Dtt)->pos)] : NULL) + +#define TOP_NODE(Dtt) \ + ((Dtt->pos) ? \ + (Dtt)->array[(Dtt)->pos - 1] : NULL) + +#define EMPTY_NODE(Dtt) (TOP_NODE(Dtt) == NULL) + + + +/* Obtain table static stack if available. NULL if not. +** Must be released with release_stack() +*/ +static DbTreeStack* get_static_stack(DbTableTree* tb) +{ + if (!erts_smp_atomic_xchg(&tb->is_stack_busy, 1)) { + return &tb->static_stack; + } + return NULL; +} + +/* Obtain static stack if available, otherwise empty dynamic stack. +** Must be released with release_stack() +*/ +static DbTreeStack* get_any_stack(DbTableTree* tb) +{ + DbTreeStack* stack; + if (!erts_smp_atomic_xchg(&tb->is_stack_busy, 1)) { + return &tb->static_stack; + } + stack = erts_db_alloc(ERTS_ALC_T_DB_STK, (DbTable *) tb, + sizeof(DbTreeStack) + sizeof(TreeDbTerm*) * STACK_NEED); + stack->pos = 0; + stack->slot = 0; + stack->array = (TreeDbTerm**) (stack + 1); + return stack; +} + +static void release_stack(DbTableTree* tb, DbTreeStack* stack) +{ + if (stack == &tb->static_stack) { + ASSERT(erts_smp_atomic_read(&tb->is_stack_busy) == 1); + erts_smp_atomic_set(&tb->is_stack_busy, 0); + } + else { + erts_db_free(ERTS_ALC_T_DB_STK, (DbTable *) tb, + (void *) stack, sizeof(DbTreeStack) + sizeof(TreeDbTerm*) * STACK_NEED); + } +} + +static void reset_static_stack(DbTableTree* tb) +{ + tb->static_stack.pos = 0; + tb->static_stack.slot = 0; +} + + +/* +** Some macros for "direction stacks" +*/ +#define DIR_LEFT 0 +#define DIR_RIGHT 1 +#define DIR_END 2 + +/* + * Special binary flag + */ +#define BIN_FLAG_ALL_OBJECTS BIN_FLAG_USR1 + +/* + * Number of records to delete before trapping. + */ +#define DELETE_RECORD_LIMIT 12000 + +/* +** Debugging +*/ +#ifdef HARDDEBUG +static TreeDbTerm *traverse_until(TreeDbTerm *t, int *current, int to); +static void check_slot_pos(DbTableTree *tb); +static void check_saved_stack(DbTableTree *tb); +static int check_table_tree(TreeDbTerm *t); + +#define TREE_DEBUG +#endif + +#ifdef TREE_DEBUG +/* +** Primitive trace macro +*/ +#define DBG erts_fprintf(stderr,"%d\n",__LINE__) + +/* +** Debugging dump +*/ + +static void do_dump_tree2(int to, void *to_arg, int show, TreeDbTerm *t, + int offset); + +#else + +#define DBG /* nothing */ + +#endif + +/* + * Size calculations + */ +#define SIZ_OVERHEAD ((sizeof(TreeDbTerm)/sizeof(Eterm)) - 1) +#define SIZ_DBTERM(TDT) (SIZ_OVERHEAD + (TDT)->dbterm.size) + +/* +** Datatypes +*/ + +/* + * This structure is filled in by analyze_pattern() for the select + * functions. + */ +struct mp_info { + int all_objects; /* True if complete objects are always + * returned from the match_spec (can use + * copy_shallow on the return value) */ + int something_can_match; /* The match_spec is not "impossible" */ + int some_limitation; /* There is some limitation on the search + * area, i. e. least and/or most is set.*/ + int got_partial; /* The limitation has a partially bound + * key */ + Eterm least; /* The lowest matching key (possibly + * partially bound expression) */ + Eterm most; /* The highest matching key (possibly + * partially bound expression) */ + + TreeDbTerm *save_term; /* If the key is completely bound, this + * will be the Tree node we're searching + * for, otherwise it will be useless */ + Binary *mp; /* The compiled match program */ +}; + +/* + * Used by doit_select(_chunk) + */ +struct select_context { + Process *p; + Eterm accum; + Binary *mp; + Eterm end_condition; + Eterm *lastobj; + Sint32 max; + int keypos; + int all_objects; + Sint got; + Sint chunk_size; +}; + +/* + * Used by doit_select_count + */ +struct select_count_context { + Process *p; + Binary *mp; + Eterm end_condition; + Eterm *lastobj; + Sint32 max; + int keypos; + int all_objects; + Sint got; +}; + +/* + * Used by doit_select_delete + */ +struct select_delete_context { + Process *p; + DbTableTree *tb; + Uint accum; + Binary *mp; + Eterm end_condition; + int erase_lastterm; + TreeDbTerm *lastterm; + Sint32 max; + int keypos; +}; + +/* +** Forward declarations +*/ +static TreeDbTerm *linkout_tree(DbTableTree *tb, Eterm key); +static TreeDbTerm *linkout_object_tree(DbTableTree *tb, + Eterm object); +static int do_free_tree_cont(DbTableTree *tb, int num_left); +static TreeDbTerm* get_term(DbTableTree *tb, + TreeDbTerm* old, + Eterm obj); +static void free_term(DbTableTree *tb, TreeDbTerm* p); +static int balance_left(TreeDbTerm **this); +static int balance_right(TreeDbTerm **this); +static int delsub(TreeDbTerm **this); +static TreeDbTerm *slot_search(Process *p, DbTableTree *tb, Sint slot); +static TreeDbTerm *find_node(DbTableTree *tb, Eterm key); +static TreeDbTerm **find_node2(DbTableTree *tb, Eterm key); +static TreeDbTerm *find_next(DbTableTree *tb, DbTreeStack*, Eterm key); +static TreeDbTerm *find_prev(DbTableTree *tb, DbTreeStack*, Eterm key); +static TreeDbTerm *find_next_from_pb_key(DbTableTree *tb, DbTreeStack*, + Eterm key); +static TreeDbTerm *find_prev_from_pb_key(DbTableTree *tb, DbTreeStack*, + Eterm key); +static void traverse_backwards(DbTableTree *tb, + DbTreeStack*, + Eterm lastkey, + int (*doit)(DbTableTree *tb, + TreeDbTerm *, + void *, + int), + void *context); +static void traverse_forward(DbTableTree *tb, + DbTreeStack*, + Eterm lastkey, + int (*doit)(DbTableTree *tb, + TreeDbTerm *, + void *, + int), + void *context); +static int key_given(DbTableTree *tb, Eterm pattern, TreeDbTerm **ret, + Eterm *partly_bound_key); +static Sint cmp_partly_bound(Eterm partly_bound_key, Eterm bound_key); +static Sint do_cmp_partly_bound(Eterm a, Eterm b, int *done); + +static int analyze_pattern(DbTableTree *tb, Eterm pattern, + struct mp_info *mpi); +static int doit_select(DbTableTree *tb, + TreeDbTerm *this, + void *ptr, + int forward); +static int doit_select_count(DbTableTree *tb, + TreeDbTerm *this, + void *ptr, + int forward); +static int doit_select_chunk(DbTableTree *tb, + TreeDbTerm *this, + void *ptr, + int forward); +static int doit_select_delete(DbTableTree *tb, + TreeDbTerm *this, + void *ptr, + int forward); +static void do_dump_tree(int to, void *to_arg, TreeDbTerm *t); + +static int partly_bound_can_match_lesser(Eterm partly_bound_1, + Eterm partly_bound_2); +static int partly_bound_can_match_greater(Eterm partly_bound_1, + Eterm partly_bound_2); +static int do_partly_bound_can_match_lesser(Eterm a, Eterm b, + int *done); +static int do_partly_bound_can_match_greater(Eterm a, Eterm b, + int *done); +static BIF_RETTYPE ets_select_reverse(Process *p, Eterm a1, + Eterm a2, Eterm a3); + +/* Method interface functions */ +static int db_first_tree(Process *p, DbTable *tbl, + Eterm *ret); +static int db_next_tree(Process *p, DbTable *tbl, + Eterm key, Eterm *ret); +static int db_last_tree(Process *p, DbTable *tbl, + Eterm *ret); +static int db_prev_tree(Process *p, DbTable *tbl, + Eterm key, + Eterm *ret); +static int db_put_tree(DbTable *tbl, Eterm obj, int key_clash_fail); +static int db_get_tree(Process *p, DbTable *tbl, + Eterm key, Eterm *ret); +static int db_member_tree(DbTable *tbl, Eterm key, Eterm *ret); +static int db_get_element_tree(Process *p, DbTable *tbl, + Eterm key,int ndex, + Eterm *ret); +static int db_erase_tree(DbTable *tbl, Eterm key, Eterm *ret); +static int db_erase_object_tree(DbTable *tbl, Eterm object,Eterm *ret); +static int db_slot_tree(Process *p, DbTable *tbl, + Eterm slot_term, Eterm *ret); +static int db_select_tree(Process *p, DbTable *tbl, + Eterm pattern, int reversed, Eterm *ret); +static int db_select_count_tree(Process *p, DbTable *tbl, + Eterm pattern, Eterm *ret); +static int db_select_chunk_tree(Process *p, DbTable *tbl, + Eterm pattern, Sint chunk_size, + int reversed, Eterm *ret); +static int db_select_continue_tree(Process *p, DbTable *tbl, + Eterm continuation, Eterm *ret); +static int db_select_count_continue_tree(Process *p, DbTable *tbl, + Eterm continuation, Eterm *ret); +static int db_select_delete_tree(Process *p, DbTable *tbl, + Eterm pattern, Eterm *ret); +static int db_select_delete_continue_tree(Process *p, DbTable *tbl, + Eterm continuation, Eterm *ret); +static void db_print_tree(int to, void *to_arg, + int show, DbTable *tbl); +static int db_free_table_tree(DbTable *tbl); + +static int db_free_table_continue_tree(DbTable *tbl); + +static void db_foreach_offheap_tree(DbTable *, + void (*)(ErlOffHeap *, void *), + void *); + +static int db_delete_all_objects_tree(Process* p, DbTable* tbl); + +#ifdef HARDDEBUG +static void db_check_table_tree(DbTable *tbl); +#endif +static int db_lookup_dbterm_tree(DbTable *, Eterm key, DbUpdateHandle*); +static void db_finalize_dbterm_tree(DbUpdateHandle*); + +/* +** Static variables +*/ + +Export ets_select_reverse_exp; + +/* +** External interface +*/ +DbTableMethod db_tree = +{ + db_create_tree, + db_first_tree, + db_next_tree, + db_last_tree, + db_prev_tree, + db_put_tree, + db_get_tree, + db_get_element_tree, + db_member_tree, + db_erase_tree, + db_erase_object_tree, + db_slot_tree, + db_select_chunk_tree, + db_select_tree, /* why not chunk size=0 ??? */ + db_select_delete_tree, + db_select_continue_tree, + db_select_delete_continue_tree, + db_select_count_tree, + db_select_count_continue_tree, + db_delete_all_objects_tree, + db_free_table_tree, + db_free_table_continue_tree, + db_print_tree, + db_foreach_offheap_tree, +#ifdef HARDDEBUG + db_check_table_tree, +#else + NULL, +#endif + db_lookup_dbterm_tree, + db_finalize_dbterm_tree + +}; + + + + + +void db_initialize_tree(void) +{ + memset(&ets_select_reverse_exp, 0, sizeof(Export)); + ets_select_reverse_exp.address = + &ets_select_reverse_exp.code[3]; + ets_select_reverse_exp.code[0] = am_ets; + ets_select_reverse_exp.code[1] = am_reverse; + ets_select_reverse_exp.code[2] = 3; + ets_select_reverse_exp.code[3] = + (Eterm) em_apply_bif; + ets_select_reverse_exp.code[4] = + (Eterm) &ets_select_reverse; + return; +}; + +/* +** Table interface routines ie what's called by the bif's +*/ + +int db_create_tree(Process *p, DbTable *tbl) +{ + DbTableTree *tb = &tbl->tree; + tb->root = NULL; + tb->static_stack.array = erts_db_alloc(ERTS_ALC_T_DB_STK, + (DbTable *) tb, + sizeof(TreeDbTerm *) * STACK_NEED); + tb->static_stack.pos = 0; + tb->static_stack.slot = 0; + erts_smp_atomic_init(&tb->is_stack_busy, 0); + tb->deletion = 0; + return DB_ERROR_NONE; +} + +static int db_first_tree(Process *p, DbTable *tbl, Eterm *ret) +{ + DbTableTree *tb = &tbl->tree; + DbTreeStack* stack; + TreeDbTerm *this; + Eterm e; + Eterm *hp; + Uint sz; + + if (( this = tb->root ) == NULL) { + *ret = am_EOT; + return DB_ERROR_NONE; + } + /* Walk down to the tree to the left */ + if ((stack = get_static_stack(tb)) != NULL) { + stack->pos = stack->slot = 0; + } + while (this->left != NULL) { + if (stack) PUSH_NODE(stack, this); + this = this->left; + } + if (stack) { + PUSH_NODE(stack, this); + stack->slot = 1; + release_stack(tb,stack); + } + e = GETKEY(tb, this->dbterm.tpl); + sz = size_object(e); + + hp = HAlloc(p, sz); + + *ret = copy_struct(e,sz,&hp,&MSO(p)); + + return DB_ERROR_NONE; +} + +static int db_next_tree(Process *p, DbTable *tbl, Eterm key, Eterm *ret) +{ + DbTableTree *tb = &tbl->tree; + DbTreeStack* stack; + TreeDbTerm *this; + Eterm e; + Eterm *hp; + Uint sz; + + if (is_atom(key) && key == am_EOT) + return DB_ERROR_BADKEY; + stack = get_any_stack(tb); + this = find_next(tb, stack, key); + release_stack(tb,stack); + if (this == NULL) { + *ret = am_EOT; + return DB_ERROR_NONE; + } + e = GETKEY(tb, this->dbterm.tpl); + sz = size_object(e); + + hp = HAlloc(p, sz); + + *ret = copy_struct(e,sz,&hp,&MSO(p)); + + return DB_ERROR_NONE; +} + +static int db_last_tree(Process *p, DbTable *tbl, Eterm *ret) +{ + DbTableTree *tb = &tbl->tree; + TreeDbTerm *this; + DbTreeStack* stack; + Eterm e; + Eterm *hp; + Uint sz; + + if (( this = tb->root ) == NULL) { + *ret = am_EOT; + return DB_ERROR_NONE; + } + /* Walk down to the tree to the left */ + if ((stack = get_static_stack(tb)) != NULL) { + stack->pos = stack->slot = 0; + } + while (this->right != NULL) { + if (stack) PUSH_NODE(stack, this); + this = this->right; + } + if (stack) { + PUSH_NODE(stack, this); + stack->slot = NITEMS(tb); + release_stack(tb,stack); + } + e = GETKEY(tb, this->dbterm.tpl); + sz = size_object(e); + + hp = HAlloc(p, sz); + + *ret = copy_struct(e,sz,&hp,&MSO(p)); + + return DB_ERROR_NONE; +} + +static int db_prev_tree(Process *p, DbTable *tbl, Eterm key, Eterm *ret) +{ + DbTableTree *tb = &tbl->tree; + TreeDbTerm *this; + DbTreeStack* stack; + Eterm e; + Eterm *hp; + Uint sz; + + if (is_atom(key) && key == am_EOT) + return DB_ERROR_BADKEY; + stack = get_any_stack(tb); + this = find_prev(tb, stack, key); + release_stack(tb,stack); + if (this == NULL) { + *ret = am_EOT; + return DB_ERROR_NONE; + } + e = GETKEY(tb, this->dbterm.tpl); + sz = size_object(e); + + hp = HAlloc(p, sz); + + *ret = copy_struct(e,sz,&hp,&MSO(p)); + + return DB_ERROR_NONE; +} + +static int db_put_tree(DbTable *tbl, Eterm obj, int key_clash_fail) +{ + DbTableTree *tb = &tbl->tree; + /* Non recursive insertion in AVL tree, building our own stack */ + TreeDbTerm **tstack[STACK_NEED]; + int tpos = 0; + int dstack[STACK_NEED+1]; + int dpos = 0; + int state = 0; + TreeDbTerm **this = &tb->root; + Sint c; + Eterm key; + int dir; + TreeDbTerm *p1, *p2, *p; + + key = GETKEY(tb, tuple_val(obj)); + + reset_static_stack(tb); + + dstack[dpos++] = DIR_END; + for (;;) + if (!*this) { /* Found our place */ + state = 1; + if (erts_smp_atomic_inctest(&tb->common.nitems) >= TREE_MAX_ELEMENTS) { + erts_smp_atomic_dec(&tb->common.nitems); + return DB_ERROR_SYSRES; + } + *this = get_term(tb, NULL, obj); + (*this)->balance = 0; + (*this)->left = (*this)->right = NULL; + break; + } else if ((c = cmp(key,GETKEY(tb,(*this)->dbterm.tpl))) < 0) { + /* go left */ + dstack[dpos++] = DIR_LEFT; + tstack[tpos++] = this; + this = &((*this)->left); + } else if (c > 0) { /* go right */ + dstack[dpos++] = DIR_RIGHT; + tstack[tpos++] = this; + this = &((*this)->right); + } else if (!key_clash_fail) { /* Equal key and this is a set, replace. */ + *this = get_term(tb, *this, obj); + break; + } else { + return DB_ERROR_BADKEY; /* key already exists */ + } + + while (state && ( dir = dstack[--dpos] ) != DIR_END) { + this = tstack[--tpos]; + p = *this; + if (dir == DIR_LEFT) { + switch (p->balance) { + case 1: + p->balance = 0; + state = 0; + break; + case 0: + p->balance = -1; + break; + case -1: /* The icky case */ + p1 = p->left; + if (p1->balance == -1) { /* Single LL rotation */ + p->left = p1->right; + p1->right = p; + p->balance = 0; + (*this) = p1; + } else { /* Double RR rotation */ + p2 = p1->right; + p1->right = p2->left; + p2->left = p1; + p->left = p2->right; + p2->right = p; + p->balance = (p2->balance == -1) ? +1 : 0; + p1->balance = (p2->balance == 1) ? -1 : 0; + (*this) = p2; + } + (*this)->balance = 0; + state = 0; + break; + } + } else { /* dir == DIR_RIGHT */ + switch (p->balance) { + case -1: + p->balance = 0; + state = 0; + break; + case 0: + p->balance = 1; + break; + case 1: + p1 = p->right; + if (p1->balance == 1) { /* Single RR rotation */ + p->right = p1->left; + p1->left = p; + p->balance = 0; + (*this) = p1; + } else { /* Double RL rotation */ + p2 = p1->left; + p1->left = p2->right; + p2->right = p1; + p->right = p2->left; + p2->left = p; + p->balance = (p2->balance == 1) ? -1 : 0; + p1->balance = (p2->balance == -1) ? 1 : 0; + (*this) = p2; + } + (*this)->balance = 0; + state = 0; + break; + } + } + } + return DB_ERROR_NONE; +} + +static int db_get_tree(Process *p, DbTable *tbl, Eterm key, Eterm *ret) +{ + DbTableTree *tb = &tbl->tree; + Eterm copy; + Eterm *hp; + TreeDbTerm *this; + + /* + * This is always a set, so we know exactly how large + * the data is when we have found it. + * The list created around it is purely for interface conformance. + */ + + this = find_node(tb,key); + if (this == NULL) { + *ret = NIL; + } else { + hp = HAlloc(p, this->dbterm.size + 2); + copy = copy_shallow(DBTERM_BUF(&this->dbterm), + this->dbterm.size, + &hp, + &MSO(p)); + *ret = CONS(hp, copy, NIL); + } + return DB_ERROR_NONE; +} + +static int db_member_tree(DbTable *tbl, Eterm key, Eterm *ret) +{ + DbTableTree *tb = &tbl->tree; + + *ret = (find_node(tb,key) == NULL) ? am_false : am_true; + return DB_ERROR_NONE; +} + +static int db_get_element_tree(Process *p, DbTable *tbl, + Eterm key, int ndex, Eterm *ret) +{ + DbTableTree *tb = &tbl->tree; + /* + * Look the node up: + */ + Eterm *hp; + TreeDbTerm *this; + + /* + * This is always a set, so we know exactly how large + * the data is when we have found it. + * No list is created around elements in set's so there are no list + * around the element here either. + */ + + this = find_node(tb,key); + if (this == NULL) { + return DB_ERROR_BADKEY; + } else { + Eterm element; + Uint sz; + if (ndex > arityval(this->dbterm.tpl[0])) { + return DB_ERROR_BADPARAM; + } + element = this->dbterm.tpl[ndex]; + sz = size_object(element); + hp = HAlloc(p, sz); + *ret = copy_struct(element, + sz, + &hp, + &MSO(p)); + } + return DB_ERROR_NONE; +} + +static int db_erase_tree(DbTable *tbl, Eterm key, Eterm *ret) +{ + DbTableTree *tb = &tbl->tree; + TreeDbTerm *res; + + *ret = am_true; + + if ((res = linkout_tree(tb, key)) != NULL) { + free_term(tb, res); + } + return DB_ERROR_NONE; +} + +static int db_erase_object_tree(DbTable *tbl, Eterm object, Eterm *ret) +{ + DbTableTree *tb = &tbl->tree; + TreeDbTerm *res; + + *ret = am_true; + + if ((res = linkout_object_tree(tb, object)) != NULL) { + free_term(tb, res); + } + return DB_ERROR_NONE; +} + + +static int db_slot_tree(Process *p, DbTable *tbl, + Eterm slot_term, Eterm *ret) +{ + DbTableTree *tb = &tbl->tree; + Sint slot; + TreeDbTerm *st; + Eterm *hp; + Eterm copy; + + /* + * The notion of a "slot" is not natural in a tree, but we try to + * simulate it by giving the n'th node in the tree instead. + * Traversing a tree in this way is not very convenient, but by + * using the saved stack we at least sometimes will get acceptable + * performance. + */ + + if (is_not_small(slot_term) || + ((slot = signed_val(slot_term)) < 0) || + (slot > NITEMS(tb))) + return DB_ERROR_BADPARAM; + + if (slot == NITEMS(tb)) { + *ret = am_EOT; + return DB_ERROR_NONE; + } + + /* + * We use the slot position and search from there, slot positions + * are counted from 1 and up. + */ + ++slot; + st = slot_search(p, tb, slot); + if (st == NULL) { + *ret = am_false; + return DB_ERROR_UNSPEC; + } + hp = HAlloc(p, st->dbterm.size + 2); + copy = copy_shallow(DBTERM_BUF(&st->dbterm), + st->dbterm.size, + &hp, + &MSO(p)); + *ret = CONS(hp, copy, NIL); + return DB_ERROR_NONE; +} + + + +static BIF_RETTYPE ets_select_reverse(Process *p, Eterm a1, Eterm a2, Eterm a3) +{ + Eterm list; + Eterm result; + Eterm* hp; + Eterm* hend; + + int max_iter = CONTEXT_REDS * 10; + + if (is_nil(a1)) { + hp = HAlloc(p, 3); + BIF_RET(TUPLE2(hp,a2,a3)); + } else if (is_not_list(a1)) { + error: + BIF_ERROR(p, BADARG); + } + + list = a1; + result = a2; + hp = hend = NULL; + while (is_list(list)) { + Eterm* pair = list_val(list); + if (--max_iter == 0) { + BUMP_ALL_REDS(p); + HRelease(p, hend, hp); + BIF_TRAP3(&ets_select_reverse_exp, p, list, result, a3); + } + if (hp == hend) { + hp = HAlloc(p, 64); + hend = hp + 64; + } + result = CONS(hp, CAR(pair), result); + hp += 2; + list = CDR(pair); + } + if (is_not_nil(list)) { + goto error; + } + HRelease(p, hend, hp); + BUMP_REDS(p,CONTEXT_REDS - max_iter / 10); + hp = HAlloc(p,3); + BIF_RET(TUPLE2(hp, result, a3)); +} + +static BIF_RETTYPE bif_trap1(Export *bif, + Process *p, + Eterm p1) +{ + BIF_TRAP1(bif, p, p1); +} + +static BIF_RETTYPE bif_trap3(Export *bif, + Process *p, + Eterm p1, + Eterm p2, + Eterm p3) +{ + BIF_TRAP3(bif, p, p1, p2, p3); +} + +/* +** This is called either when the select bif traps or when ets:select/1 +** is called. It does mostly the same as db_select_tree and may in either case +** trap to itself again (via the ets:select/1 bif). +** Note that this is common for db_select_tree and db_select_chunk_tree. +*/ +static int db_select_continue_tree(Process *p, + DbTable *tbl, + Eterm continuation, + Eterm *ret) +{ + DbTableTree *tb = &tbl->tree; + DbTreeStack* stack; + struct select_context sc; + unsigned sz; + Eterm *hp; + Eterm lastkey; + Eterm end_condition; + Binary *mp; + Eterm key; + Eterm *tptr; + Sint chunk_size; + Sint reverse; + + +#define RET_TO_BIF(Term, State) do { *ret = (Term); return State; } while(0); + + /* Decode continuation. We know it's a tuple but not the arity or + anything else */ + + tptr = tuple_val(continuation); + + if (arityval(*tptr) != 8) + RET_TO_BIF(NIL,DB_ERROR_BADPARAM); + + if (!is_small(tptr[4]) || !is_binary(tptr[5]) || + !(is_list(tptr[6]) || tptr[6] == NIL) || !is_small(tptr[7]) || + !is_small(tptr[8])) + RET_TO_BIF(NIL,DB_ERROR_BADPARAM); + + lastkey = tptr[2]; + end_condition = tptr[3]; + if (!(thing_subtag(*binary_val(tptr[5])) == REFC_BINARY_SUBTAG)) + RET_TO_BIF(NIL,DB_ERROR_BADPARAM); + mp = ((ProcBin *) binary_val(tptr[5]))->val; + if (!IsMatchProgBinary(mp)) + RET_TO_BIF(NIL,DB_ERROR_BADPARAM); + chunk_size = signed_val(tptr[4]); + + sc.p = p; + sc.accum = tptr[6]; + sc.mp = mp; + sc.end_condition = NIL; + sc.lastobj = NULL; + sc.max = 1000; + sc.keypos = tb->common.keypos; + sc.all_objects = mp->flags & BIN_FLAG_ALL_OBJECTS; + sc.chunk_size = chunk_size; + reverse = unsigned_val(tptr[7]); + sc.got = signed_val(tptr[8]); + + stack = get_any_stack(tb); + if (chunk_size) { + if (reverse) { + traverse_backwards(tb, stack, lastkey, &doit_select_chunk, &sc); + } else { + traverse_forward(tb, stack, lastkey, &doit_select_chunk, &sc); + } + } else { + if (reverse) { + traverse_forward(tb, stack, lastkey, &doit_select, &sc); + } else { + traverse_backwards(tb, stack, lastkey, &doit_select, &sc); + } + } + release_stack(tb,stack); + + BUMP_REDS(p, 1000 - sc.max); + + if (sc.max > 0 || (chunk_size && sc.got == chunk_size)) { + if (chunk_size) { + Eterm *hp; + unsigned sz; + + if (sc.got < chunk_size || sc.lastobj == NULL) { + /* end of table, sc.lastobj may be NULL as we may have been + at the very last object in the table when trapping. */ + if (!sc.got) { + RET_TO_BIF(am_EOT, DB_ERROR_NONE); + } else { + RET_TO_BIF(bif_trap3(&ets_select_reverse_exp, p, + sc.accum, NIL, am_EOT), + DB_ERROR_NONE); + } + } + + key = GETKEY(tb, sc.lastobj); + + sz = size_object(key); + hp = HAlloc(p, 9 + sz); + key = copy_struct(key, sz, &hp, &MSO(p)); + continuation = TUPLE8 + (hp, + tptr[1], + key, + tptr[3], + tptr[4], + tptr[5], + NIL, + tptr[7], + make_small(0)); + RET_TO_BIF(bif_trap3(&ets_select_reverse_exp, p, + sc.accum, NIL, continuation), + DB_ERROR_NONE); + } else { + RET_TO_BIF(sc.accum, DB_ERROR_NONE); + } + } + key = GETKEY(tb, sc.lastobj); + if (chunk_size) { + if (end_condition != NIL && + ((!reverse && cmp_partly_bound(end_condition,key) < 0) || + (reverse && cmp_partly_bound(end_condition,key) > 0))) { + /* done anyway */ + if (!sc.got) { + RET_TO_BIF(am_EOT, DB_ERROR_NONE); + } else { + RET_TO_BIF(bif_trap3(&ets_select_reverse_exp, p, + sc.accum, NIL, am_EOT), + DB_ERROR_NONE); + } + } + } else { + if (end_condition != NIL && + ((!reverse && cmp_partly_bound(end_condition,key) > 0) || + (reverse && cmp_partly_bound(end_condition,key) < 0))) { + /* done anyway */ + RET_TO_BIF(sc.accum,DB_ERROR_NONE); + } + } + /* Not done yet, let's trap. */ + sz = size_object(key); + hp = HAlloc(p, 9 + sz); + key = copy_struct(key, sz, &hp, &MSO(p)); + continuation = TUPLE8 + (hp, + tptr[1], + key, + tptr[3], + tptr[4], + tptr[5], + sc.accum, + tptr[7], + make_small(sc.got)); + RET_TO_BIF(bif_trap1(bif_export[BIF_ets_select_1], p, continuation), + DB_ERROR_NONE); + +#undef RET_TO_BIF +} + + +static int db_select_tree(Process *p, DbTable *tbl, + Eterm pattern, int reverse, Eterm *ret) +{ + DbTableTree *tb = &tbl->tree; + DbTreeStack* stack; + struct select_context sc; + struct mp_info mpi; + Eterm lastkey = NIL; + Eterm key; + Eterm continuation; + unsigned sz; + Eterm *hp; + TreeDbTerm *this; + int errcode; + Eterm mpb; + + +#define RET_TO_BIF(Term,RetVal) do { \ + if (mpi.mp != NULL) { \ + erts_bin_free(mpi.mp); \ + } \ + *ret = (Term); \ + return RetVal; \ + } while(0) + + mpi.mp = NULL; + + sc.accum = NIL; + sc.lastobj = NULL; + sc.p = p; + sc.max = 1000; + sc.end_condition = NIL; + sc.keypos = tb->common.keypos; + sc.got = 0; + sc.chunk_size = 0; + + if ((errcode = analyze_pattern(tb, pattern, &mpi)) != DB_ERROR_NONE) { + RET_TO_BIF(NIL,errcode); + } + + if (!mpi.something_can_match) { + RET_TO_BIF(NIL,DB_ERROR_NONE); + /* can't possibly match anything */ + } + + sc.mp = mpi.mp; + sc.all_objects = mpi.all_objects; + + if (!mpi.got_partial && mpi.some_limitation && + cmp(mpi.least,mpi.most) == 0) { + doit_select(tb,mpi.save_term,&sc,0 /* direction doesn't matter */); + RET_TO_BIF(sc.accum,DB_ERROR_NONE); + } + + stack = get_any_stack(tb); + if (reverse) { + if (mpi.some_limitation) { + if ((this = find_prev_from_pb_key(tb, stack, mpi.least)) != NULL) { + lastkey = GETKEY(tb, this->dbterm.tpl); + } + sc.end_condition = mpi.most; + } + + traverse_forward(tb, stack, lastkey, &doit_select, &sc); + } else { + if (mpi.some_limitation) { + if ((this = find_next_from_pb_key(tb, stack, mpi.most)) != NULL) { + lastkey = GETKEY(tb, this->dbterm.tpl); + } + sc.end_condition = mpi.least; + } + + traverse_backwards(tb, stack, lastkey, &doit_select, &sc); + } + release_stack(tb,stack); +#ifdef HARDDEBUG + erts_fprintf(stderr,"Least: %T\n", mpi.least); + erts_fprintf(stderr,"Most: %T\n", mpi.most); +#endif + BUMP_REDS(p, 1000 - sc.max); + if (sc.max > 0) { + RET_TO_BIF(sc.accum,DB_ERROR_NONE); + } + + key = GETKEY(tb, sc.lastobj); + sz = size_object(key); + hp = HAlloc(p, 9 + sz + PROC_BIN_SIZE); + key = copy_struct(key, sz, &hp, &MSO(p)); + if (mpi.all_objects) + (mpi.mp)->flags |= BIN_FLAG_ALL_OBJECTS; + mpb=db_make_mp_binary(p,mpi.mp,&hp); + + continuation = TUPLE8 + (hp, + tb->common.id, + key, + sc.end_condition, /* From the match program, needn't be copied */ + make_small(0), /* Chunk size of zero means not chunked to the + continuation BIF */ + mpb, + sc.accum, + make_small(reverse), + make_small(sc.got)); + + /* Don't free mpi.mp, so don't use macro */ + *ret = bif_trap1(bif_export[BIF_ets_select_1], p, continuation); + return DB_ERROR_NONE; + +#undef RET_TO_BIF + +} + + +/* +** This is called either when the select_count bif traps. +*/ +static int db_select_count_continue_tree(Process *p, + DbTable *tbl, + Eterm continuation, + Eterm *ret) +{ + DbTableTree *tb = &tbl->tree; + DbTreeStack* stack; + struct select_count_context sc; + unsigned sz; + Eterm *hp; + Eterm lastkey; + Eterm end_condition; + Binary *mp; + Eterm key; + Eterm *tptr; + Eterm egot; + + +#define RET_TO_BIF(Term, State) do { *ret = (Term); return State; } while(0); + + /* Decode continuation. We know it's a tuple and everything else as + this is only called by ourselves */ + + /* continuation: + {Table, Lastkey, EndCondition, MatchProgBin, HowManyGot}*/ + + tptr = tuple_val(continuation); + + if (arityval(*tptr) != 5) + erl_exit(1,"Internal error in ets:select_count/1"); + + lastkey = tptr[2]; + end_condition = tptr[3]; + if (!(thing_subtag(*binary_val(tptr[4])) == REFC_BINARY_SUBTAG)) + RET_TO_BIF(NIL,DB_ERROR_BADPARAM); + mp = ((ProcBin *) binary_val(tptr[4]))->val; + if (!IsMatchProgBinary(mp)) + RET_TO_BIF(NIL,DB_ERROR_BADPARAM); + + sc.p = p; + sc.mp = mp; + sc.end_condition = NIL; + sc.lastobj = NULL; + sc.max = 1000; + sc.keypos = tb->common.keypos; + if (is_big(tptr[5])) { + sc.got = big_to_uint32(tptr[5]); + } else { + sc.got = unsigned_val(tptr[5]); + } + + stack = get_any_stack(tb); + traverse_backwards(tb, stack, lastkey, &doit_select_count, &sc); + release_stack(tb,stack); + + BUMP_REDS(p, 1000 - sc.max); + + if (sc.max > 0) { + RET_TO_BIF(erts_make_integer(sc.got,p), DB_ERROR_NONE); + } + key = GETKEY(tb, sc.lastobj); + if (end_condition != NIL && + (cmp_partly_bound(end_condition,key) > 0)) { + /* done anyway */ + RET_TO_BIF(make_small(sc.got),DB_ERROR_NONE); + } + /* Not done yet, let's trap. */ + sz = size_object(key); + if (IS_USMALL(0, sc.got)) { + hp = HAlloc(p, sz + 6); + egot = make_small(sc.got); + } + else { + hp = HAlloc(p, BIG_UINT_HEAP_SIZE + sz + 6); + egot = uint_to_big(sc.got, hp); + hp += BIG_UINT_HEAP_SIZE; + } + key = copy_struct(key, sz, &hp, &MSO(p)); + continuation = TUPLE5 + (hp, + tptr[1], + key, + tptr[3], + tptr[4], + egot); + RET_TO_BIF(bif_trap1(&ets_select_count_continue_exp, p, continuation), + DB_ERROR_NONE); + +#undef RET_TO_BIF +} + + +static int db_select_count_tree(Process *p, DbTable *tbl, + Eterm pattern, Eterm *ret) +{ + DbTableTree *tb = &tbl->tree; + DbTreeStack* stack; + struct select_count_context sc; + struct mp_info mpi; + Eterm lastkey = NIL; + Eterm key; + Eterm continuation; + unsigned sz; + Eterm *hp; + TreeDbTerm *this; + int errcode; + Eterm egot; + Eterm mpb; + + +#define RET_TO_BIF(Term,RetVal) do { \ + if (mpi.mp != NULL) { \ + erts_bin_free(mpi.mp); \ + } \ + *ret = (Term); \ + return RetVal; \ + } while(0) + + mpi.mp = NULL; + + sc.lastobj = NULL; + sc.p = p; + sc.max = 1000; + sc.end_condition = NIL; + sc.keypos = tb->common.keypos; + sc.got = 0; + + if ((errcode = analyze_pattern(tb, pattern, &mpi)) != DB_ERROR_NONE) { + RET_TO_BIF(NIL,errcode); + } + + if (!mpi.something_can_match) { + RET_TO_BIF(make_small(0),DB_ERROR_NONE); + /* can't possibly match anything */ + } + + sc.mp = mpi.mp; + sc.all_objects = mpi.all_objects; + + if (!mpi.got_partial && mpi.some_limitation && + cmp(mpi.least,mpi.most) == 0) { + doit_select_count(tb,mpi.save_term,&sc,0 /* dummy */); + RET_TO_BIF(erts_make_integer(sc.got,p),DB_ERROR_NONE); + } + + stack = get_any_stack(tb); + if (mpi.some_limitation) { + if ((this = find_next_from_pb_key(tb, stack, mpi.most)) != NULL) { + lastkey = GETKEY(tb, this->dbterm.tpl); + } + sc.end_condition = mpi.least; + } + + traverse_backwards(tb, stack, lastkey, &doit_select_count, &sc); + release_stack(tb,stack); + BUMP_REDS(p, 1000 - sc.max); + if (sc.max > 0) { + RET_TO_BIF(erts_make_integer(sc.got,p),DB_ERROR_NONE); + } + + key = GETKEY(tb, sc.lastobj); + sz = size_object(key); + if (IS_USMALL(0, sc.got)) { + hp = HAlloc(p, sz + PROC_BIN_SIZE + 6); + egot = make_small(sc.got); + } + else { + hp = HAlloc(p, BIG_UINT_HEAP_SIZE + sz + PROC_BIN_SIZE + 6); + egot = uint_to_big(sc.got, hp); + hp += BIG_UINT_HEAP_SIZE; + } + key = copy_struct(key, sz, &hp, &MSO(p)); + if (mpi.all_objects) + (mpi.mp)->flags |= BIN_FLAG_ALL_OBJECTS; + mpb = db_make_mp_binary(p,mpi.mp,&hp); + + continuation = TUPLE5 + (hp, + tb->common.id, + key, + sc.end_condition, /* From the match program, needn't be copied */ + mpb, + egot); + + /* Don't free mpi.mp, so don't use macro */ + *ret = bif_trap1(&ets_select_count_continue_exp, p, continuation); + return DB_ERROR_NONE; + +#undef RET_TO_BIF + +} + +static int db_select_chunk_tree(Process *p, DbTable *tbl, + Eterm pattern, Sint chunk_size, + int reverse, + Eterm *ret) +{ + DbTableTree *tb = &tbl->tree; + DbTreeStack* stack; + struct select_context sc; + struct mp_info mpi; + Eterm lastkey = NIL; + Eterm key; + Eterm continuation; + unsigned sz; + Eterm *hp; + TreeDbTerm *this; + int errcode; + Eterm mpb; + + +#define RET_TO_BIF(Term,RetVal) do { \ + if (mpi.mp != NULL) { \ + erts_bin_free(mpi.mp); \ + } \ + *ret = (Term); \ + return RetVal; \ + } while(0) + + mpi.mp = NULL; + + sc.accum = NIL; + sc.lastobj = NULL; + sc.p = p; + sc.max = 1000; + sc.end_condition = NIL; + sc.keypos = tb->common.keypos; + sc.got = 0; + sc.chunk_size = chunk_size; + + if ((errcode = analyze_pattern(tb, pattern, &mpi)) != DB_ERROR_NONE) { + RET_TO_BIF(NIL,errcode); + } + + if (!mpi.something_can_match) { + RET_TO_BIF(am_EOT,DB_ERROR_NONE); + /* can't possibly match anything */ + } + + sc.mp = mpi.mp; + sc.all_objects = mpi.all_objects; + + if (!mpi.got_partial && mpi.some_limitation && + cmp(mpi.least,mpi.most) == 0) { + doit_select(tb,mpi.save_term,&sc, 0 /* direction doesn't matter */); + if (sc.accum != NIL) { + hp=HAlloc(p, 3); + RET_TO_BIF(TUPLE2(hp,sc.accum,am_EOT),DB_ERROR_NONE); + } else { + RET_TO_BIF(am_EOT,DB_ERROR_NONE); + } + } + + stack = get_any_stack(tb); + if (reverse) { + if (mpi.some_limitation) { + if ((this = find_next_from_pb_key(tb, stack, mpi.most)) != NULL) { + lastkey = GETKEY(tb, this->dbterm.tpl); + } + sc.end_condition = mpi.least; + } + + traverse_backwards(tb, stack, lastkey, &doit_select_chunk, &sc); + } else { + if (mpi.some_limitation) { + if ((this = find_prev_from_pb_key(tb, stack, mpi.least)) != NULL) { + lastkey = GETKEY(tb, this->dbterm.tpl); + } + sc.end_condition = mpi.most; + } + + traverse_forward(tb, stack, lastkey, &doit_select_chunk, &sc); + } + release_stack(tb,stack); + + BUMP_REDS(p, 1000 - sc.max); + if (sc.max > 0 || sc.got == chunk_size) { + Eterm *hp; + unsigned sz; + + if (sc.got < chunk_size || + sc.lastobj == NULL) { + /* We haven't got all and we haven't trapped + which should mean we are at the end of the + table, sc.lastobj may be NULL if the table was empty */ + + if (!sc.got) { + RET_TO_BIF(am_EOT, DB_ERROR_NONE); + } else { + RET_TO_BIF(bif_trap3(&ets_select_reverse_exp, p, + sc.accum, NIL, am_EOT), + DB_ERROR_NONE); + } + } + + key = GETKEY(tb, sc.lastobj); + sz = size_object(key); + hp = HAlloc(p, 9 + sz + PROC_BIN_SIZE); + key = copy_struct(key, sz, &hp, &MSO(p)); + if (mpi.all_objects) + (mpi.mp)->flags |= BIN_FLAG_ALL_OBJECTS; + mpb = db_make_mp_binary(p,mpi.mp,&hp); + + continuation = TUPLE8 + (hp, + tb->common.id, + key, + sc.end_condition, /* From the match program, + needn't be copied */ + make_small(chunk_size), + mpb, + NIL, + make_small(reverse), + make_small(0)); + /* Don't let RET_TO_BIF macro free mpi.mp*/ + *ret = bif_trap3(&ets_select_reverse_exp, p, + sc.accum, NIL, continuation); + return DB_ERROR_NONE; + } + + key = GETKEY(tb, sc.lastobj); + sz = size_object(key); + hp = HAlloc(p, 9 + sz + PROC_BIN_SIZE); + key = copy_struct(key, sz, &hp, &MSO(p)); + + if (mpi.all_objects) + (mpi.mp)->flags |= BIN_FLAG_ALL_OBJECTS; + mpb = db_make_mp_binary(p,mpi.mp,&hp); + continuation = TUPLE8 + (hp, + tb->common.id, + key, + sc.end_condition, /* From the match program, needn't be copied */ + make_small(chunk_size), + mpb, + sc.accum, + make_small(reverse), + make_small(sc.got)); + /* Don't let RET_TO_BIF macro free mpi.mp*/ + *ret = bif_trap1(bif_export[BIF_ets_select_1], p, continuation); + return DB_ERROR_NONE; + +#undef RET_TO_BIF + +} + +/* +** This is called when select_delete traps +*/ +static int db_select_delete_continue_tree(Process *p, + DbTable *tbl, + Eterm continuation, + Eterm *ret) +{ + DbTableTree *tb = &tbl->tree; + struct select_delete_context sc; + unsigned sz; + Eterm *hp; + Eterm lastkey; + Eterm end_condition; + Binary *mp; + Eterm key; + Eterm *tptr; + Eterm eaccsum; + + +#define RET_TO_BIF(Term, State) do { \ + if (sc.erase_lastterm) { \ + free_term(tb, sc.lastterm); \ + } \ + *ret = (Term); \ + return State; \ + } while(0); + + /* Decode continuation. We know it's correct, this can only be called + by trapping */ + + tptr = tuple_val(continuation); + + lastkey = tptr[2]; + end_condition = tptr[3]; + + sc.erase_lastterm = 0; /* Before first RET_TO_BIF */ + sc.lastterm = NULL; + + mp = ((ProcBin *) binary_val(tptr[4]))->val; + sc.p = p; + sc.tb = tb; + if (is_big(tptr[5])) { + sc.accum = big_to_uint32(tptr[5]); + } else { + sc.accum = unsigned_val(tptr[5]); + } + sc.mp = mp; + sc.end_condition = NIL; + sc.max = 1000; + sc.keypos = tb->common.keypos; + + ASSERT(!erts_smp_atomic_read(&tb->is_stack_busy)); + traverse_backwards(tb, &tb->static_stack, lastkey, &doit_select_delete, &sc); + + BUMP_REDS(p, 1000 - sc.max); + + if (sc.max > 0) { + RET_TO_BIF(erts_make_integer(sc.accum, p), DB_ERROR_NONE); + } + key = GETKEY(tb, (sc.lastterm)->dbterm.tpl); + if (end_condition != NIL && + cmp_partly_bound(end_condition,key) > 0) { /* done anyway */ + RET_TO_BIF(erts_make_integer(sc.accum,p),DB_ERROR_NONE); + } + /* Not done yet, let's trap. */ + sz = size_object(key); + if (IS_USMALL(0, sc.accum)) { + hp = HAlloc(p, sz + 6); + eaccsum = make_small(sc.accum); + } + else { + hp = HAlloc(p, BIG_UINT_HEAP_SIZE + sz + 6); + eaccsum = uint_to_big(sc.accum, hp); + hp += BIG_UINT_HEAP_SIZE; + } + key = copy_struct(key, sz, &hp, &MSO(p)); + continuation = TUPLE5 + (hp, + tptr[1], + key, + tptr[3], + tptr[4], + eaccsum); + RET_TO_BIF(bif_trap1(&ets_select_delete_continue_exp, p, continuation), + DB_ERROR_NONE); + +#undef RET_TO_BIF +} + +static int db_select_delete_tree(Process *p, DbTable *tbl, + Eterm pattern, Eterm *ret) +{ + DbTableTree *tb = &tbl->tree; + struct select_delete_context sc; + struct mp_info mpi; + Eterm lastkey = NIL; + Eterm key; + Eterm continuation; + unsigned sz; + Eterm *hp; + TreeDbTerm *this; + int errcode; + Eterm mpb; + Eterm eaccsum; + +#define RET_TO_BIF(Term,RetVal) do { \ + if (mpi.mp != NULL) { \ + erts_bin_free(mpi.mp); \ + } \ + if (sc.erase_lastterm) { \ + free_term(tb, sc.lastterm); \ + } \ + *ret = (Term); \ + return RetVal; \ + } while(0) + + mpi.mp = NULL; + + sc.accum = 0; + sc.erase_lastterm = 0; + sc.lastterm = NULL; + sc.p = p; + sc.max = 1000; + sc.end_condition = NIL; + sc.keypos = tb->common.keypos; + sc.tb = tb; + + if ((errcode = analyze_pattern(tb, pattern, &mpi)) != DB_ERROR_NONE) { + RET_TO_BIF(0,errcode); + } + + if (!mpi.something_can_match) { + RET_TO_BIF(make_small(0),DB_ERROR_NONE); + /* can't possibly match anything */ + } + + sc.mp = mpi.mp; + + if (!mpi.got_partial && mpi.some_limitation && + cmp(mpi.least,mpi.most) == 0) { + doit_select_delete(tb,mpi.save_term,&sc, 0 /* direction doesn't + matter */); + RET_TO_BIF(erts_make_integer(sc.accum,p),DB_ERROR_NONE); + } + + if (mpi.some_limitation) { + if ((this = find_next_from_pb_key(tb, &tb->static_stack, mpi.most)) != NULL) { + lastkey = GETKEY(tb, this->dbterm.tpl); + } + sc.end_condition = mpi.least; + } + + traverse_backwards(tb, &tb->static_stack, lastkey, &doit_select_delete, &sc); + BUMP_REDS(p, 1000 - sc.max); + + if (sc.max > 0) { + RET_TO_BIF(erts_make_integer(sc.accum,p), DB_ERROR_NONE); + } + + key = GETKEY(tb, (sc.lastterm)->dbterm.tpl); + sz = size_object(key); + if (IS_USMALL(0, sc.accum)) { + hp = HAlloc(p, sz + PROC_BIN_SIZE + 6); + eaccsum = make_small(sc.accum); + } + else { + hp = HAlloc(p, BIG_UINT_HEAP_SIZE + sz + PROC_BIN_SIZE + 6); + eaccsum = uint_to_big(sc.accum, hp); + hp += BIG_UINT_HEAP_SIZE; + } + key = copy_struct(key, sz, &hp, &MSO(p)); + mpb = db_make_mp_binary(p,mpi.mp,&hp); + + continuation = TUPLE5 + (hp, + tb->common.id, + key, + sc.end_condition, /* From the match program, needn't be copied */ + mpb, + eaccsum); + + /* Don't free mpi.mp, so don't use macro */ + if (sc.erase_lastterm) { + free_term(tb, sc.lastterm); + } + *ret = bif_trap1(&ets_select_delete_continue_exp, p, continuation); + return DB_ERROR_NONE; + +#undef RET_TO_BIF + +} + +/* +** Other interface routines (not directly coupled to one bif) +*/ + +/* Display hash table contents (for dump) */ +static void db_print_tree(int to, void *to_arg, + int show, + DbTable *tbl) +{ + DbTableTree *tb = &tbl->tree; +#ifdef TREE_DEBUG + if (show) + erts_print(to, to_arg, "\nTree data dump:\n" + "------------------------------------------------\n"); + do_dump_tree2(to, to_arg, show, tb->root, 0); + if (show) + erts_print(to, to_arg, "\n" + "------------------------------------------------\n"); +#else + erts_print(to, to_arg, "Ordered set (AVL tree), Elements: %d\n", NITEMS(tb)); + do_dump_tree(to, to_arg, tb->root); +#endif +} + +/* release all memory occupied by a single table */ +static int db_free_table_tree(DbTable *tbl) +{ + while (!db_free_table_continue_tree(tbl)) + ; + return 1; +} + +static int db_free_table_continue_tree(DbTable *tbl) +{ + DbTableTree *tb = &tbl->tree; + int result; + + if (!tb->deletion) { + tb->static_stack.pos = 0; + tb->deletion = 1; + PUSH_NODE(&tb->static_stack, tb->root); + } + result = do_free_tree_cont(tb, DELETE_RECORD_LIMIT); + if (result) { /* Completely done. */ + erts_db_free(ERTS_ALC_T_DB_STK, + (DbTable *) tb, + (void *) tb->static_stack.array, + sizeof(TreeDbTerm *) * STACK_NEED); + ASSERT(erts_smp_atomic_read(&tb->common.memory_size) + == sizeof(DbTable)); + } + return result; +} + +static int db_delete_all_objects_tree(Process* p, DbTable* tbl) +{ + db_free_table_tree(tbl); + db_create_tree(p, tbl); + erts_smp_atomic_set(&tbl->tree.common.nitems, 0); + return 0; +} + +static void do_db_tree_foreach_offheap(TreeDbTerm *, + void (*)(ErlOffHeap *, void *), + void *); + +static void db_foreach_offheap_tree(DbTable *tbl, + void (*func)(ErlOffHeap *, void *), + void * arg) +{ + do_db_tree_foreach_offheap(tbl->tree.root, func, arg); +} + + +/* +** Functions for internal use +*/ + + +static void +do_db_tree_foreach_offheap(TreeDbTerm *tdbt, + void (*func)(ErlOffHeap *, void *), + void * arg) +{ + if(!tdbt) + return; + do_db_tree_foreach_offheap(tdbt->left, func, arg); + (*func)(&(tdbt->dbterm.off_heap), arg); + do_db_tree_foreach_offheap(tdbt->right, func, arg); +} + +static TreeDbTerm *linkout_tree(DbTableTree *tb, + Eterm key) +{ + TreeDbTerm **tstack[STACK_NEED]; + int tpos = 0; + int dstack[STACK_NEED+1]; + int dpos = 0; + int state = 0; + TreeDbTerm **this = &tb->root; + Sint c; + int dir; + TreeDbTerm *q = NULL; + + /* + * Somewhat complicated, deletion in an AVL tree, + * The two helpers balance_left and balance_right are used to + * keep the balance. As in insert, we do the stacking ourselves. + */ + + reset_static_stack(tb); + dstack[dpos++] = DIR_END; + for (;;) { + if (!*this) { /* Failure */ + return NULL; + } else if ((c = cmp(key,GETKEY(tb,(*this)->dbterm.tpl))) < 0) { + dstack[dpos++] = DIR_LEFT; + tstack[tpos++] = this; + this = &((*this)->left); + } else if (c > 0) { /* go right */ + dstack[dpos++] = DIR_RIGHT; + tstack[tpos++] = this; + this = &((*this)->right); + } else { /* Equal key, found the one to delete*/ + q = (*this); + if (q->right == NULL) { + (*this) = q->left; + state = 1; + } else if (q->left == NULL) { + (*this) = q->right; + state = 1; + } else { + dstack[dpos++] = DIR_LEFT; + tstack[tpos++] = this; + state = delsub(this); + } + erts_smp_atomic_dec(&tb->common.nitems); + break; + } + } + while (state && ( dir = dstack[--dpos] ) != DIR_END) { + this = tstack[--tpos]; + if (dir == DIR_LEFT) { + state = balance_left(this); + } else { + state = balance_right(this); + } + } + return q; +} + +static TreeDbTerm *linkout_object_tree(DbTableTree *tb, + Eterm object) +{ + TreeDbTerm **tstack[STACK_NEED]; + int tpos = 0; + int dstack[STACK_NEED+1]; + int dpos = 0; + int state = 0; + TreeDbTerm **this = &tb->root; + Sint c; + int dir; + TreeDbTerm *q = NULL; + Eterm key; + + /* + * Somewhat complicated, deletion in an AVL tree, + * The two helpers balance_left and balance_right are used to + * keep the balance. As in insert, we do the stacking ourselves. + */ + + + key = GETKEY(tb, tuple_val(object)); + + reset_static_stack(tb); + dstack[dpos++] = DIR_END; + for (;;) { + if (!*this) { /* Failure */ + return NULL; + } else if ((c = cmp(key,GETKEY(tb,(*this)->dbterm.tpl))) < 0) { + dstack[dpos++] = DIR_LEFT; + tstack[tpos++] = this; + this = &((*this)->left); + } else if (c > 0) { /* go right */ + dstack[dpos++] = DIR_RIGHT; + tstack[tpos++] = this; + this = &((*this)->right); + } else { /* Equal key, found the only possible matching object*/ + if (!eq(object,make_tuple((*this)->dbterm.tpl))) { + return NULL; + } + q = (*this); + if (q->right == NULL) { + (*this) = q->left; + state = 1; + } else if (q->left == NULL) { + (*this) = q->right; + state = 1; + } else { + dstack[dpos++] = DIR_LEFT; + tstack[tpos++] = this; + state = delsub(this); + } + erts_smp_atomic_dec(&tb->common.nitems); + break; + } + } + while (state && ( dir = dstack[--dpos] ) != DIR_END) { + this = tstack[--tpos]; + if (dir == DIR_LEFT) { + state = balance_left(this); + } else { + state = balance_right(this); + } + } + return q; +} + +/* +** For the select functions, analyzes the pattern and determines which +** part of the tree should be searched. Also compiles the match program +*/ +static int analyze_pattern(DbTableTree *tb, Eterm pattern, + struct mp_info *mpi) +{ + Eterm lst, tpl, ttpl; + Eterm *matches,*guards, *bodies; + Eterm sbuff[30]; + Eterm *buff = sbuff; + Eterm *ptpl; + int i; + int num_heads = 0; + Eterm key; + Eterm partly_bound; + int res; + Eterm least = 0; + Eterm most = 0; + + mpi->some_limitation = 1; + mpi->got_partial = 0; + mpi->something_can_match = 0; + mpi->mp = NULL; + mpi->all_objects = 1; + mpi->save_term = NULL; + + for (lst = pattern; is_list(lst); lst = CDR(list_val(lst))) + ++num_heads; + + if (lst != NIL) {/* proper list... */ + return DB_ERROR_BADPARAM; + } + if (num_heads > 10) { + buff = erts_alloc(ERTS_ALC_T_DB_TMP, sizeof(Eterm) * num_heads * 3); + } + + matches = buff; + guards = buff + num_heads; + bodies = buff + (num_heads * 2); + + i = 0; + for(lst = pattern; is_list(lst); lst = CDR(list_val(lst))) { + Eterm body; + ttpl = CAR(list_val(lst)); + if (!is_tuple(ttpl)) { + if (buff != sbuff) { + erts_free(ERTS_ALC_T_DB_TMP, buff); + } + return DB_ERROR_BADPARAM; + } + ptpl = tuple_val(ttpl); + if (ptpl[0] != make_arityval(3U)) { + if (buff != sbuff) { + erts_free(ERTS_ALC_T_DB_TMP, buff); + } + return DB_ERROR_BADPARAM; + } + matches[i] = tpl = ptpl[1]; + guards[i] = ptpl[2]; + bodies[i] = body = ptpl[3]; + if (!is_list(body) || CDR(list_val(body)) != NIL || + CAR(list_val(body)) != am_DollarUnderscore) { + mpi->all_objects = 0; + } + ++i; + + partly_bound = NIL; + res = key_given(tb, tpl, &mpi->save_term, &partly_bound); + if ( res >= 0 ) { /* Can match something */ + key = 0; + mpi->something_can_match = 1; + if (res > 0) { + key = GETKEY(tb,tuple_val(tpl)); + } else if (partly_bound != NIL) { + mpi->got_partial = 1; + key = partly_bound; + } else { + mpi->some_limitation = 0; + } + if (key != 0) { + if (least == 0 || + partly_bound_can_match_lesser(key,least)) { + least = key; + } + if (most == 0 || + partly_bound_can_match_greater(key,most)) { + most = key; + } + } + } + } + mpi->least = least; + mpi->most = most; + + /* + * It would be nice not to compile the match_spec if nothing could match, + * but then the select calls would not fail like they should on bad + * match specs that happen to specify non existent keys etc. + */ + if ((mpi->mp = db_match_compile(matches, guards, bodies, + num_heads, DCOMP_TABLE, NULL)) + == NULL) { + if (buff != sbuff) { + erts_free(ERTS_ALC_T_DB_TMP, buff); + } + return DB_ERROR_BADPARAM; + } + if (buff != sbuff) { + erts_free(ERTS_ALC_T_DB_TMP, buff); + } + return DB_ERROR_NONE; +} + +static void do_dump_tree(int to, void *to_arg, TreeDbTerm *t) +{ + if (t != NULL) { + do_dump_tree(to, to_arg, t->left); + erts_print(to, to_arg, "%T\n", make_tuple(t->dbterm.tpl)); + do_dump_tree(to, to_arg, t->right); + } +} + +static void free_term(DbTableTree *tb, TreeDbTerm* p) +{ + db_free_term_data(&(p->dbterm)); + erts_db_free(ERTS_ALC_T_DB_TERM, + (DbTable *) tb, + (void *) p, + SIZ_DBTERM(p)*sizeof(Uint)); +} + +static int do_free_tree_cont(DbTableTree *tb, int num_left) +{ + TreeDbTerm *root; + TreeDbTerm *p; + + for (;;) { + root = POP_NODE(&tb->static_stack); + if (root == NULL) break; + for (;;) { + if ((p = root->left) != NULL) { + root->left = NULL; + PUSH_NODE(&tb->static_stack, root); + root = p; + } else if ((p = root->right) != NULL) { + root->right = NULL; + PUSH_NODE(&tb->static_stack, root); + root = p; + } else { + free_term(tb, root); + if (--num_left > 0) { + break; + } else { + return 0; /* Done enough for now */ + } + } + } + } + return 1; +} + +static TreeDbTerm* get_term(DbTableTree *tb, + TreeDbTerm* old, + Eterm obj) +{ + TreeDbTerm* p = db_get_term((DbTableCommon *) tb, + (old != NULL) ? &(old->dbterm) : NULL, + ((char *) &(old->dbterm)) - ((char *) old), + obj); + return p; +} + +/* + * Deletion helpers + */ +static int balance_left(TreeDbTerm **this) +{ + TreeDbTerm *p, *p1, *p2; + int b1, b2, h = 1; + + p = *this; + switch (p->balance) { + case -1: + p->balance = 0; + break; + case 0: + p->balance = 1; + h = 0; + break; + case 1: + p1 = p->right; + b1 = p1->balance; + if (b1 >= 0) { /* Single RR rotation */ + p->right = p1->left; + p1->left = p; + if (b1 == 0) { + p->balance = 1; + p1->balance = -1; + h = 0; + } else { + p->balance = p1->balance = 0; + } + (*this) = p1; + } else { /* Double RL rotation */ + p2 = p1->left; + b2 = p2->balance; + p1->left = p2->right; + p2->right = p1; + p->right = p2->left; + p2->left = p; + p->balance = (b2 == 1) ? -1 : 0; + p1->balance = (b2 == -1) ? 1 : 0; + p2->balance = 0; + (*this) = p2; + } + break; + } + return h; +} + +static int balance_right(TreeDbTerm **this) +{ + TreeDbTerm *p, *p1, *p2; + int b1, b2, h = 1; + + p = *this; + switch (p->balance) { + case 1: + p->balance = 0; + break; + case 0: + p->balance = -1; + h = 0; + break; + case -1: + p1 = p->left; + b1 = p1->balance; + if (b1 <= 0) { /* Single LL rotation */ + p->left = p1->right; + p1->right = p; + if (b1 == 0) { + p->balance = -1; + p1->balance = 1; + h = 0; + } else { + p->balance = p1->balance = 0; + } + (*this) = p1; + } else { /* Double LR rotation */ + p2 = p1->right; + b2 = p2->balance; + p1->right = p2->left; + p2->left = p1; + p->left = p2->right; + p2->right = p; + p->balance = (b2 == -1) ? 1 : 0; + p1->balance = (b2 == 1) ? -1 : 0; + p2->balance = 0; + (*this) = p2; + } + } + return h; +} + +static int delsub(TreeDbTerm **this) +{ + TreeDbTerm **tstack[STACK_NEED]; + int tpos = 0; + TreeDbTerm *q = (*this); + TreeDbTerm **r = &(q->left); + int h; + + /* + * Walk down the tree to the right and search + * for a void right child, pick that child out + * and return it to be put in the deleted + * object's place. + */ + + while ((*r)->right != NULL) { + tstack[tpos++] = r; + r = &((*r)->right); + } + *this = *r; + *r = (*r)->left; + (*this)->left = q->left; + (*this)->right = q->right; + (*this)->balance = q->balance; + tstack[0] = &((*this)->left); + h = 1; + while (tpos && h) { + r = tstack[--tpos]; + h = balance_right(r); + } + return h; +} + +/* + * Helper for db_slot + */ + +static TreeDbTerm *slot_search(Process *p, DbTableTree *tb, Sint slot) +{ + TreeDbTerm *this; + TreeDbTerm *tmp; + DbTreeStack* stack = get_any_stack(tb); + ASSERT(stack != NULL); + + if (slot == 1) { /* Don't search from where we are if we are + looking for the first slot */ + stack->slot = 0; + } + + if (stack->slot == 0) { /* clear stack if slot positions + are not recorded */ + stack->pos = 0; + } + if (EMPTY_NODE(stack)) { + this = tb->root; + if (this == NULL) + goto done; + while (this->left != NULL){ + PUSH_NODE(stack, this); + this = this->left; + } + PUSH_NODE(stack, this); + stack->slot = 1; + } + this = TOP_NODE(stack); + while (stack->slot != slot && this != NULL) { + if (slot > stack->slot) { + if (this->right != NULL) { + this = this->right; + while (this->left != NULL) { + PUSH_NODE(stack, this); + this = this->left; + } + PUSH_NODE(stack, this); + } else { + for (;;) { + tmp = POP_NODE(stack); + this = TOP_NODE(stack); + if (this == NULL || this->left == tmp) + break; + } + } + ++(stack->slot); + } else { + if (this->left != NULL) { + this = this->left; + while (this->right != NULL) { + PUSH_NODE(stack, this); + this = this->right; + } + PUSH_NODE(stack, this); + } else { + for (;;) { + tmp = POP_NODE(stack); + this = TOP_NODE(stack); + if (this == NULL || this->right == tmp) + break; + } + } + --(stack->slot); + } + } +done: + release_stack(tb,stack); + return this; +} + +/* + * Find next and previous in sort order + */ + +static TreeDbTerm *find_next(DbTableTree *tb, DbTreeStack* stack, Eterm key) +{ + TreeDbTerm *this; + TreeDbTerm *tmp; + Sint c; + + if(( this = TOP_NODE(stack)) != NULL) { + if (!CMP_EQ(GETKEY(tb, this->dbterm.tpl),key)) { + /* Start from the beginning */ + stack->pos = stack->slot = 0; + } + } + if (EMPTY_NODE(stack)) { /* Have to rebuild the stack */ + if (( this = tb->root ) == NULL) + return NULL; + for (;;) { + PUSH_NODE(stack, this); + if (( c = cmp(GETKEY(tb, this->dbterm.tpl),key) ) < 0) { + if (this->right == NULL) /* We are at the previos + and the element does + not exist */ + break; + else + this = this->right; + } else if (c > 0) { + if (this->left == NULL) /* Done */ + return this; + else + this = this->left; + } else + break; + } + } + /* The next element from this... */ + if (this->right != NULL) { + this = this->right; + PUSH_NODE(stack,this); + while (this->left != NULL) { + this = this->left; + PUSH_NODE(stack, this); + } + if (stack->slot > 0) + ++(stack->slot); + } else { + do { + tmp = POP_NODE(stack); + if (( this = TOP_NODE(stack)) == NULL) { + stack->slot = 0; + return NULL; + } + } while (this->right == tmp); + if (stack->slot > 0) + ++(stack->slot); + } + return this; +} + +static TreeDbTerm *find_prev(DbTableTree *tb, DbTreeStack* stack, Eterm key) +{ + TreeDbTerm *this; + TreeDbTerm *tmp; + Sint c; + + if(( this = TOP_NODE(stack)) != NULL) { + if (!CMP_EQ(GETKEY(tb, this->dbterm.tpl),key)) { + /* Start from the beginning */ + stack->pos = stack->slot = 0; + } + } + if (EMPTY_NODE(stack)) { /* Have to rebuild the stack */ + if (( this = tb->root ) == NULL) + return NULL; + for (;;) { + PUSH_NODE(stack, this); + if (( c = cmp(GETKEY(tb, this->dbterm.tpl),key) ) > 0) { + if (this->left == NULL) /* We are at the next + and the element does + not exist */ + break; + else + this = this->left; + } else if (c < 0) { + if (this->right == NULL) /* Done */ + return this; + else + this = this->right; + } else + break; + } + } + /* The previous element from this... */ + if (this->left != NULL) { + this = this->left; + PUSH_NODE(stack,this); + while (this->right != NULL) { + this = this->right; + PUSH_NODE(stack, this); + } + if (stack->slot > 0) + --(stack->slot); + } else { + do { + tmp = POP_NODE(stack); + if (( this = TOP_NODE(stack)) == NULL) { + stack->slot = 0; + return NULL; + } + } while (this->left == tmp); + if (stack->slot > 0) + --(stack->slot); + } + return this; +} + +static TreeDbTerm *find_next_from_pb_key(DbTableTree *tb, DbTreeStack* stack, + Eterm key) +{ + TreeDbTerm *this; + TreeDbTerm *tmp; + Sint c; + + /* spool the stack, we have to "re-search" */ + stack->pos = stack->slot = 0; + if (( this = tb->root ) == NULL) + return NULL; + for (;;) { + PUSH_NODE(stack, this); + if (( c = cmp_partly_bound(key,GETKEY(tb, this->dbterm.tpl)) ) >= 0) { + if (this->right == NULL) { + do { + tmp = POP_NODE(stack); + if (( this = TOP_NODE(stack)) == NULL) { + return NULL; + } + } while (this->right == tmp); + return this; + } else + this = this->right; + } else /*if (c < 0)*/ { + if (this->left == NULL) /* Done */ + return this; + else + this = this->left; + } + } +} + +static TreeDbTerm *find_prev_from_pb_key(DbTableTree *tb, DbTreeStack* stack, + Eterm key) +{ + TreeDbTerm *this; + TreeDbTerm *tmp; + Sint c; + + /* spool the stack, we have to "re-search" */ + stack->pos = stack->slot = 0; + if (( this = tb->root ) == NULL) + return NULL; + for (;;) { + PUSH_NODE(stack, this); + if (( c = cmp_partly_bound(key,GETKEY(tb, this->dbterm.tpl)) ) <= 0) { + if (this->left == NULL) { + do { + tmp = POP_NODE(stack); + if (( this = TOP_NODE(stack)) == NULL) { + return NULL; + } + } while (this->left == tmp); + return this; + } else + this = this->left; + } else /*if (c < 0)*/ { + if (this->right == NULL) /* Done */ + return this; + else + this = this->right; + } + } +} + + +/* + * Just lookup a node + */ +static TreeDbTerm *find_node(DbTableTree *tb, Eterm key) +{ + TreeDbTerm *this; + Sint res; + DbTreeStack* stack = get_static_stack(tb); + + if(!stack || EMPTY_NODE(stack) + || !CMP_EQ(GETKEY(tb, ( this = TOP_NODE(stack) )->dbterm.tpl), key)) { + + this = tb->root; + while (this != NULL && + ( res = cmp(key, GETKEY(tb, this->dbterm.tpl)) ) != 0) { + if (res < 0) + this = this->left; + else + this = this->right; + } + } + release_stack(tb,stack); + return this; +} + +/* + * Lookup a node and return the address of the node pointer in the tree + */ +static TreeDbTerm **find_node2(DbTableTree *tb, Eterm key) +{ + TreeDbTerm **this; + Sint res; + + this = &tb->root; + while ((*this) != NULL && + ( res = cmp(key, GETKEY(tb, (*this)->dbterm.tpl)) ) != 0) { + if (res < 0) + this = &((*this)->left); + else + this = &((*this)->right); + } + if (*this == NULL) + return NULL; + return this; +} + +static int db_lookup_dbterm_tree(DbTable *tbl, Eterm key, DbUpdateHandle* handle) +{ + DbTableTree *tb = &tbl->tree; + TreeDbTerm **pp = find_node2(tb, key); + + if (pp == NULL) return 0; + + handle->tb = tbl; + handle->dbterm = &(*pp)->dbterm; + handle->bp = (void**) pp; + handle->new_size = (*pp)->dbterm.size; + handle->mustResize = 0; + return 1; +} + +static void db_finalize_dbterm_tree(DbUpdateHandle* handle) +{ + if (handle->mustResize) { + Eterm* top; + Eterm copy; + DbTerm* newDbTerm; + DbTableTree *tb = &handle->tb->tree; + TreeDbTerm* oldp = (TreeDbTerm*) *handle->bp; + TreeDbTerm* newp = erts_db_alloc(ERTS_ALC_T_DB_TERM, + handle->tb, + sizeof(TreeDbTerm)+sizeof(Eterm)*(handle->new_size-1)); + memcpy(newp, oldp, sizeof(TreeDbTerm)-sizeof(DbTerm)); /* copy only tree header */ + *(handle->bp) = newp; + reset_static_stack(tb); + newDbTerm = &newp->dbterm; + + newDbTerm->size = handle->new_size; + newDbTerm->off_heap.mso = NULL; + newDbTerm->off_heap.externals = NULL; + #ifndef HYBRID /* FIND ME! */ + newDbTerm->off_heap.funs = NULL; + #endif + newDbTerm->off_heap.overhead = 0; + + /* make a flat copy */ + top = DBTERM_BUF(newDbTerm); + copy = copy_struct(make_tuple(handle->dbterm->tpl), + handle->new_size, + &top, &newDbTerm->off_heap); + DBTERM_SET_TPL(newDbTerm,tuple_val(copy)); + + db_free_term_data(handle->dbterm); + erts_db_free(ERTS_ALC_T_DB_TERM, + handle->tb, + (void *) (((char *) handle->dbterm) - (sizeof(TreeDbTerm) - sizeof(DbTerm))), + sizeof(TreeDbTerm) + sizeof(Eterm)*(handle->dbterm->size-1)); + } +#ifdef DEBUG + handle->dbterm = 0; +#endif + return; +} + +/* + * Traverse the tree with a callback function, used by db_match_xxx + */ +static void traverse_backwards(DbTableTree *tb, + DbTreeStack* stack, + Eterm lastkey, + int (*doit)(DbTableTree *, + TreeDbTerm *, + void *, + int), + void *context) +{ + TreeDbTerm *this, *next; + + if (lastkey == NIL) { + stack->pos = stack->slot = 0; + if (( this = tb->root ) == NULL) { + return; + } + while (this != NULL) { + PUSH_NODE(stack, this); + this = this->right; + } + this = TOP_NODE(stack); + next = find_prev(tb, stack, GETKEY(tb, this->dbterm.tpl)); + if (!((*doit)(tb, this, context, 0))) + return; + } else { + next = find_prev(tb, stack, lastkey); + } + + while ((this = next) != NULL) { + next = find_prev(tb, stack, GETKEY(tb, this->dbterm.tpl)); + if (!((*doit)(tb, this, context, 0))) + return; + } +} + +/* + * Traverse the tree with a callback function, used by db_match_xxx + */ +static void traverse_forward(DbTableTree *tb, + DbTreeStack* stack, + Eterm lastkey, + int (*doit)(DbTableTree *, + TreeDbTerm *, + void *, + int), + void *context) +{ + TreeDbTerm *this, *next; + + if (lastkey == NIL) { + stack->pos = stack->slot = 0; + if (( this = tb->root ) == NULL) { + return; + } + while (this != NULL) { + PUSH_NODE(stack, this); + this = this->left; + } + this = TOP_NODE(stack); + next = find_next(tb, stack, GETKEY(tb, this->dbterm.tpl)); + if (!((*doit)(tb, this, context, 1))) + return; + } else { + next = find_next(tb, stack, lastkey); + } + + while ((this = next) != NULL) { + next = find_next(tb, stack, GETKEY(tb, this->dbterm.tpl)); + if (!((*doit)(tb, this, context, 1))) + return; + } +} + +/* + * Returns 0 if not given 1 if given and -1 on no possible match + * if key is given; *ret is set to point to the object concerned. + */ +static int key_given(DbTableTree *tb, Eterm pattern, TreeDbTerm **ret, + Eterm *partly_bound) +{ + TreeDbTerm *this; + Eterm key; + + ASSERT(ret != NULL); + if (pattern == am_Underscore || db_is_variable(pattern) != -1) + return 0; + key = db_getkey(tb->common.keypos, pattern); + if (is_non_value(key)) + return -1; /* can't possibly match anything */ + if (!db_has_variable(key)) { /* Bound key */ + if (( this = find_node(tb, key) ) == NULL) { + return -1; + } + *ret = this; + return 1; + } else if (partly_bound != NULL && key != am_Underscore && + db_is_variable(key) < 0) + *partly_bound = key; + + return 0; +} + + + +static Sint do_cmp_partly_bound(Eterm a, Eterm b, int *done) +{ + Eterm* aa; + Eterm* bb; + Eterm a_hdr; + Eterm b_hdr; + int i; + Sint j; + + /* A variable matches anything */ + if (is_atom(a) && (a == am_Underscore || (db_is_variable(a) >= 0))) { + *done = 1; + return 0; + } + if (a == b) + return 0; + + switch (a & _TAG_PRIMARY_MASK) { + case TAG_PRIMARY_LIST: + if (!is_list(b)) { + return cmp(a,b); + } + aa = list_val(a); + bb = list_val(b); + while (1) { + if ((j = do_cmp_partly_bound(*aa++, *bb++, done)) != 0 || *done) + return j; + if (*aa==*bb) + return 0; + if (is_not_list(*aa) || is_not_list(*bb)) + return do_cmp_partly_bound(*aa, *bb, done); + aa = list_val(*aa); + bb = list_val(*bb); + } + case TAG_PRIMARY_BOXED: + if ((b & _TAG_PRIMARY_MASK) != TAG_PRIMARY_BOXED) { + return cmp(a,b); + } + a_hdr = ((*boxed_val(a)) & _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE; + b_hdr = ((*boxed_val(b)) & _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE; + if (a_hdr != b_hdr) { + return cmp(a, b); + } + if (a_hdr == (_TAG_HEADER_ARITYVAL >> _TAG_PRIMARY_SIZE)) { + aa = tuple_val(a); + bb = tuple_val(b); + /* compare the arities */ + i = arityval(*aa); /* get the arity*/ + if (i < arityval(*bb)) return(-1); + if (i > arityval(*bb)) return(1); + while (i--) { + if ((j = do_cmp_partly_bound(*++aa, *++bb, done)) != 0 + || *done) + return j; + } + return 0; + } + /* Drop through */ + default: + return cmp(a, b); + } +} + +static Sint cmp_partly_bound(Eterm partly_bound_key, Eterm bound_key) +{ + int done = 0; + Sint ret = do_cmp_partly_bound(partly_bound_key, bound_key, &done); +#ifdef HARDDEBUG + erts_fprintf(stderr,"\ncmp_partly_bound: %T", partly_bound_key); + if (ret < 0) + erts_fprintf(stderr," < "); + else if (ret > 0) + erts_fprintf(stderr," > "); + else + erts_fprintf(stderr," == "); + erts_fprintf(stderr,"%T\n",bound_key); +#endif + return ret; +} + +/* +** For partly_bound debugging.... +** +BIF_RETTYPE ets_testnisse_2(BIF_ALIST_2) +BIF_ADECL_2 +{ + Eterm r1 = make_small(partly_bound_can_match_lesser(BIF_ARG_1, + BIF_ARG_2)); + Eterm r2 = make_small(partly_bound_can_match_greater(BIF_ARG_1, + BIF_ARG_2)); + Eterm *hp = HAlloc(BIF_P,3); + Eterm ret; + + ret = TUPLE2(hp,r1,r2); + BIF_RET(ret); +} +** +*/ +static int partly_bound_can_match_lesser(Eterm partly_bound_1, + Eterm partly_bound_2) +{ + int done = 0; + int ret = do_partly_bound_can_match_lesser(partly_bound_1, + partly_bound_2, + &done); +#ifdef HARDDEBUG + erts_fprintf(stderr,"\npartly_bound_can_match_lesser: %T",partly_bound_1); + if (ret) + erts_fprintf(stderr," can match lesser than "); + else + erts_fprintf(stderr," can not match lesser than "); + erts_fprintf(stderr,"%T\n",partly_bound_2); +#endif + return ret; +} + +static int partly_bound_can_match_greater(Eterm partly_bound_1, + Eterm partly_bound_2) +{ + int done = 0; + int ret = do_partly_bound_can_match_greater(partly_bound_1, + partly_bound_2, + &done); +#ifdef HARDDEBUG + erts_fprintf(stderr,"\npartly_bound_can_match_greater: %T",partly_bound_1); + if (ret) + erts_fprintf(stderr," can match greater than "); + else + erts_fprintf(stderr," can not match greater than "); + erts_fprintf(stderr,"%T\n",partly_bound_2); +#endif + return ret; +} + +static int do_partly_bound_can_match_lesser(Eterm a, Eterm b, + int *done) +{ + Eterm* aa; + Eterm* bb; + Sint i; + int j; + + if (is_atom(a) && (a == am_Underscore || + (db_is_variable(a) >= 0))) { + *done = 1; + if (is_atom(b) && (b == am_Underscore || + (db_is_variable(b) >= 0))) { + return 0; + } else { + return 1; + } + } else if (is_atom(b) && (b == am_Underscore || + (db_is_variable(b) >= 0))) { + *done = 1; + return 0; + } + + if (a == b) + return 0; + + if (not_eq_tags(a,b)) { + *done = 1; + return (cmp(a, b) < 0) ? 1 : 0; + } + + /* we now know that tags are the same */ + switch (tag_val_def(a)) { + case TUPLE_DEF: + aa = tuple_val(a); + bb = tuple_val(b); + /* compare the arities */ + if (arityval(*aa) < arityval(*bb)) return 1; + if (arityval(*aa) > arityval(*bb)) return 0; + i = arityval(*aa); /* get the arity*/ + while (i--) { + if ((j = do_partly_bound_can_match_lesser(*++aa, *++bb, + done)) != 0 + || *done) + return j; + } + return 0; + case LIST_DEF: + aa = list_val(a); + bb = list_val(b); + while (1) { + if ((j = do_partly_bound_can_match_lesser(*aa++, *bb++, + done)) != 0 + || *done) + return j; + if (*aa==*bb) + return 0; + if (is_not_list(*aa) || is_not_list(*bb)) + return do_partly_bound_can_match_lesser(*aa, *bb, + done); + aa = list_val(*aa); + bb = list_val(*bb); + } + default: + if((i = cmp(a, b)) != 0) { + *done = 1; + } + return (i < 0) ? 1 : 0; + } +} + +static int do_partly_bound_can_match_greater(Eterm a, Eterm b, + int *done) +{ + Eterm* aa; + Eterm* bb; + Sint i; + int j; + + if (is_atom(a) && (a == am_Underscore || + (db_is_variable(a) >= 0))) { + *done = 1; + if (is_atom(b) && (b == am_Underscore || + (db_is_variable(b) >= 0))) { + return 0; + } else { + return 1; + } + } else if (is_atom(b) && (b == am_Underscore || + (db_is_variable(b) >= 0))) { + *done = 1; + return 0; + } + + if (a == b) + return 0; + + if (not_eq_tags(a,b)) { + *done = 1; + return (cmp(a, b) > 0) ? 1 : 0; + } + + /* we now know that tags are the same */ + switch (tag_val_def(a)) { + case TUPLE_DEF: + aa = tuple_val(a); + bb = tuple_val(b); + /* compare the arities */ + if (arityval(*aa) < arityval(*bb)) return 0; + if (arityval(*aa) > arityval(*bb)) return 1; + i = arityval(*aa); /* get the arity*/ + while (i--) { + if ((j = do_partly_bound_can_match_greater(*++aa, *++bb, + done)) != 0 + || *done) + return j; + } + return 0; + case LIST_DEF: + aa = list_val(a); + bb = list_val(b); + while (1) { + if ((j = do_partly_bound_can_match_greater(*aa++, *bb++, + done)) != 0 + || *done) + return j; + if (*aa==*bb) + return 0; + if (is_not_list(*aa) || is_not_list(*bb)) + return do_partly_bound_can_match_greater(*aa, *bb, + done); + aa = list_val(*aa); + bb = list_val(*bb); + } + default: + if((i = cmp(a, b)) != 0) { + *done = 1; + } + return (i > 0) ? 1 : 0; + } +} + +/* + * Callback functions for the different match functions + */ + +static int doit_select(DbTableTree *tb, TreeDbTerm *this, void *ptr, + int forward) +{ + struct select_context *sc = (struct select_context *) ptr; + Eterm ret; + Uint32 dummy; + + sc->lastobj = this->dbterm.tpl; + + if (sc->end_condition != NIL && + ((forward && + cmp_partly_bound(sc->end_condition, + GETKEY_WITH_POS(sc->keypos, + this->dbterm.tpl)) < 0) || + (!forward && + cmp_partly_bound(sc->end_condition, + GETKEY_WITH_POS(sc->keypos, + this->dbterm.tpl)) > 0))) { + return 0; + } + ret = db_prog_match(sc->p, sc->mp, + make_tuple(this->dbterm.tpl), + 0, &dummy); + if (is_value(ret)) { + Uint sz; + Eterm *hp; + if (sc->all_objects) { + hp = HAlloc(sc->p, this->dbterm.size + 2); + ret = copy_shallow(DBTERM_BUF(&this->dbterm), + this->dbterm.size, + &hp, + &MSO(sc->p)); + } else { + sz = size_object(ret); + hp = HAlloc(sc->p, sz + 2); + ret = copy_struct(ret, sz, + &hp, &MSO(sc->p)); + } + sc->accum = CONS(hp, ret, sc->accum); + } + if (MBUF(sc->p)) { + /* + * Force a trap and GC if a heap fragment was created. Many heap fragments + * make the GC slow. + */ + sc->max = 0; + } + if (--(sc->max) <= 0) { + return 0; + } + return 1; +} + +static int doit_select_count(DbTableTree *tb, TreeDbTerm *this, void *ptr, + int forward) +{ + struct select_count_context *sc = (struct select_count_context *) ptr; + Eterm ret; + Uint32 dummy; + + sc->lastobj = this->dbterm.tpl; + + /* Always backwards traversing */ + if (sc->end_condition != NIL && + (cmp_partly_bound(sc->end_condition, + GETKEY_WITH_POS(sc->keypos, + this->dbterm.tpl)) > 0)) { + return 0; + } + ret = db_prog_match(sc->p, sc->mp, + make_tuple(this->dbterm.tpl), + 0, &dummy); + if (ret == am_true) { + ++(sc->got); + } + if (--(sc->max) <= 0) { + return 0; + } + return 1; +} + +static int doit_select_chunk(DbTableTree *tb, TreeDbTerm *this, void *ptr, + int forward) +{ + struct select_context *sc = (struct select_context *) ptr; + Eterm ret; + Uint32 dummy; + + sc->lastobj = this->dbterm.tpl; + + if (sc->end_condition != NIL && + ((forward && + cmp_partly_bound(sc->end_condition, + GETKEY_WITH_POS(sc->keypos, + this->dbterm.tpl)) < 0) || + (!forward && + cmp_partly_bound(sc->end_condition, + GETKEY_WITH_POS(sc->keypos, + this->dbterm.tpl)) > 0))) { + return 0; + } + + ret = db_prog_match(sc->p, sc->mp, + make_tuple(this->dbterm.tpl), + 0, &dummy); + if (is_value(ret)) { + Uint sz; + Eterm *hp; + + ++(sc->got); + if (sc->all_objects) { + hp = HAlloc(sc->p, this->dbterm.size + 2); + ret = copy_shallow(DBTERM_BUF(&this->dbterm), + this->dbterm.size, + &hp, + &MSO(sc->p)); + } else { + sz = size_object(ret); + hp = HAlloc(sc->p, sz + 2); + ret = copy_struct(ret, sz, &hp, &MSO(sc->p)); + } + sc->accum = CONS(hp, ret, sc->accum); + } + if (MBUF(sc->p)) { + /* + * Force a trap and GC if a heap fragment was created. Many heap fragments + * make the GC slow. + */ + sc->max = 0; + } + if (--(sc->max) <= 0 || sc->got == sc->chunk_size) { + return 0; + } + return 1; +} + + +static int doit_select_delete(DbTableTree *tb, TreeDbTerm *this, void *ptr, + int forward) +{ + struct select_delete_context *sc = (struct select_delete_context *) ptr; + Eterm ret; + Uint32 dummy; + Eterm key; + + if (sc->erase_lastterm) + free_term(tb, sc->lastterm); + sc->erase_lastterm = 0; + sc->lastterm = this; + + if (sc->end_condition != NIL && + cmp_partly_bound(sc->end_condition, + GETKEY_WITH_POS(sc->keypos, + this->dbterm.tpl)) > 0) + return 0; + ret = db_prog_match(sc->p, sc->mp, + make_tuple(this->dbterm.tpl), + 0, &dummy); + if (ret == am_true) { + key = GETKEY(sc->tb, this->dbterm.tpl); + linkout_tree(sc->tb, key); + sc->erase_lastterm = 1; + ++sc->accum; + } + if (--(sc->max) <= 0) { + return 0; + } + return 1; +} + +#ifdef TREE_DEBUG +static void do_dump_tree2(int to, void *to_arg, int show, TreeDbTerm *t, + int offset) +{ + if (t == NULL) + return 0; + do_dump_tree2(to, to_arg, show, t->right, offset + 4); + if (show) { + erts_print(to, to_arg, "%*s%T (addr = %p, bal = %d)\n" + offset, "", make_tuple(t->dbterm.tpl), + t, t->balance); + } + do_dump_tree2(to, to_arg, show, t->left, offset + 4); + return sum; +} + +#endif + +#ifdef HARDDEBUG + +void db_check_table_tree(DbTable *tbl) +{ + DbTableTree *tb = &tbl->tree; + check_table_tree(tb->root); + check_saved_stack(tb); + check_slot_pos(tb); +} + +static TreeDbTerm *traverse_until(TreeDbTerm *t, int *current, int to) +{ + TreeDbTerm *tmp; + if (t == NULL) + return NULL; + tmp = traverse_until(t->left, current, to); + if (tmp != NULL) + return tmp; + ++(*current); + if (*current == to) + return t; + return traverse_until(t->right, current, to); +} + +static void check_slot_pos(DbTableTree *tb) +{ + int pos = 0; + TreeDbTerm *t; + if (tb->stack.slot == 0 || tb->stack.pos == 0) + return; + t = traverse_until(tb->root, &pos, tb->stack.slot); + if (t != tb->stack.array[tb->stack.pos - 1]) { + erts_fprintf(stderr, "Slot position does not correspont with stack, " + "element position %d is really 0x%08X, when stack says " + "it's 0x%08X\n", tb->stack.slot, t, + tb->stack.array[tb->stack.pos - 1]); + do_dump_tree2(ERTS_PRINT_STDERR, NULL, 1, tb->root, 0); + } +} + + +static void check_saved_stack(DbTableTree *tb) +{ + TreeDbTerm *t = tb->root; + DbTreeStack* stack = &tb->static_stack; + int n = 0; + if (stack->pos == 0) + return; + if (t != stack->array[0]) { + erts_fprintf(stderr,"tb->stack[0] is 0x%08X, should be 0x%08X\n", + stack->array[0], t); + do_dump_tree2(ERTS_PRINT_STDERR, NULL, 1, tb->root, 0); + return; + } + while (n < stack->pos) { + if (t == NULL) { + erts_fprintf(stderr, "NULL pointer in tree when stack not empty," + " stack depth is %d\n", n); + do_dump_tree2(ERTS_PRINT_STDERR, NULL, 1, tb->root, 0); + return; + } + n++; + if (n < stack->pos) { + if (stack->array[n] == t->left) + t = t->left; + else if (stack->array[n] == t->right) + t = t->right; + else { + erts_fprintf(stderr, "tb->stack[%d] == 0x%08X does not " + "represent child pointer in tree!" + "(left == 0x%08X, right == 0x%08X\n", + n, tb->stack[n], t->left, t->right); + do_dump_tree2(ERTS_PRINT_STDERR, NULL, 1, tb->root, 0); + return; + } + } + } +} + +static int check_table_tree(TreeDbTerm *t) +{ + int lh, rh; + if (t == NULL) + return 0; + lh = check_table_tree(t->left); + rh = check_table_tree(t->right); + if ((rh - lh) != t->balance) { + erts_fprintf(stderr, "Invalid tree balance for this node:\n"); + erts_fprintf(stderr,"balance = %d, left = 0x%08X, right = 0x%08X\n" + "data = %T", + t->balance, t->left, t->right, + make_tuple(t->dbterm.tpl)); + erts_fprintf(stderr,"\nDump:\n---------------------------------\n"); + do_dump_tree2(ERTS_PRINT_STDERR, NULL, 1, t, 0); + erts_fprintf(stderr,"\n---------------------------------\n"); + } + return ((rh > lh) ? rh : lh) + 1; +} + +#endif diff --git a/erts/emulator/beam/erl_db_tree.h b/erts/emulator/beam/erl_db_tree.h new file mode 100644 index 0000000000..7bc235e135 --- /dev/null +++ b/erts/emulator/beam/erl_db_tree.h @@ -0,0 +1,55 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1998-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifndef _DB_TREE_H +#define _DB_TREE_H + +#include "erl_db_util.h" + +typedef struct tree_db_term { + struct tree_db_term *left, *right; /* left and right child */ + int balance; /* tree balancing value */ + DbTerm dbterm; /* The actual term */ +} TreeDbTerm; + +typedef struct { + Uint pos; /* Current position on stack */ + Uint slot; /* "Slot number" of top element or 0 if not set */ + TreeDbTerm** array; /* The stack */ +} DbTreeStack; + +typedef struct db_table_tree { + DbTableCommon common; + + /* Tree-specific fields */ + TreeDbTerm *root; /* The tree root */ + Uint deletion; /* Being deleted */ + erts_smp_atomic_t is_stack_busy; + DbTreeStack static_stack; +} DbTableTree; + +/* +** Function prototypes, looks the same (except the suffix) for all +** table types. The process is always an [in out] parameter. +*/ +void db_initialize_tree(void); + +int db_create_tree(Process *p, DbTable *tbl); + +#endif /* _DB_TREE_H */ diff --git a/erts/emulator/beam/erl_db_util.c b/erts/emulator/beam/erl_db_util.c new file mode 100644 index 0000000000..8c373451fd --- /dev/null +++ b/erts/emulator/beam/erl_db_util.c @@ -0,0 +1,4651 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1998-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* + * Common utilities for the different types of db tables. + * Mostly matching etc. + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "erl_process.h" +#include "error.h" +#define ERTS_WANT_DB_INTERNAL__ +#include "erl_db.h" +#include "bif.h" +#include "big.h" +#include "erl_binary.h" + +#include "erl_db_util.h" + + +/* +** Flags for the guard bif's +*/ + +/* These are offsets from the DCOMP_* value */ +#define DBIF_GUARD 1 +#define DBIF_BODY 0 + +/* These are the DBIF flag bits corresponding to the DCOMP_* value. + * If a bit is set, the BIF is allowed in that context. */ +#define DBIF_TABLE_GUARD (1 << (DCOMP_TABLE + DBIF_GUARD)) +#define DBIF_TABLE_BODY (1 << (DCOMP_TABLE + DBIF_BODY)) +#define DBIF_TRACE_GUARD (1 << (DCOMP_TRACE + DBIF_GUARD)) +#define DBIF_TRACE_BODY (1 << (DCOMP_TRACE + DBIF_BODY)) +#define DBIF_ALL \ +DBIF_TABLE_GUARD | DBIF_TABLE_BODY | DBIF_TRACE_GUARD | DBIF_TRACE_BODY + + + +/* +** Some convenience macros for stacks (DMC == db_match_compile) +*/ + +#define DMC_DEFAULT_SIZE 25 + +#define DMC_STACK_TYPE(Type) DMC_##Type##_stack + +#define DMC_DECLARE_STACK_TYPE(Type) \ +typedef struct DMC_STACK_TYPE(Type) { \ + int pos; \ + int siz; \ + Type def[DMC_DEFAULT_SIZE]; \ + Type *data; \ +} DMC_STACK_TYPE(Type) + +#define DMC_INIT_STACK(Name) \ + (Name).pos = 0; (Name).siz = DMC_DEFAULT_SIZE; (Name).data = (Name).def + +#define DMC_STACK_DATA(Name) (Name).data + +#define DMC_STACK_NUM(Name) (Name).pos + +#define DMC_PUSH(On, What) \ +do { \ + if ((On).pos >= (On).siz) { \ + (On).siz *= 2; \ + (On).data \ + = (((On).def == (On).data) \ + ? memcpy(erts_alloc(ERTS_ALC_T_DB_MC_STK, \ + (On).siz*sizeof(*((On).data))), \ + (On).def, \ + DMC_DEFAULT_SIZE*sizeof(*((On).data))) \ + : erts_realloc(ERTS_ALC_T_DB_MC_STK, \ + (void *) (On).data, \ + (On).siz*sizeof(*((On).data)))); \ + } \ + (On).data[(On).pos++] = What; \ +} while (0) + +#define DMC_POP(From) (From).data[--(From).pos] + +#define DMC_TOP(From) (From).data[(From).pos - 1] + +#define DMC_EMPTY(Name) ((Name).pos == 0) + +#define DMC_PEEK(On, At) (On).data[At] + +#define DMC_POKE(On, At, Value) ((On).data[At] = (Value)) + +#define DMC_CLEAR(Name) (Name).pos = 0 + +#define DMC_FREE(Name) \ +do { \ + if ((Name).def != (Name).data) \ + erts_free(ERTS_ALC_T_DB_MC_STK, (Name).data); \ +} while (0) + +static ERTS_INLINE Process * +get_proc(Process *cp, Uint32 cp_locks, Eterm id, Uint32 id_locks) +{ + Process *proc = erts_pid2proc(cp, cp_locks, id, id_locks); + if (!proc && is_atom(id)) + proc = erts_whereis_process(cp, cp_locks, id, id_locks, 0); + return proc; +} + + +static Eterm +set_tracee_flags(Process *tracee_p, Eterm tracer, Uint d_flags, Uint e_flags) { + Eterm ret; + Uint flags; + + if (tracer == NIL) { + flags = tracee_p->trace_flags & ~TRACEE_FLAGS; + } else { + flags = ((tracee_p->trace_flags & ~d_flags) | e_flags); + if (! flags) tracer = NIL; + } + ret = tracee_p->tracer_proc != tracer || tracee_p->trace_flags != flags + ? am_true : am_false; + tracee_p->tracer_proc = tracer; + tracee_p->trace_flags = flags; + return ret; +} +/* +** Assuming all locks on tracee_p on entry +** +** Changes tracee_p->trace_flags and tracee_p->tracer_proc +** according to input disable/enable flags and tracer. +** +** Returns am_true|am_false on success, am_true if value changed, +** returns fail_term on failure. Fails if tracer pid or port is invalid. +*/ +static Eterm +set_match_trace(Process *tracee_p, Eterm fail_term, Eterm tracer, + Uint d_flags, Uint e_flags) { + Eterm ret = fail_term; + Process *tracer_p; + + ERTS_SMP_LC_ASSERT(ERTS_PROC_LOCKS_ALL == + erts_proc_lc_my_proc_locks(tracee_p)); + + if (is_internal_pid(tracer) + && (tracer_p = + erts_pid2proc(tracee_p, ERTS_PROC_LOCKS_ALL, + tracer, ERTS_PROC_LOCKS_ALL))) { + if (tracee_p != tracer_p) { + ret = set_tracee_flags(tracee_p, tracer, d_flags, e_flags); + tracer_p->trace_flags |= tracee_p->trace_flags ? F_TRACER : 0; + erts_smp_proc_unlock(tracer_p, ERTS_PROC_LOCKS_ALL); + } + } else if (is_internal_port(tracer)) { + Port *tracer_port = + erts_id2port(tracer, tracee_p, ERTS_PROC_LOCKS_ALL); + if (tracer_port) { + if (! INVALID_TRACER_PORT(tracer_port, tracer)) { + ret = set_tracee_flags(tracee_p, tracer, d_flags, e_flags); + } + erts_smp_port_unlock(tracer_port); + } + } else { + ASSERT(is_nil(tracer)); + ret = set_tracee_flags(tracee_p, tracer, d_flags, e_flags); + } + return ret; +} + + +/* Type checking... */ + +#define BOXED_IS_TUPLE(Boxed) is_arity_value(*boxed_val((Boxed))) + +/* +** +** Types and enum's (compiled matches) +** +*/ + +/* +** match VM instructions +*/ +typedef enum { + matchArray, /* Only when parameter is an array (DCOMP_TRACE) */ + matchArrayBind, /* ------------- " ------------ */ + matchTuple, + matchPushT, + matchPushL, + matchPop, + matchBind, + matchCmp, + matchEqBin, + matchEqFloat, + matchEqBig, + matchEqRef, + matchEq, + matchList, + matchSkip, + matchPushC, + matchConsA, /* Car is below Cdr */ + matchConsB, /* Cdr is below Car (unusual) */ + matchMkTuple, + matchCall0, + matchCall1, + matchCall2, + matchCall3, + matchPushV, + matchPushExpr, /* Push the whole expression we're matching ('$_') */ + matchPushArrayAsList, /* Only when parameter is an Array and + not an erlang term (DCOMP_TRACE) */ + matchPushArrayAsListU, /* As above but unknown size */ + matchTrue, + matchOr, + matchAnd, + matchOrElse, + matchAndAlso, + matchJump, + matchSelf, + matchWaste, + matchReturn, + matchProcessDump, + matchDisplay, + matchIsSeqTrace, + matchSetSeqToken, + matchGetSeqToken, + matchSetReturnTrace, + matchSetExceptionTrace, + matchCatch, + matchEnableTrace, + matchDisableTrace, + matchEnableTrace2, + matchDisableTrace2, + matchTryMeElse, + matchCaller, + matchHalt, + matchSilent, + matchSetSeqTokenFake, + matchTrace2, + matchTrace3 +} MatchOps; + +/* +** Guard bif's +*/ + +typedef struct dmc_guard_bif { + Eterm name; /* atom */ + void *biff; + /* BIF_RETTYPE (*biff)(); */ + int arity; + Uint32 flags; +} DMCGuardBif; + +/* +** Error information (for lint) +*/ + +/* +** Type declarations for stacks +*/ +DMC_DECLARE_STACK_TYPE(Eterm); + +DMC_DECLARE_STACK_TYPE(Uint); + +DMC_DECLARE_STACK_TYPE(unsigned); + +/* +** Data about the heap during compilation +*/ + +typedef struct DMCHeap { + int size; + unsigned def[DMC_DEFAULT_SIZE]; + unsigned *data; + int used; +} DMCHeap; + +/* +** Return values from sub compilation steps (guard compilation) +*/ + +typedef enum dmc_ret { + retOk, + retFail, + retRestart +} DMCRet; + +/* +** Diverse context information +*/ + +typedef struct dmc_context { + int stack_need; + int stack_used; + ErlHeapFragment *save; + ErlHeapFragment *copy; + Eterm *matchexpr; + Eterm *guardexpr; + Eterm *bodyexpr; + int num_match; + int current_match; + int eheap_need; + Uint cflags; + int is_guard; /* 1 if in guard, 0 if in body */ + int special; /* 1 if the head in the match was a single expression */ + DMCErrInfo *err_info; +} DMCContext; + +/* +** +** Global variables +** +*/ + +/* +** Internal +*/ + +/* +** The pseudo process used by the VM (pam). +*/ + +#define ERTS_DEFAULT_MS_HEAP_SIZE 128 + +typedef struct { + Process process; + Eterm *heap; + Eterm default_heap[ERTS_DEFAULT_MS_HEAP_SIZE]; +} ErtsMatchPseudoProcess; + + +#ifdef ERTS_SMP +static erts_smp_tsd_key_t match_pseudo_process_key; +#else +static ErtsMatchPseudoProcess *match_pseudo_process; +#endif + +static ERTS_INLINE void +cleanup_match_pseudo_process(ErtsMatchPseudoProcess *mpsp, int keep_heap) +{ + if (mpsp->process.mbuf + || mpsp->process.off_heap.mso +#ifndef HYBRID /* FIND ME! */ + || mpsp->process.off_heap.funs +#endif + || mpsp->process.off_heap.externals) { + erts_cleanup_empty_process(&mpsp->process); + } +#ifdef DEBUG + else { + erts_debug_verify_clean_empty_process(&mpsp->process); + } +#endif + if (!keep_heap) { + if (mpsp->heap != &mpsp->default_heap[0]) { + /* Have to be done *after* call to erts_cleanup_empty_process() */ + erts_free(ERTS_ALC_T_DB_MS_RUN_HEAP, (void *) mpsp->heap); + mpsp->heap = &mpsp->default_heap[0]; + } +#ifdef DEBUG + else { + int i; + for (i = 0; i < ERTS_DEFAULT_MS_HEAP_SIZE; i++) { +#ifdef ARCH_64 + mpsp->default_heap[i] = (Eterm) 0xdeadbeefdeadbeef; +#else + mpsp->default_heap[i] = (Eterm) 0xdeadbeef; +#endif + } + } +#endif + } +} + +static ErtsMatchPseudoProcess * +create_match_pseudo_process(void) +{ + ErtsMatchPseudoProcess *mpsp; + mpsp = (ErtsMatchPseudoProcess *)erts_alloc(ERTS_ALC_T_DB_MS_PSDO_PROC, + sizeof(ErtsMatchPseudoProcess)); + erts_init_empty_process(&mpsp->process); + mpsp->heap = &mpsp->default_heap[0]; + return mpsp; +} + +static ERTS_INLINE ErtsMatchPseudoProcess * +get_match_pseudo_process(Process *c_p, Uint heap_size) +{ + ErtsMatchPseudoProcess *mpsp; +#ifdef ERTS_SMP + mpsp = (ErtsMatchPseudoProcess *) c_p->scheduler_data->match_pseudo_process; + if (mpsp) + cleanup_match_pseudo_process(mpsp, 0); + else { + ASSERT(erts_smp_tsd_get(match_pseudo_process_key) == NULL); + mpsp = create_match_pseudo_process(); + c_p->scheduler_data->match_pseudo_process = (void *) mpsp; + erts_smp_tsd_set(match_pseudo_process_key, (void *) mpsp); + } + ASSERT(mpsp == erts_smp_tsd_get(match_pseudo_process_key)); + mpsp->process.scheduler_data = c_p->scheduler_data; +#else + mpsp = match_pseudo_process; + cleanup_match_pseudo_process(mpsp, 0); +#endif + if (heap_size > ERTS_DEFAULT_MS_HEAP_SIZE) + mpsp->heap = (Eterm *) erts_alloc(ERTS_ALC_T_DB_MS_RUN_HEAP, + heap_size*sizeof(Uint)); + else { + ASSERT(mpsp->heap == &mpsp->default_heap[0]); + } + return mpsp; +} + +#ifdef ERTS_SMP +static void +destroy_match_pseudo_process(void) +{ + ErtsMatchPseudoProcess *mpsp; + mpsp = (ErtsMatchPseudoProcess *)erts_smp_tsd_get(match_pseudo_process_key); + if (mpsp) { + cleanup_match_pseudo_process(mpsp, 0); + erts_free(ERTS_ALC_T_DB_MS_PSDO_PROC, (void *) mpsp); + erts_smp_tsd_set(match_pseudo_process_key, (void *) NULL); + } +} +#endif + +static +void +match_pseudo_process_init(void) +{ +#ifdef ERTS_SMP + erts_smp_tsd_key_create(&match_pseudo_process_key); + erts_smp_install_exit_handler(destroy_match_pseudo_process); +#else + match_pseudo_process = create_match_pseudo_process(); +#endif +} + +void +erts_match_set_release_result(Process* c_p) +{ + (void) get_match_pseudo_process(c_p, 0); /* Clean it up */ +} + +/* The trace control word. */ + +static erts_smp_atomic_t trace_control_word; + + +Eterm +erts_ets_copy_object(Eterm obj, Process* to) +{ + Uint size = size_object(obj); + Eterm* hp = HAlloc(to, size); + Eterm res; + + res = copy_struct(obj, size, &hp, &MSO(to)); +#ifdef DEBUG + if (eq(obj, res) == 0) { + erl_exit(1, "copy not equal to source\n"); + } +#endif + return res; +} + +/* This needs to be here, before the bif table... */ + +static Eterm db_set_trace_control_word_fake_1(Process *p, Eterm val); + +/* +** The table of callable bif's, i e guard bif's and +** some special animals that can provide us with trace +** information. This array is sorted on init. +*/ +static DMCGuardBif guard_tab[] = +{ + { + am_is_atom, + &is_atom_1, + 1, + DBIF_ALL + }, + { + am_is_float, + &is_float_1, + 1, + DBIF_ALL + }, + { + am_is_integer, + &is_integer_1, + 1, + DBIF_ALL + }, + { + am_is_list, + &is_list_1, + 1, + DBIF_ALL + }, + { + am_is_number, + &is_number_1, + 1, + DBIF_ALL + }, + { + am_is_pid, + &is_pid_1, + 1, + DBIF_ALL + }, + { + am_is_port, + &is_port_1, + 1, + DBIF_ALL + }, + { + am_is_reference, + &is_reference_1, + 1, + DBIF_ALL + }, + { + am_is_tuple, + &is_tuple_1, + 1, + DBIF_ALL + }, + { + am_is_binary, + &is_binary_1, + 1, + DBIF_ALL + }, + { + am_is_function, + &is_function_1, + 1, + DBIF_ALL + }, + { + am_is_record, + &is_record_3, + 3, + DBIF_ALL + }, + { + am_abs, + &abs_1, + 1, + DBIF_ALL + }, + { + am_element, + &element_2, + 2, + DBIF_ALL + }, + { + am_hd, + &hd_1, + 1, + DBIF_ALL + }, + { + am_length, + &length_1, + 1, + DBIF_ALL + }, + { + am_node, + &node_1, + 1, + DBIF_ALL + }, + { + am_node, + &node_0, + 0, + DBIF_ALL + }, + { + am_round, + &round_1, + 1, + DBIF_ALL + }, + { + am_size, + &size_1, + 1, + DBIF_ALL + }, + { + am_bit_size, + &bit_size_1, + 1, + DBIF_ALL + }, + { + am_tl, + &tl_1, + 1, + DBIF_ALL + }, + { + am_trunc, + &trunc_1, + 1, + DBIF_ALL + }, + { + am_float, + &float_1, + 1, + DBIF_ALL + }, + { + am_Plus, + &splus_1, + 1, + DBIF_ALL + }, + { + am_Minus, + &sminus_1, + 1, + DBIF_ALL + }, + { + am_Plus, + &splus_2, + 2, + DBIF_ALL + }, + { + am_Minus, + &sminus_2, + 2, + DBIF_ALL + }, + { + am_Times, + &stimes_2, + 2, + DBIF_ALL + }, + { + am_Div, + &div_2, + 2, + DBIF_ALL + }, + { + am_div, + &intdiv_2, + 2, + DBIF_ALL + }, + { + am_rem, + &rem_2, + 2, + DBIF_ALL + }, + { + am_band, + &band_2, + 2, + DBIF_ALL + }, + { + am_bor, + &bor_2, + 2, + DBIF_ALL + }, + { + am_bxor, + &bxor_2, + 2, + DBIF_ALL + }, + { + am_bnot, + &bnot_1, + 1, + DBIF_ALL + }, + { + am_bsl, + &bsl_2, + 2, + DBIF_ALL + }, + { + am_bsr, + &bsr_2, + 2, + DBIF_ALL + }, + { + am_Gt, + &sgt_2, + 2, + DBIF_ALL + }, + { + am_Ge, + &sge_2, + 2, + DBIF_ALL + }, + { + am_Lt, + &slt_2, + 2, + DBIF_ALL + }, + { + am_Le, + &sle_2, + 2, + DBIF_ALL + }, + { + am_Eq, + &seq_2, + 2, + DBIF_ALL + }, + { + am_Eqeq, + &seqeq_2, + 2, + DBIF_ALL + }, + { + am_Neq, + &sneq_2, + 2, + DBIF_ALL + }, + { + am_Neqeq, + &sneqeq_2, + 2, + DBIF_ALL + }, + { + am_not, + ¬_1, + 1, + DBIF_ALL + }, + { + am_xor, + &xor_2, + 2, + DBIF_ALL + }, + { + am_get_tcw, + &db_get_trace_control_word_0, + 0, + DBIF_TRACE_GUARD | DBIF_TRACE_BODY + }, + { + am_set_tcw, + &db_set_trace_control_word_1, + 1, + DBIF_TRACE_BODY + }, + { + am_set_tcw_fake, + &db_set_trace_control_word_fake_1, + 1, + DBIF_TRACE_BODY + } +}; + +/* +** Exported +*/ +Eterm db_am_eot; /* Atom '$end_of_table' */ + +/* +** Forward decl's +*/ + + +/* +** ... forwards for compiled matches +*/ +/* Utility code */ +static DMCGuardBif *dmc_lookup_bif(Eterm t, int arity); +#ifdef DMC_DEBUG +static Eterm dmc_lookup_bif_reversed(void *f); +#endif +static int cmp_uint(void *a, void *b); +static int cmp_guard_bif(void *a, void *b); +static int match_compact(ErlHeapFragment *expr, DMCErrInfo *err_info); +static Uint my_size_object(Eterm t); +static Eterm my_copy_struct(Eterm t, Eterm **hp, ErlOffHeap* off_heap); + +/* Guard compilation */ +static void do_emit_constant(DMCContext *context, DMC_STACK_TYPE(Uint) *text, + Eterm t); +static DMCRet dmc_list(DMCContext *context, + DMCHeap *heap, + DMC_STACK_TYPE(Uint) *text, + Eterm t, + int *constant); +static DMCRet dmc_tuple(DMCContext *context, + DMCHeap *heap, + DMC_STACK_TYPE(Uint) *text, + Eterm t, + int *constant); +static DMCRet dmc_variable(DMCContext *context, + DMCHeap *heap, + DMC_STACK_TYPE(Uint) *text, + Eterm t, + int *constant); +static DMCRet dmc_fun(DMCContext *context, + DMCHeap *heap, + DMC_STACK_TYPE(Uint) *text, + Eterm t, + int *constant); +static DMCRet dmc_expr(DMCContext *context, + DMCHeap *heap, + DMC_STACK_TYPE(Uint) *text, + Eterm t, + int *constant); +static DMCRet compile_guard_expr(DMCContext *context, + DMCHeap *heap, + DMC_STACK_TYPE(Uint) *text, + Eterm t); +/* match expression subroutine */ +static DMCRet dmc_one_term(DMCContext *context, + DMCHeap *heap, + DMC_STACK_TYPE(Eterm) *stack, + DMC_STACK_TYPE(Uint) *text, + Eterm c); + + +#ifdef DMC_DEBUG +static int test_disassemble_next = 0; +static void db_match_dis(Binary *prog); +#define TRACE erts_fprintf(stderr,"Trace: %s:%d\n",__FILE__,__LINE__) +#define FENCE_PATTERN_SIZE 1 +#define FENCE_PATTERN 0xDEADBEEFUL +#else +#define TRACE /* Nothing */ +#define FENCE_PATTERN_SIZE 0 +#endif +static void add_dmc_err(DMCErrInfo *err_info, + char *str, + int variable, + Eterm term, + DMCErrorSeverity severity); + +static Eterm dpm_array_to_list(Process *psp, Eterm *arr, int arity); + +static Eterm match_spec_test(Process *p, Eterm against, Eterm spec, int trace); + +static Eterm seq_trace_fake(Process *p, Eterm arg1); + + +/* +** Interface routines. +*/ + +/* +** Pseudo BIF:s to be callable from the PAM VM. +*/ + +BIF_RETTYPE db_get_trace_control_word_0(Process *p) +{ + Uint32 tcw = (Uint32) erts_smp_atomic_read(&trace_control_word); + BIF_RET(erts_make_integer((Uint) tcw, p)); +} + +BIF_RETTYPE db_set_trace_control_word_1(Process *p, Eterm new) +{ + Uint val; + Uint32 old_tcw; + if (!term_to_Uint(new, &val)) + BIF_ERROR(p, BADARG); + if (val != ((Uint32)val)) + BIF_ERROR(p, BADARG); + + old_tcw = (Uint32) erts_smp_atomic_xchg(&trace_control_word, (long) val); + BIF_RET(erts_make_integer((Uint) old_tcw, p)); +} + +static Eterm db_set_trace_control_word_fake_1(Process *p, Eterm new) +{ + Uint val; + if (!term_to_Uint(new, &val)) + BIF_ERROR(p, BADARG); + if (val != ((Uint32)val)) + BIF_ERROR(p, BADARG); + BIF_RET(db_get_trace_control_word_0(p)); +} + +/* +** The API used by the tracer (declared in global.h): +*/ + +/* +** Matchexpr is a list of tuples containing match-code, i e: +** +** Matchexpr = [{Pattern, Guards, Body}, ...] +** Pattern = [ PatternExpr , ...] +** PatternExpr = Constant | PatternTuple | PatternList | Variable +** Constant = Any erlang term +** PatternTuple = { PatternExpr ... } +** PatternList = [ PatternExpr ] +** Variable = '$' ++ +** Guards = [Guard ...] +** Guard = {GuardFunc, GuardExpr, ...} +** GuardExpr = BoundVariable | Guard | GuardList | GuardTuple | ConstExpr +** BoundVariable = Variable (existing in Pattern) +** GuardList = [ GuardExpr , ... ] +** GuardTuple = {{ GuardExpr, ... }} +** ConstExpr = {const, Constant} +** GuardFunc = is_list | .... | element | ... +** Body = [ BodyExpr, ... ] +** BodyExpr = GuardExpr | { BodyFunc, GuardExpr, ... } +** BodyFunc = return_trace | seq_trace | trace | ... +** - or something like that... +*/ + + +Eterm erts_match_set_get_source(Binary *mpsp) +{ + MatchProg *prog = Binary2MatchProg(mpsp); + return prog->saved_program; +} + +/* This one is for the tracing */ +Binary *erts_match_set_compile(Process *p, Eterm matchexpr) { + Binary *bin; + Uint sz; + Eterm *hp; + + bin = db_match_set_compile(p, matchexpr, DCOMP_TRACE); + if (bin != NULL) { + MatchProg *prog = Binary2MatchProg(bin); + sz = size_object(matchexpr); + prog->saved_program_buf = new_message_buffer(sz); + hp = prog->saved_program_buf->mem; + prog->saved_program = + copy_struct(matchexpr, sz, &hp, + &(prog->saved_program_buf->off_heap)); + } + return bin; +} + +Binary *db_match_set_compile(Process *p, Eterm matchexpr, + Uint flags) +{ + Eterm l; + Eterm t; + Eterm l2; + Eterm *tp; + Eterm *hp; + int n = 0; + int num_heads; + int i; + Binary *mps = NULL; + int compiled = 0; + Eterm *matches,*guards, *bodies; + Eterm *buff; + Eterm sbuff[15]; + + if (!is_list(matchexpr)) + return NULL; + num_heads = 0; + for (l = matchexpr; is_list(l); l = CDR(list_val(l))) + ++num_heads; + + if (l != NIL) /* proper list... */ + return NULL; + + if (num_heads > 5) { + buff = erts_alloc(ERTS_ALC_T_DB_TMP, + sizeof(Eterm) * num_heads * 3); + } else { + buff = sbuff; + } + + matches = buff; + guards = buff + num_heads; + bodies = buff + (num_heads * 2); + + i = 0; + for (l = matchexpr; is_list(l); l = CDR(list_val(l))) { + t = CAR(list_val(l)); + if (!is_tuple(t) || arityval((tp = tuple_val(t))[0]) != 3) { + goto error; + } + if (!(flags & DCOMP_TRACE) || (!is_list(tp[1]) && + !is_nil(tp[1]))) { + t = tp[1]; + } else { + /* This is when tracing, the parameter is a list, + that I convert to a tuple and that is matched + against an array (strange, but gives the semantics + of matching against a parameter list) */ + n = 0; + for (l2 = tp[1]; is_list(l2); l2 = CDR(list_val(l2))) { + ++n; + } + if (l2 != NIL) { + goto error; + } + hp = HAlloc(p, n + 1); + t = make_tuple(hp); + *hp++ = make_arityval((Uint) n); + l2 = tp[1]; + while (n--) { + *hp++ = CAR(list_val(l2)); + l2 = CDR(list_val(l2)); + } + } + matches[i] = t; + guards[i] = tp[2]; + bodies[i] = tp[3]; + ++i; + } + if ((mps = db_match_compile(matches, guards, bodies, + num_heads, + flags, + NULL)) == NULL) { + goto error; + } + compiled = 1; + if (buff != sbuff) { + erts_free(ERTS_ALC_T_DB_TMP, buff); + } + return mps; + +error: + if (compiled) { + erts_bin_free(mps); + } + if (buff != sbuff) { + erts_free(ERTS_ALC_T_DB_TMP, buff); + } + return NULL; +} + +/* This is used when tracing */ +Eterm erts_match_set_lint(Process *p, Eterm matchexpr) { + return db_match_set_lint(p, matchexpr, DCOMP_TRACE); +} + +Eterm db_match_set_lint(Process *p, Eterm matchexpr, Uint flags) +{ + Eterm l; + Eterm t; + Eterm l2; + Eterm *tp; + Eterm *hp; + DMCErrInfo *err_info = db_new_dmc_err_info(); + Eterm ret; + int n = 0; + int num_heads; + Binary *mp; + Eterm *matches,*guards, *bodies; + Eterm sbuff[15]; + Eterm *buff = sbuff; + int i; + + if (!is_list(matchexpr)) { + add_dmc_err(err_info, "Match programs are not in a list.", + -1, 0UL, dmcError); + goto done; + } + num_heads = 0; + for (l = matchexpr; is_list(l); l = CDR(list_val(l))) + ++num_heads; + + if (l != NIL) { /* proper list... */ + add_dmc_err(err_info, "Match programs are not in a proper " + "list.", + -1, 0UL, dmcError); + goto done; + } + + if (num_heads > 5) { + buff = erts_alloc(ERTS_ALC_T_DB_TMP, + sizeof(Eterm) * num_heads * 3); + } + + matches = buff; + guards = buff + num_heads; + bodies = buff + (num_heads * 2); + + i = 0; + for (l = matchexpr; is_list(l); l = CDR(list_val(l))) { + t = CAR(list_val(l)); + if (!is_tuple(t) || arityval((tp = tuple_val(t))[0]) != 3) { + add_dmc_err(err_info, + "Match program part is not a tuple of " + "arity 3.", + -1, 0UL, dmcError); + goto done; + } + if (!(flags & DCOMP_TRACE) || (!is_list(tp[1]) && + !is_nil(tp[1]))) { + t = tp[1]; + } else { + n = 0; + for (l2 = tp[1]; is_list(l2); l2 = CDR(list_val(l2))) { + ++n; + } + if (l2 != NIL) { + add_dmc_err(err_info, + "Match expression part %T is not a " + "proper list.", + -1, tp[1], dmcError); + + goto done; + } + hp = HAlloc(p, n + 1); + t = make_tuple(hp); + *hp++ = make_arityval((Uint) n); + l2 = tp[1]; + while (n--) { + *hp++ = CAR(list_val(l2)); + l2 = CDR(list_val(l2)); + } + } + matches[i] = t; + guards[i] = tp[2]; + bodies[i] = tp[3]; + ++i; + } + mp = db_match_compile(matches, guards, bodies, num_heads, + flags, err_info); + if (mp != NULL) { + erts_bin_free(mp); + } +done: + ret = db_format_dmc_err_info(p, err_info); + db_free_dmc_err_info(err_info); + if (buff != sbuff) { + erts_free(ERTS_ALC_T_DB_TMP, buff); + } + return ret; +} + +Eterm erts_match_set_run(Process *p, Binary *mpsp, + Eterm *args, int num_args, + Uint32 *return_flags) +{ + Eterm ret; + + ret = db_prog_match(p, mpsp, + (Eterm) args, + num_args, return_flags); +#if defined(HARDDEBUG) + if (is_non_value(ret)) { + erts_fprintf(stderr, "Failed\n"); + } else { + erts_fprintf(stderr, "Returning : %T\n", ret); + } +#endif + return ret; + /* Returns + * THE_NON_VALUE if no match + * am_false if {message,false} has been called, + * am_true if {message,_} has not been called or + * if {message,true} has been called, + * Msg if {message,Msg} has been called. + */ +} + +/* +** API Used by other erl_db modules. +*/ + +void db_initialize_util(void){ + qsort(guard_tab, + sizeof(guard_tab) / sizeof(DMCGuardBif), + sizeof(DMCGuardBif), + (int (*)(const void *, const void *)) &cmp_guard_bif); + match_pseudo_process_init(); + erts_smp_atomic_init(&trace_control_word, 0); +} + + + +Eterm db_getkey(int keypos, Eterm obj) +{ + if (is_tuple(obj)) { + Eterm *tptr = tuple_val(obj); + if (arityval(*tptr) >= keypos) + return *(tptr + keypos); + } + return THE_NON_VALUE; +} + +/* +** Matching compiled (executed by "Pam" :-) +*/ + +/* +** The actual compiling of the match expression and the guards +*/ +Binary *db_match_compile(Eterm *matchexpr, + Eterm *guards, + Eterm *body, + int num_progs, + Uint flags, + DMCErrInfo *err_info) +{ + DMCHeap heap; + DMC_STACK_TYPE(Eterm) stack; + DMC_STACK_TYPE(Uint) text; + DMCContext context; + MatchProg *ret = NULL; + Eterm t; + Uint i; + Uint num_iters; + int structure_checked; + DMCRet res; + int current_try_label; + Uint max_eheap_need; + Binary *bp = NULL; + unsigned clause_start; + + DMC_INIT_STACK(stack); + DMC_INIT_STACK(text); + + context.stack_need = context.stack_used = 0; + context.save = context.copy = NULL; + context.num_match = num_progs; + context.matchexpr = matchexpr; + context.guardexpr = guards; + context.bodyexpr = body; + context.eheap_need = 0; + context.err_info = err_info; + context.cflags = flags; + + heap.size = DMC_DEFAULT_SIZE; + heap.data = heap.def; + + /* + ** Compile the match expression + */ +restart: + heap.used = 0; + max_eheap_need = 0; + for (context.current_match = 0; + context.current_match < num_progs; + ++context.current_match) { /* This loop is long, + too long */ + memset(heap.data, 0, heap.size * sizeof(*heap.data)); + t = context.matchexpr[context.current_match]; + context.stack_used = 0; + context.eheap_need = 0; + structure_checked = 0; + if (context.current_match < num_progs - 1) { + DMC_PUSH(text,matchTryMeElse); + current_try_label = DMC_STACK_NUM(text); + DMC_PUSH(text,0); + } else { + current_try_label = -1; + } + clause_start = DMC_STACK_NUM(text); /* the "special" test needs it */ + DMC_PUSH(stack,NIL); + for (;;) { + switch (t & _TAG_PRIMARY_MASK) { + case TAG_PRIMARY_BOXED: + if (!BOXED_IS_TUPLE(t)) { + goto simple_term; + } + num_iters = arityval(*tuple_val(t)); + if (!structure_checked) { /* i.e. we did not + pop it */ + DMC_PUSH(text,matchTuple); + DMC_PUSH(text,num_iters); + } + structure_checked = 0; + for (i = 1; i <= num_iters; ++i) { + if ((res = dmc_one_term(&context, + &heap, + &stack, + &text, + tuple_val(t)[i])) + != retOk) { + if (res == retRestart) { + goto restart; /* restart the + surrounding + loop */ + } else goto error; + } + } + break; + case TAG_PRIMARY_LIST: + if (!structure_checked) { + DMC_PUSH(text, matchList); + } + structure_checked = 0; /* Whatever it is, we did + not pop it */ + if ((res = dmc_one_term(&context, &heap, &stack, + &text, CAR(list_val(t)))) + != retOk) { + if (res == retRestart) { + goto restart; + } else goto error; + } + t = CDR(list_val(t)); + continue; + default: /* Nil and non proper tail end's or + single terms as match + expressions */ + simple_term: + structure_checked = 0; + if ((res = dmc_one_term(&context, &heap, &stack, + &text, t)) + != retOk) { + if (res == retRestart) { + goto restart; + } else goto error; + } + break; + } + + /* The *program's* stack just *grows* while we are + traversing one composite data structure, we can + check the stack usage here */ + + if (context.stack_used > context.stack_need) + context.stack_need = context.stack_used; + + /* We are at the end of one composite data structure, + pop sub structures and emit a matchPop instruction + (or break) */ + if ((t = DMC_POP(stack)) == NIL) { + break; + } else { + DMC_PUSH(text, matchPop); + structure_checked = 1; /* + * Checked with matchPushT + * or matchPushL + */ + --(context.stack_used); + } + } + + /* + ** There is one single top variable in the match expression + ** iff the text is tho Uint's and the single instruction + ** is 'matchBind' or it is only a skip. + */ + context.special = + (DMC_STACK_NUM(text) == 2 + clause_start && + DMC_PEEK(text,clause_start) == matchBind) || + (DMC_STACK_NUM(text) == 1 + clause_start && + DMC_PEEK(text, clause_start) == matchSkip); + + if (flags & DCOMP_TRACE) { + if (context.special) { + if (DMC_PEEK(text, clause_start) == matchBind) { + DMC_POKE(text, clause_start, matchArrayBind); + } + } else { + ASSERT(DMC_STACK_NUM(text) >= 1); + if (DMC_PEEK(text, clause_start) != matchTuple) { + /* If it isn't "special" and the argument is + not a tuple, the expression is not valid + when matching an array*/ + if (context.err_info) { + add_dmc_err(context.err_info, + "Match head is invalid in " + "this context.", + -1, 0UL, + dmcError); + } + goto error; + } + DMC_POKE(text, clause_start, matchArray); + } + } + + + /* + ** ... and the guards + */ + context.is_guard = 1; + if (compile_guard_expr + (&context, + &heap, + &text, + context.guardexpr[context.current_match]) != retOk) + goto error; + context.is_guard = 0; + if ((context.cflags & DCOMP_TABLE) && + !is_list(context.bodyexpr[context.current_match])) { + if (context.err_info) { + add_dmc_err(context.err_info, + "Body clause does not return " + "anything.", -1, 0UL, + dmcError); + } + goto error; + } + if (compile_guard_expr + (&context, + &heap, + &text, + context.bodyexpr[context.current_match]) != retOk) + goto error; + + /* + * The compilation does not bail out when error information + * is requested, so we need to detect that here... + */ + if (context.err_info != NULL && + (context.err_info)->error_added) { + goto error; + } + + + /* If the matchprogram comes here, the match is + successful */ + DMC_PUSH(text,matchHalt); + /* Fill in try-me-else label if there is one. */ + if (current_try_label >= 0) { + DMC_POKE(text, current_try_label, DMC_STACK_NUM(text)); + } + /* So, how much eheap did this part of the match program need? */ + if (context.eheap_need > max_eheap_need) { + max_eheap_need = context.eheap_need; + } + } /* for (context.current_match = 0 ...) */ + + + /* + ** Done compiling + ** Allocate enough space for the program, + ** heap size is in 'heap_used', stack size is in 'stack_need' + ** and text size is simply DMC_STACK_NUM(text). + ** The "program memory" is allocated like this: + ** text ----> +-------------+ + ** | | + ** .......... + ** +-------------+ + ** + ** The heap-eheap-stack block of a MatchProg is nowadays allocated + ** when the match program is run (see db_prog_match()). + ** + ** heap ----> +-------------+ + ** .......... + ** eheap ---> + + + ** .......... + ** stack ---> + + + ** .......... + ** +-------------+ + ** The stack is expected to grow towards *higher* adresses. + ** A special case is when the match expression is a single binding + ** (i.e '$1'), then the field single_variable is set to 1. + */ + bp = erts_create_magic_binary(((sizeof(MatchProg) - sizeof(Uint)) + + (DMC_STACK_NUM(text) * sizeof(Uint))), + erts_db_match_prog_destructor); + ret = Binary2MatchProg(bp); + ret->saved_program_buf = NULL; + ret->saved_program = NIL; + ret->term_save = context.save; + ret->num_bindings = heap.used; + ret->single_variable = context.special; + sys_memcpy(ret->text, DMC_STACK_DATA(text), + DMC_STACK_NUM(text) * sizeof(Uint)); + ret->heap_size = ((heap.used * sizeof(Eterm)) + + (max_eheap_need * sizeof(Eterm)) + + (context.stack_need * sizeof(Eterm *)) + + (3 * (FENCE_PATTERN_SIZE * sizeof(Eterm *)))); + ret->eheap_offset = heap.used + FENCE_PATTERN_SIZE; + ret->stack_offset = ret->eheap_offset + max_eheap_need + FENCE_PATTERN_SIZE; +#ifdef DMC_DEBUG + ret->prog_end = ret->text + DMC_STACK_NUM(text); +#endif + + /* + * Fall through to cleanup code, but context.save should not be free'd + */ + context.save = NULL; +error: /* Here is were we land when compilation failed. */ + while (context.save != NULL) { + ErlHeapFragment *ll = context.save->next; + free_message_buffer(context.save); + context.save = ll; + } + DMC_FREE(stack); + DMC_FREE(text); + if (context.copy != NULL) + free_message_buffer(context.copy); + if (heap.data != heap.def) + erts_free(ERTS_ALC_T_DB_MS_CMPL_HEAP, (void *) heap.data); + return bp; +} + +/* +** Free a match program (in a binary) +*/ +void erts_db_match_prog_destructor(Binary *bprog) +{ + MatchProg *prog; + ErlHeapFragment *tmp, *ll; + if (bprog == NULL) + return; + prog = Binary2MatchProg(bprog); + tmp = prog->term_save; + while (tmp != NULL) { + ll = tmp->next; + free_message_buffer(tmp); + tmp = ll; + } + if (prog->saved_program_buf != NULL) + free_message_buffer(prog->saved_program_buf); +} + +void +erts_match_prog_foreach_offheap(Binary *bprog, + void (*func)(ErlOffHeap *, void *), + void *arg) +{ + MatchProg *prog; + ErlHeapFragment *tmp; + if (bprog == NULL) + return; + prog = Binary2MatchProg(bprog); + tmp = prog->term_save; + while (tmp) { + (*func)(&(tmp->off_heap), arg); + tmp = tmp->next; + } + if (prog->saved_program_buf) + (*func)(&(prog->saved_program_buf->off_heap), arg); +} + +/* +** This is not the most efficient way to do it, but it's a rare +** and not especially nice case when this is used. +*/ +static Eterm dpm_array_to_list(Process *psp, Eterm *arr, int arity) +{ + Eterm *hp = HAlloc(psp, arity * 2); + Eterm ret = NIL; + while (--arity >= 0) { + ret = CONS(hp, arr[arity], ret); + hp += 2; + } + return ret; +} +/* +** Execution of the match program, this is Pam. +** May return THE_NON_VALUE, which is a bailout. +** the para meter 'arity' is only used if 'term' is actually an array, +** i.e. 'DCOMP_TRACE' was specified +*/ +Eterm db_prog_match(Process *c_p, Binary *bprog, Eterm term, + int arity, + Uint32 *return_flags) +{ + MatchProg *prog = Binary2MatchProg(bprog); + Eterm *ep; + Eterm *tp; + Eterm t; + Eterm **sp; + Eterm *esp; + Eterm *hp; + Uint *pc = prog->text; + Eterm *ehp; + Eterm ret; + Uint n = 0; /* To avoid warning. */ + int i; + unsigned do_catch; + ErtsMatchPseudoProcess *mpsp; + Process *psp; + Process *tmpp; + Process *current_scheduled; + ErtsSchedulerData *esdp; + Eterm (*bif)(Process*, ...); + int fail_label; + int atomic_trace; +#ifdef DMC_DEBUG + unsigned long *heap_fence; + unsigned long *eheap_fence; + unsigned long *stack_fence; + Uint save_op; +#endif /* DMC_DEBUG */ + + mpsp = get_match_pseudo_process(c_p, prog->heap_size); + psp = &mpsp->process; + + /* We need to lure the scheduler into believing in the pseudo process, + because of floating point exceptions. Do *after* mpsp is set!!! */ + + esdp = ERTS_GET_SCHEDULER_DATA_FROM_PROC(c_p); + ASSERT(esdp != NULL); + current_scheduled = esdp->current_process; + esdp->current_process = psp; + /* SMP: psp->scheduler_data is set by get_match_pseudo_process */ + + atomic_trace = 0; +#define BEGIN_ATOMIC_TRACE(p) \ + do { \ + if (! atomic_trace) { \ + erts_smp_proc_unlock((p), ERTS_PROC_LOCK_MAIN); \ + erts_smp_block_system(0); \ + atomic_trace = !0; \ + } \ + } while (0) +#define END_ATOMIC_TRACE(p) \ + do { \ + if (atomic_trace) { \ + erts_smp_release_system(); \ + erts_smp_proc_lock((p), ERTS_PROC_LOCK_MAIN); \ + atomic_trace = 0; \ + } \ + } while (0) + +#ifdef DMC_DEBUG + save_op = 0; + heap_fence = (unsigned long *) mpsp->heap + prog->eheap_offset - 1; + eheap_fence = (unsigned long *) mpsp->heap + prog->stack_offset - 1; + stack_fence = (unsigned long *) mpsp->heap + prog->heap_size - 1; + *heap_fence = FENCE_PATTERN; + *eheap_fence = FENCE_PATTERN; + *stack_fence = FENCE_PATTERN; +#endif /* DMC_DEBUG */ + +#ifdef HARDDEBUG +#define FAIL() {erts_printf("Fail line %d\n",__LINE__); goto fail;} +#else +#define FAIL() goto fail +#endif +#define FAIL_TERM am_EXIT /* The term to set as return when bif fails and + do_catch != 0 */ + + *return_flags = 0U; + +restart: + ep = &term; + esp = mpsp->heap + prog->stack_offset; + sp = (Eterm **) esp; + hp = mpsp->heap; + ehp = mpsp->heap + prog->eheap_offset; + ret = am_true; + do_catch = 0; + fail_label = -1; + + for (;;) { +#ifdef DMC_DEBUG + if (*heap_fence != FENCE_PATTERN) { + erl_exit(1, "Heap fence overwritten in db_prog_match after op " + "0x%08x, overwritten with 0x%08x.", save_op, *heap_fence); + } + if (*eheap_fence != FENCE_PATTERN) { + erl_exit(1, "Eheap fence overwritten in db_prog_match after op " + "0x%08x, overwritten with 0x%08x.", save_op, + *eheap_fence); + } + if (*stack_fence != FENCE_PATTERN) { + erl_exit(1, "Stack fence overwritten in db_prog_match after op " + "0x%08x, overwritten with 0x%08x.", save_op, + *stack_fence); + } + save_op = *pc; +#endif + switch (*pc++) { + case matchTryMeElse: + fail_label = *pc++; + break; + case matchArray: /* only when DCOMP_TRACE, is always first + instruction. */ + n = *pc++; + if ((int) n != arity) + FAIL(); + ep = (Eterm *) *ep; + break; + case matchArrayBind: /* When the array size is unknown. */ + n = *pc++; + hp[n] = dpm_array_to_list(psp, (Eterm *) term, arity); + break; + case matchTuple: /* *ep is a tuple of arity n */ + if (!is_tuple(*ep)) + FAIL(); + ep = tuple_val(*ep); + n = *pc++; + if (arityval(*ep) != n) + FAIL(); + ++ep; + break; + case matchPushT: /* *ep is a tuple of arity n, + push ptr to first element */ + if (!is_tuple(*ep)) + FAIL(); + tp = tuple_val(*ep); + n = *pc++; + if (arityval(*tp) != n) + FAIL(); + *sp++ = tp + 1; + ++ep; + break; + case matchList: + if (!is_list(*ep)) + FAIL(); + ep = list_val(*ep); + break; + case matchPushL: + if (!is_list(*ep)) + FAIL(); + *sp++ = list_val(*ep); + ++ep; + break; + case matchPop: + ep = *(--sp); + break; + case matchBind: + n = *pc++; + hp[n] = *ep++; + break; + case matchCmp: + n = *pc++; + if (!eq(hp[n],*ep)) + FAIL(); + ++ep; + break; + case matchEqBin: + t = (Eterm) *pc++; + if (!eq(*ep,t)) + FAIL(); + ++ep; + break; + case matchEqFloat: + if (!is_float(*ep)) + FAIL(); + if (memcmp(float_val(*ep) + 1, pc, sizeof(double))) + FAIL(); + pc += 2; + ++ep; + break; + case matchEqRef: + if (!is_ref(*ep)) + FAIL(); + if (!eq(*ep, make_internal_ref(pc))) + FAIL(); + i = thing_arityval(*pc); + pc += i+1; + ++ep; + break; + case matchEqBig: + if (!is_big(*ep)) + FAIL(); + tp = big_val(*ep); + if (*tp != *pc) + FAIL(); + i = BIG_ARITY(pc); + while(i--) + if (*++tp != *++pc) + FAIL(); + ++pc; + ++ep; + break; + case matchEq: + t = (Eterm) *pc++; + if (t != *ep++) + FAIL(); + break; + case matchSkip: + ++ep; + break; + /* + * Here comes guard instructions + */ + case matchPushC: /* Push constant */ + *esp++ = *pc++; + break; + case matchConsA: + ehp[1] = *--esp; + ehp[0] = esp[-1]; + esp[-1] = make_list(ehp); + ehp += 2; + break; + case matchConsB: + ehp[0] = *--esp; + ehp[1] = esp[-1]; + esp[-1] = make_list(ehp); + ehp += 2; + break; + case matchMkTuple: + n = *pc++; + t = make_tuple(ehp); + *ehp++ = make_arityval(n); + while (n--) { + *ehp++ = *--esp; + } + *esp++ = t; + break; + case matchCall0: + bif = (Eterm (*)(Process*, ...)) *pc++; + t = (*bif)(psp); + if (is_non_value(t)) { + if (do_catch) + t = FAIL_TERM; + else + FAIL(); + } + *esp++ = t; + break; + case matchCall1: + bif = (Eterm (*)(Process*, ...)) *pc++; + t = (*bif)(psp, esp[-1]); + if (is_non_value(t)) { + if (do_catch) + t = FAIL_TERM; + else + FAIL(); + } + esp[-1] = t; + break; + case matchCall2: + bif = (Eterm (*)(Process*, ...)) *pc++; + t = (*bif)(psp, esp[-1], esp[-2]); + if (is_non_value(t)) { + if (do_catch) + t = FAIL_TERM; + else + FAIL(); + } + --esp; + esp[-1] = t; + break; + case matchCall3: + bif = (Eterm (*)(Process*, ...)) *pc++; + t = (*bif)(psp, esp[-1], esp[-2], esp[-3]); + if (is_non_value(t)) { + if (do_catch) + t = FAIL_TERM; + else + FAIL(); + } + esp -= 2; + esp[-1] = t; + break; + case matchPushV: + *esp++ = hp[*pc++]; + break; + case matchPushExpr: + *esp++ = term; + break; + case matchPushArrayAsList: + n = arity; /* Only happens when 'term' is an array */ + tp = (Eterm *) term; + *esp++ = make_list(ehp); + while (n--) { + *ehp++ = *tp++; + *ehp = make_list(ehp + 1); + ehp++; /* As pointed out by Mikael Pettersson the expression + (*ehp++ = make_list(ehp + 1)) that I previously + had written here has undefined behaviour. */ + } + ehp[-1] = NIL; + break; + case matchPushArrayAsListU: + /* This instruction is NOT efficient. */ + *esp++ = dpm_array_to_list(psp, (Eterm *) term, arity); + break; + case matchTrue: + if (*--esp != am_true) + FAIL(); + break; + case matchOr: + n = *pc++; + t = am_false; + while (n--) { + if (*--esp == am_true) { + t = am_true; + } else if (*esp != am_false) { + esp -= n; + if (do_catch) { + t = FAIL_TERM; + break; + } else { + FAIL(); + } + } + } + *esp++ = t; + break; + case matchAnd: + n = *pc++; + t = am_true; + while (n--) { + if (*--esp == am_false) { + t = am_false; + } else if (*esp != am_true) { + esp -= n; + if (do_catch) { + t = FAIL_TERM; + break; + } else { + FAIL(); + } + } + } + *esp++ = t; + break; + case matchOrElse: + n = *pc++; + if (*--esp == am_true) { + ++esp; + pc += n; + } else if (*esp != am_false) { + if (do_catch) { + *esp++ = FAIL_TERM; + pc += n; + } else { + FAIL(); + } + } + break; + case matchAndAlso: + n = *pc++; + if (*--esp == am_false) { + esp++; + pc += n; + } else if (*esp != am_true) { + if (do_catch) { + *esp++ = FAIL_TERM; + pc += n; + } else { + FAIL(); + } + } + break; + case matchJump: + n = *pc++; + pc += n; + break; + case matchSelf: + *esp++ = c_p->id; + break; + case matchWaste: + --esp; + break; + case matchReturn: + ret = *--esp; + break; + case matchProcessDump: { + erts_dsprintf_buf_t *dsbufp = erts_create_tmp_dsbuf(0); + print_process_info(ERTS_PRINT_DSBUF, (void *) dsbufp, c_p); + *esp++ = new_binary(psp, (byte *)dsbufp->str, (int)dsbufp->str_len); + erts_destroy_tmp_dsbuf(dsbufp); + break; + } + case matchDisplay: /* Debugging, not for production! */ + erts_printf("%T\n", esp[-1]); + esp[-1] = am_true; + break; + case matchSetReturnTrace: + *return_flags |= MATCH_SET_RETURN_TRACE; + *esp++ = am_true; + break; + case matchSetExceptionTrace: + *return_flags |= MATCH_SET_EXCEPTION_TRACE; + *esp++ = am_true; + break; + case matchIsSeqTrace: + if (SEQ_TRACE_TOKEN(c_p) != NIL) + *esp++ = am_true; + else + *esp++ = am_false; + break; + case matchSetSeqToken: + t = erts_seq_trace(c_p, esp[-1], esp[-2], 0); + if (is_non_value(t)) { + esp[-2] = FAIL_TERM; + } else { + esp[-2] = t; + } + --esp; + break; + case matchSetSeqTokenFake: + t = seq_trace_fake(c_p, esp[-1]); + if (is_non_value(t)) { + esp[-2] = FAIL_TERM; + } else { + esp[-2] = t; + } + --esp; + break; + case matchGetSeqToken: + if (SEQ_TRACE_TOKEN(c_p) == NIL) + *esp++ = NIL; + else { + *esp++ = make_tuple(ehp); + ehp[0] = make_arityval(5); + ehp[1] = SEQ_TRACE_TOKEN_FLAGS(c_p); + ehp[2] = SEQ_TRACE_TOKEN_LABEL(c_p); + ehp[3] = SEQ_TRACE_TOKEN_SERIAL(c_p); + ehp[4] = SEQ_TRACE_TOKEN_SENDER(c_p); + ehp[5] = SEQ_TRACE_TOKEN_LASTCNT(c_p); + ASSERT(SEQ_TRACE_TOKEN_ARITY(c_p) == 5); + ASSERT(is_immed(ehp[1])); + ASSERT(is_immed(ehp[2])); + ASSERT(is_immed(ehp[3])); + ASSERT(is_immed(ehp[5])); + if(!is_immed(ehp[4])) { + Eterm *sender = &ehp[4]; + ehp += 6; + *sender = copy_struct(*sender, + size_object(*sender), + &ehp, + &MSO(psp)); + } + else + ehp += 6; + + } + break; + case matchEnableTrace: + if ( (n = erts_trace_flag2bit(esp[-1]))) { + BEGIN_ATOMIC_TRACE(c_p); + set_tracee_flags(c_p, c_p->tracer_proc, 0, n); + esp[-1] = am_true; + } else { + esp[-1] = FAIL_TERM; + } + break; + case matchEnableTrace2: + n = erts_trace_flag2bit((--esp)[-1]); + esp[-1] = FAIL_TERM; + if (n) { + BEGIN_ATOMIC_TRACE(c_p); + if ( (tmpp = get_proc(c_p, 0, esp[0], 0))) { + /* Always take over the tracer of the current process */ + set_tracee_flags(tmpp, c_p->tracer_proc, 0, n); + esp[-1] = am_true; + } + } + break; + case matchDisableTrace: + if ( (n = erts_trace_flag2bit(esp[-1]))) { + BEGIN_ATOMIC_TRACE(c_p); + set_tracee_flags(c_p, c_p->tracer_proc, n, 0); + esp[-1] = am_true; + } else { + esp[-1] = FAIL_TERM; + } + break; + case matchDisableTrace2: + n = erts_trace_flag2bit((--esp)[-1]); + esp[-1] = FAIL_TERM; + if (n) { + BEGIN_ATOMIC_TRACE(c_p); + if ( (tmpp = get_proc(c_p, 0, esp[0], 0))) { + /* Always take over the tracer of the current process */ + set_tracee_flags(tmpp, c_p->tracer_proc, n, 0); + esp[-1] = am_true; + } + } + break; + case matchCaller: + if (!(c_p->cp) || !(hp = find_function_from_pc(c_p->cp))) { + *esp++ = am_undefined; + } else { + *esp++ = make_tuple(ehp); + ehp[0] = make_arityval(3); + ehp[1] = hp[0]; + ehp[2] = hp[1]; + ehp[3] = make_small(hp[2]); + ehp += 4; + } + break; + case matchSilent: + --esp; + if (*esp == am_true) { + erts_smp_proc_lock(c_p, ERTS_PROC_LOCKS_ALL_MINOR); + c_p->trace_flags |= F_TRACE_SILENT; + erts_smp_proc_unlock(c_p, ERTS_PROC_LOCKS_ALL_MINOR); + } + else if (*esp == am_false) { + erts_smp_proc_lock(c_p, ERTS_PROC_LOCKS_ALL_MINOR); + c_p->trace_flags &= ~F_TRACE_SILENT; + erts_smp_proc_unlock(c_p, ERTS_PROC_LOCKS_ALL_MINOR); + } + break; + case matchTrace2: + { + /* disable enable */ + Uint d_flags = 0, e_flags = 0; /* process trace flags */ + Eterm tracer = c_p->tracer_proc; + /* XXX Atomicity note: Not fully atomic. Default tracer + * is sampled from current process but applied to + * tracee and tracer later after releasing main + * locks on current process, so c_p->tracer_proc + * may actually have changed when tracee and tracer + * gets updated. I do not think nobody will notice. + * It is just the default value that is not fully atomic. + * and the real argument settable from match spec + * {trace,[],[{{tracer,Tracer}}]} is much, much older. + */ + int cputs = 0; + + if (! erts_trace_flags(esp[-1], &d_flags, &tracer, &cputs) || + ! erts_trace_flags(esp[-2], &e_flags, &tracer, &cputs) || + cputs ) { + (--esp)[-1] = FAIL_TERM; + break; + } + erts_smp_proc_lock(c_p, ERTS_PROC_LOCKS_ALL_MINOR); + (--esp)[-1] = set_match_trace(c_p, FAIL_TERM, tracer, + d_flags, e_flags); + erts_smp_proc_unlock(c_p, ERTS_PROC_LOCKS_ALL_MINOR); + } + break; + case matchTrace3: + { + /* disable enable */ + Uint d_flags = 0, e_flags = 0; /* process trace flags */ + Eterm tracer = c_p->tracer_proc; + /* XXX Atomicity note. Not fully atomic. See above. + * Above it could possibly be solved, but not here. + */ + int cputs = 0; + Eterm tracee = (--esp)[0]; + + if (! erts_trace_flags(esp[-1], &d_flags, &tracer, &cputs) || + ! erts_trace_flags(esp[-2], &e_flags, &tracer, &cputs) || + cputs || + ! (tmpp = get_proc(c_p, ERTS_PROC_LOCK_MAIN, + tracee, ERTS_PROC_LOCKS_ALL))) { + (--esp)[-1] = FAIL_TERM; + break; + } + if (tmpp == c_p) { + (--esp)[-1] = set_match_trace(c_p, FAIL_TERM, tracer, + d_flags, e_flags); + erts_smp_proc_unlock(c_p, ERTS_PROC_LOCKS_ALL_MINOR); + } else { + erts_smp_proc_unlock(c_p, ERTS_PROC_LOCK_MAIN); + (--esp)[-1] = set_match_trace(tmpp, FAIL_TERM, tracer, + d_flags, e_flags); + erts_smp_proc_unlock(tmpp, ERTS_PROC_LOCKS_ALL); + erts_smp_proc_lock(c_p, ERTS_PROC_LOCK_MAIN); + } + } + break; + case matchCatch: + do_catch = 1; + break; + case matchHalt: + goto success; + default: + erl_exit(1, "Internal error: unexpected opcode in match program."); + } + } +fail: + *return_flags = 0U; + if (fail_label >= 0) { /* We failed during a "TryMeElse", + lets restart, with the next match + program */ + pc = (prog->text) + fail_label; + cleanup_match_pseudo_process(mpsp, 1); + goto restart; + } + ret = THE_NON_VALUE; +success: + +#ifdef DMC_DEBUG + if (*heap_fence != FENCE_PATTERN) { + erl_exit(1, "Heap fence overwritten in db_prog_match after op " + "0x%08x, overwritten with 0x%08x.", save_op, *heap_fence); + } + if (*eheap_fence != FENCE_PATTERN) { + erl_exit(1, "Eheap fence overwritten in db_prog_match after op " + "0x%08x, overwritten with 0x%08x.", save_op, + *eheap_fence); + } + if (*stack_fence != FENCE_PATTERN) { + erl_exit(1, "Stack fence overwritten in db_prog_match after op " + "0x%08x, overwritten with 0x%08x.", save_op, + *stack_fence); + } +#endif + + esdp->current_process = current_scheduled; + + END_ATOMIC_TRACE(c_p); + return ret; +#undef FAIL +#undef FAIL_TERM +#undef BEGIN_ATOMIC_TRACE +#undef END_ATOMIC_TRACE +} + + +/* + * Convert a match program to a "magic" binary to return up to erlang + */ +Eterm db_make_mp_binary(Process *p, Binary *mp, Eterm **hpp) { + return erts_mk_magic_binary_term(hpp, &MSO(p), mp); +} + +DMCErrInfo *db_new_dmc_err_info(void) +{ + DMCErrInfo *ret = erts_alloc(ERTS_ALC_T_DB_DMC_ERR_INFO, + sizeof(DMCErrInfo)); + ret->var_trans = NULL; + ret->num_trans = 0; + ret->error_added = 0; + ret->first = NULL; + return ret; +} + +Eterm db_format_dmc_err_info(Process *p, DMCErrInfo *ei) +{ + int sl; + int vnum; + DMCError *tmp; + Eterm *shp; + Eterm ret = NIL; + Eterm tlist, tpl, sev; + char buff[DMC_ERR_STR_LEN + 20 /* for the number */]; + + for (tmp = ei->first; tmp != NULL; tmp = tmp->next) { + if (tmp->variable >= 0 && + tmp->variable < ei->num_trans && + ei->var_trans != NULL) { + vnum = (int) ei->var_trans[tmp->variable]; + } else { + vnum = tmp->variable; + } + if (vnum >= 0) + sprintf(buff,tmp->error_string, vnum); + else + strcpy(buff,tmp->error_string); + sl = strlen(buff); + shp = HAlloc(p, sl * 2 + 5); + sev = (tmp->severity == dmcWarning) ? + am_atom_put("warning",7) : + am_error; + tlist = buf_to_intlist(&shp, buff, sl, NIL); + tpl = TUPLE2(shp, sev, tlist); + shp += 3; + ret = CONS(shp, tpl, ret); + shp += 2; + } + return ret; +} + +void db_free_dmc_err_info(DMCErrInfo *ei){ + while (ei->first != NULL) { + DMCError *ll = ei->first->next; + erts_free(ERTS_ALC_T_DB_DMC_ERROR, ei->first); + ei->first = ll; + } + if (ei->var_trans) + erts_free(ERTS_ALC_T_DB_TRANS_TAB, ei->var_trans); + erts_free(ERTS_ALC_T_DB_DMC_ERR_INFO, ei); +} + +/* Calculate integer addition: counter+incr. +** Store bignum in *hpp and increase *hpp accordingly. +** *hpp is assumed to be large enough to hold the result. +*/ +Eterm db_add_counter(Eterm** hpp, Eterm counter, Eterm incr) +{ + Eterm big_tmp[2]; + Eterm res; + Sint ires; + Eterm arg1; + Eterm arg2; + + if (is_both_small(counter,incr)) { + ires = signed_val(counter) + signed_val(incr); + if (IS_SSMALL(ires)) { + return make_small(ires); + } else { + res = small_to_big(ires, *hpp); + ASSERT(BIG_NEED_SIZE(big_size(res))==2); + *hpp += 2; + return res; + } + } + else { + switch(NUMBER_CODE(counter, incr)) { + case SMALL_BIG: + arg1 = small_to_big(signed_val(counter), big_tmp); + arg2 = incr; + break; + case BIG_SMALL: + arg1 = counter; + arg2 = small_to_big(signed_val(incr), big_tmp); + break; + case BIG_BIG: + arg1 = incr; + arg2 = counter; + break; + default: + return THE_NON_VALUE; + } + res = big_plus(arg1, arg2, *hpp); + if (is_big(res)) { + *hpp += BIG_NEED_SIZE(big_size(res)); + } + return res; + } +} + +/* +** Update one element: +** handle: Initialized by db_lookup_dbterm() +** position: The tuple position of the elements to be updated. +** newval: The new value of the element. +** Can not fail. +*/ +void db_do_update_element(DbUpdateHandle* handle, + Sint position, + Eterm newval) +{ + Eterm oldval = handle->dbterm->tpl[position]; + Eterm* newp; + Eterm* oldp; + Uint newval_sz; + Uint oldval_sz; + + if (is_both_immed(newval,oldval)) { + handle->dbterm->tpl[position] = newval; + return; + } + else if (!handle->mustResize && is_boxed(newval)) { + newp = boxed_val(newval); + switch (*newp & _TAG_HEADER_MASK) { + case _TAG_HEADER_POS_BIG: + case _TAG_HEADER_NEG_BIG: + case _TAG_HEADER_FLOAT: + case _TAG_HEADER_HEAP_BIN: + newval_sz = header_arity(*newp) + 1; + if (is_boxed(oldval)) { + oldp = boxed_val(oldval); + switch (*oldp & _TAG_HEADER_MASK) { + case _TAG_HEADER_POS_BIG: + case _TAG_HEADER_NEG_BIG: + case _TAG_HEADER_FLOAT: + case _TAG_HEADER_HEAP_BIN: + oldval_sz = header_arity(*oldp) + 1; + if (oldval_sz == newval_sz) { + /* "self contained" terms of same size, do memcpy */ + sys_memcpy(oldp, newp, newval_sz*sizeof(Eterm)); + return; + } + goto both_size_set; + } + } + goto new_size_set; + } + } + /* Not possible for simple memcpy or dbterm is already non-contiguous, */ + /* need to realloc... */ + + newval_sz = is_immed(newval) ? 0 : size_object(newval); +new_size_set: + + oldval_sz = is_immed(oldval) ? 0 : size_object(oldval); +both_size_set: + + handle->new_size = handle->new_size - oldval_sz + newval_sz; + + /* write new value in old dbterm, finalize will make a flat copy */ + handle->dbterm->tpl[position] = newval; + handle->mustResize = 1; +} + + +/* +** Copy the object into a possibly new DbTerm, +** offset is the offset of the DbTerm from the start +** of the sysAllocaed structure, The possibly realloced and copied +** structure is returned. Make sure (((char *) old) - offset) is a +** pointer to a ERTS_ALC_T_DB_TERM allocated data area. +*/ +void* db_get_term(DbTableCommon *tb, DbTerm* old, Uint offset, Eterm obj) +{ + int size = size_object(obj); + void *structp = ((char*) old) - offset; + DbTerm* p; + Eterm copy; + Eterm *top; + + if (old != 0) { + erts_cleanup_offheap(&old->off_heap); + if (size == old->size) { + p = old; + } else { + Uint new_sz = offset + sizeof(DbTerm) + sizeof(Eterm)*(size-1); + Uint old_sz = offset + sizeof(DbTerm) + sizeof(Eterm)*(old->size-1); + + if (erts_ets_realloc_always_moves) { + void *nstructp = erts_db_alloc(ERTS_ALC_T_DB_TERM, + (DbTable *) tb, + new_sz); + memcpy(nstructp,structp,offset); + erts_db_free(ERTS_ALC_T_DB_TERM, + (DbTable *) tb, + structp, + old_sz); + structp = nstructp; + } else { + structp = erts_db_realloc(ERTS_ALC_T_DB_TERM, + (DbTable *) tb, + structp, + old_sz, + new_sz); + } + p = (DbTerm*) ((void *)(((char *) structp) + offset)); + } + } + else { + structp = erts_db_alloc(ERTS_ALC_T_DB_TERM, + (DbTable *) tb, + (offset + + sizeof(DbTerm) + + sizeof(Eterm)*(size-1))); + p = (DbTerm*) ((void *)(((char *) structp) + offset)); + } + p->size = size; + p->off_heap.mso = NULL; + p->off_heap.externals = NULL; +#ifndef HYBRID /* FIND ME! */ + p->off_heap.funs = NULL; +#endif + p->off_heap.overhead = 0; + + top = DBTERM_BUF(p); + copy = copy_struct(obj, size, &top, &p->off_heap); + DBTERM_SET_TPL(p,tuple_val(copy)); + + return structp; +} + + +void db_free_term_data(DbTerm* p) +{ + erts_cleanup_offheap(&p->off_heap); +} + + +/* +** Check if object represents a "match" variable +** i.e and atom $N where N is an integer +** +*/ + +int db_is_variable(Eterm obj) +{ + byte *b; + int n; + int N; + + if (is_not_atom(obj)) + return -1; + b = atom_tab(atom_val(obj))->name; + if ((n = atom_tab(atom_val(obj))->len) < 2) + return -1; + if (*b++ != '$') + return -1; + n--; + /* Handle first digit */ + if (*b == '0') + return (n == 1) ? 0 : -1; + if (*b >= '1' && *b <= '9') + N = *b++ - '0'; + else + return -1; + n--; + while(n--) { + if (*b >= '0' && *b <= '9') { + N = N*10 + (*b - '0'); + b++; + } + else + return -1; + } + return N; +} + + +/* check if obj is (or contains) a variable */ +/* return 1 if obj contains a variable or underscore */ +/* return 0 if obj is fully ground */ + +int db_has_variable(Eterm obj) +{ + switch(obj & _TAG_PRIMARY_MASK) { + case TAG_PRIMARY_LIST: { + while (is_list(obj)) { + if (db_has_variable(CAR(list_val(obj)))) + return 1; + obj = CDR(list_val(obj)); + } + return(db_has_variable(obj)); /* Non wellformed list or [] */ + } + case TAG_PRIMARY_BOXED: + if (!BOXED_IS_TUPLE(obj)) { + return 0; + } else { + Eterm *tuple = tuple_val(obj); + int arity = arityval(*tuple++); + while(arity--) { + if (db_has_variable(*tuple)) + return 1; + tuple++; + } + return(0); + } + case TAG_PRIMARY_IMMED1: + if (obj == am_Underscore || db_is_variable(obj) >= 0) + return 1; + } + return 0; +} + +int erts_db_is_compiled_ms(Eterm term) +{ + return (is_binary(term) + && (thing_subtag(*binary_val(term)) == REFC_BINARY_SUBTAG) + && IsMatchProgBinary((((ProcBin *) binary_val(term))->val))); +} + +/* +** Local (static) utilities. +*/ + +/* +*************************************************************************** +** Compiled matches +*************************************************************************** +*/ +/* +** Utility to add an error +*/ + +static void add_dmc_err(DMCErrInfo *err_info, + char *str, + int variable, + Eterm term, + DMCErrorSeverity severity) +{ + /* Linked in in reverse order, to ease the formatting */ + DMCError *e = erts_alloc(ERTS_ALC_T_DB_DMC_ERROR, sizeof(DMCError)); + if (term != 0UL) { + erts_snprintf(e->error_string, DMC_ERR_STR_LEN, str, term); + } else { + strncpy(e->error_string, str, DMC_ERR_STR_LEN); + e->error_string[DMC_ERR_STR_LEN] ='\0'; + } + e->variable = variable; + e->severity = severity; + e->next = err_info->first; +#ifdef HARDDEBUG + erts_fprintf(stderr,"add_dmc_err: %s\n",e->error_string); +#endif + err_info->first = e; + if (severity >= dmcError) + err_info->error_added = 1; +} + +/* +** Handle one term in the match expression (not the guard) +*/ +static DMCRet dmc_one_term(DMCContext *context, + DMCHeap *heap, + DMC_STACK_TYPE(Eterm) *stack, + DMC_STACK_TYPE(Uint) *text, + Eterm c) +{ + Sint n; + Eterm *hp; + ErlHeapFragment *tmp_mb; + Uint sz, sz2, sz3; + Uint i, j; + + + switch (c & _TAG_PRIMARY_MASK) { + case TAG_PRIMARY_IMMED1: + if ((n = db_is_variable(c)) >= 0) { /* variable */ + if (n >= heap->size) { + /* + ** Ouch, big integer in match variable. + */ + Eterm *save_hp; + ASSERT(heap->data == heap->def); + sz = sz2 = sz3 = 0; + for (j = 0; j < context->num_match; ++j) { + sz += size_object(context->matchexpr[j]); + sz2 += size_object(context->guardexpr[j]); + sz3 += size_object(context->bodyexpr[j]); + } + context->copy = + new_message_buffer(sz + sz2 + sz3 + + context->num_match); + save_hp = hp = context->copy->mem; + hp += context->num_match; + for (j = 0; j < context->num_match; ++j) { + context->matchexpr[j] = + copy_struct(context->matchexpr[j], + size_object(context->matchexpr[j]), &hp, + &(context->copy->off_heap)); + context->guardexpr[j] = + copy_struct(context->guardexpr[j], + size_object(context->guardexpr[j]), &hp, + &(context->copy->off_heap)); + context->bodyexpr[j] = + copy_struct(context->bodyexpr[j], + size_object(context->bodyexpr[j]), &hp, + &(context->copy->off_heap)); + } + for (j = 0; j < context->num_match; ++j) { + /* the actual expressions can be + atoms in their selves, place them first */ + *save_hp++ = context->matchexpr[j]; + } + heap->size = match_compact(context->copy, + context->err_info); + for (j = 0; j < context->num_match; ++j) { + /* restore the match terms, as they + may be atoms that changed */ + context->matchexpr[j] = context->copy->mem[j]; + } + heap->data = erts_alloc(ERTS_ALC_T_DB_MS_CMPL_HEAP, + heap->size*sizeof(unsigned)); + sys_memset(heap->data, 0, + heap->size * sizeof(unsigned)); + DMC_CLEAR(*stack); + /*DMC_PUSH(*stack,NIL);*/ + DMC_CLEAR(*text); + return retRestart; + } + if (heap->data[n]) { /* already bound ? */ + DMC_PUSH(*text,matchCmp); + DMC_PUSH(*text,n); + } else { /* Not bound, bind! */ + if (n >= heap->used) + heap->used = n + 1; + DMC_PUSH(*text,matchBind); + DMC_PUSH(*text,n); + heap->data[n] = 1; + } + } else if (c == am_Underscore) { + DMC_PUSH(*text, matchSkip); + } else { /* Any immediate value */ + DMC_PUSH(*text, matchEq); + DMC_PUSH(*text, (Uint) c); + } + break; + case TAG_PRIMARY_LIST: + DMC_PUSH(*text, matchPushL); + ++(context->stack_used); + DMC_PUSH(*stack, c); + break; + case TAG_PRIMARY_BOXED: { + Eterm hdr = *boxed_val(c); + switch ((hdr & _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_HEADER_ARITYVAL >> _TAG_PRIMARY_SIZE): + n = arityval(*tuple_val(c)); + DMC_PUSH(*text, matchPushT); + ++(context->stack_used); + DMC_PUSH(*text, n); + DMC_PUSH(*stack, c); + break; + case (_TAG_HEADER_REF >> _TAG_PRIMARY_SIZE): + n = thing_arityval(*internal_ref_val(c)); + DMC_PUSH(*text, matchEqRef); + DMC_PUSH(*text, *internal_ref_val(c)); + for (i = 1; i <= n; ++i) { + DMC_PUSH(*text, (Uint) internal_ref_val(c)[i]); + } + break; + case (_TAG_HEADER_POS_BIG >> _TAG_PRIMARY_SIZE): + case (_TAG_HEADER_NEG_BIG >> _TAG_PRIMARY_SIZE): + n = thing_arityval(*big_val(c)); + DMC_PUSH(*text, matchEqBig); + DMC_PUSH(*text, *big_val(c)); + for (i = 1; i <= n; ++i) { + DMC_PUSH(*text, (Uint) big_val(c)[i]); + } + break; + case (_TAG_HEADER_FLOAT >> _TAG_PRIMARY_SIZE): + DMC_PUSH(*text,matchEqFloat); + DMC_PUSH(*text, (Uint) float_val(c)[1]); + /* XXX: this reads and pushes random junk on ARCH_64 */ + DMC_PUSH(*text, (Uint) float_val(c)[2]); + break; + default: /* BINARY, FUN, VECTOR, or EXTERNAL */ + /* + ** Make a private copy... + */ + n = size_object(c); + tmp_mb = new_message_buffer(n); + hp = tmp_mb->mem; + DMC_PUSH(*text, matchEqBin); + DMC_PUSH(*text, copy_struct(c, n, &hp, &(tmp_mb->off_heap))); + tmp_mb->next = context->save; + context->save = tmp_mb; + break; + } + break; + } + default: + erl_exit(1, "db_match_compile: " + "Bad object on heap: 0x%08lx\n", + (unsigned long) c); + } + return retOk; +} + +/* +** Match guard compilation +*/ + +static void do_emit_constant(DMCContext *context, DMC_STACK_TYPE(Uint) *text, + Eterm t) +{ + int sz; + ErlHeapFragment *emb; + Eterm *hp; + Eterm tmp; + + if (IS_CONST(t)) { + tmp = t; + } else { + sz = my_size_object(t); + emb = new_message_buffer(sz); + hp = emb->mem; + tmp = my_copy_struct(t,&hp,&(emb->off_heap)); + emb->next = context->save; + context->save = emb; + } + DMC_PUSH(*text,matchPushC); + DMC_PUSH(*text,(Uint) tmp); + if (++context->stack_used > context->stack_need) + context->stack_need = context->stack_used; +} + +#define RETURN_ERROR_X(String, X, Y, ContextP, ConstantF) \ +do { \ +if ((ContextP)->err_info != NULL) { \ + (ConstantF) = 0; \ + add_dmc_err((ContextP)->err_info, String, X, Y, dmcError); \ + return retOk; \ +} else \ + return retFail; \ +} while(0) + +#define RETURN_ERROR(String, ContextP, ConstantF) \ + RETURN_ERROR_X(String, -1, 0UL, ContextP, ConstantF) + +#define RETURN_VAR_ERROR(String, N, ContextP, ConstantF) \ + RETURN_ERROR_X(String, N, 0UL, ContextP, ConstantF) + +#define RETURN_TERM_ERROR(String, T, ContextP, ConstantF) \ + RETURN_ERROR_X(String, -1, T, ContextP, ConstantF) + +#define WARNING(String, ContextP) \ +add_dmc_err((ContextP)->err_info, String, -1, 0UL, dmcWarning) + +#define VAR_WARNING(String, N, ContextP) \ +add_dmc_err((ContextP)->err_info, String, N, 0UL, dmcWarning) + +#define TERM_WARNING(String, T, ContextP) \ +add_dmc_err((ContextP)->err_info, String, -1, T, dmcWarning) + +static DMCRet dmc_list(DMCContext *context, + DMCHeap *heap, + DMC_STACK_TYPE(Uint) *text, + Eterm t, + int *constant) +{ + int c1; + int c2; + int ret; + + if ((ret = dmc_expr(context, heap, text, CAR(list_val(t)), &c1)) != retOk) + return ret; + + if ((ret = dmc_expr(context, heap, text, CDR(list_val(t)), &c2)) != retOk) + return ret; + + if (c1 && c2) { + *constant = 1; + return retOk; + } + *constant = 0; + if (!c1) { + /* The CAR is not a constant, so if the CDR is, we just push it, + otherwise it is already pushed. */ + if (c2) + do_emit_constant(context, text, CDR(list_val(t))); + DMC_PUSH(*text, matchConsA); + } else { /* !c2 && c1 */ + do_emit_constant(context, text, CAR(list_val(t))); + DMC_PUSH(*text, matchConsB); + } + --context->stack_used; /* Two objects on stack becomes one */ + context->eheap_need += 2; + return retOk; +} + +static DMCRet dmc_tuple(DMCContext *context, + DMCHeap *heap, + DMC_STACK_TYPE(Uint) *text, + Eterm t, + int *constant) +{ + DMC_STACK_TYPE(Uint) instr_save; + int all_constant = 1; + int textpos = DMC_STACK_NUM(*text); + Eterm *p = tuple_val(t); + Uint nelems = arityval(*p); + Uint i; + int c; + DMCRet ret; + + /* + ** We remember where we started to layout code, + ** assume all is constant and back up and restart if not so. + ** The tuple should be laid out with the last element first, + ** so we can memcpy the tuple to the eheap. + */ + for (i = nelems; i > 0; --i) { + if ((ret = dmc_expr(context, heap, text, p[i], &c)) != retOk) + return ret; + if (!c && all_constant) { + all_constant = 0; + if (i < nelems) { + Uint j; + + /* + * Oops, we need to relayout the constants. + * Save the already laid out instructions. + */ + DMC_INIT_STACK(instr_save); + while (DMC_STACK_NUM(*text) > textpos) + DMC_PUSH(instr_save, DMC_POP(*text)); + for (j = nelems; j > i; --j) + do_emit_constant(context, text, p[j]); + while(!DMC_EMPTY(instr_save)) + DMC_PUSH(*text, DMC_POP(instr_save)); + DMC_FREE(instr_save); + } + } else if (c && !all_constant) { + /* push a constant */ + do_emit_constant(context, text, p[i]); + } + } + + if (all_constant) { + *constant = 1; + return retOk; + } + DMC_PUSH(*text, matchMkTuple); + DMC_PUSH(*text, nelems); + context->stack_used -= (nelems - 1); + context->eheap_need += (nelems + 1); + *constant = 0; + return retOk; +} + +static DMCRet dmc_whole_expression(DMCContext *context, + DMCHeap *heap, + DMC_STACK_TYPE(Uint) *text, + Eterm t, + int *constant) +{ + if (context->cflags & DCOMP_TRACE) { + /* Hmmm, convert array to list... */ + if (context->special) { + DMC_PUSH(*text, matchPushArrayAsListU); + } else { + ASSERT(is_tuple(context->matchexpr + [context->current_match])); + context->eheap_need += + arityval(*(tuple_val(context->matchexpr + [context->current_match]))) * 2; + DMC_PUSH(*text, matchPushArrayAsList); + } + } else { + DMC_PUSH(*text, matchPushExpr); + } + ++context->stack_used; + if (context->stack_used > context->stack_need) + context->stack_need = context->stack_used; + *constant = 0; + return retOk; +} + +static DMCRet dmc_variable(DMCContext *context, + DMCHeap *heap, + DMC_STACK_TYPE(Uint) *text, + Eterm t, + int *constant) +{ + Uint n = db_is_variable(t); + ASSERT(n >= 0); + if (n >= heap->used) + RETURN_VAR_ERROR("Variable $%d is unbound.", n, context, *constant); + if (heap->data[n] == 0U) + RETURN_VAR_ERROR("Variable $%d is unbound.", n, context, *constant); + DMC_PUSH(*text, matchPushV); + DMC_PUSH(*text, n); + ++context->stack_used; + if (context->stack_used > context->stack_need) + context->stack_need = context->stack_used; + *constant = 0; + return retOk; +} + +static DMCRet dmc_all_bindings(DMCContext *context, + DMCHeap *heap, + DMC_STACK_TYPE(Uint) *text, + Eterm t, + int *constant) +{ + int i; + int heap_used = 0; + + DMC_PUSH(*text, matchPushC); + DMC_PUSH(*text, NIL); + for (i = heap->used - 1; i >= 0; --i) { + if (heap->data[i]) { + DMC_PUSH(*text, matchPushV); + DMC_PUSH(*text, i); + DMC_PUSH(*text, matchConsB); + heap_used += 2; + } + } + ++context->stack_used; + if ((context->stack_used + 1) > context->stack_need) + context->stack_need = (context->stack_used + 1); + context->eheap_need += heap_used; + *constant = 0; + return retOk; +} + +static DMCRet dmc_const(DMCContext *context, + DMCHeap *heap, + DMC_STACK_TYPE(Uint) *text, + Eterm t, + int *constant) +{ + Eterm *p = tuple_val(t); + Uint a = arityval(*p); + + if (a != 2) { + RETURN_TERM_ERROR("Special form 'const' called with more than one " + "argument in %T.", t, context, *constant); + } + *constant = 1; + return retOk; +} + +static DMCRet dmc_and(DMCContext *context, + DMCHeap *heap, + DMC_STACK_TYPE(Uint) *text, + Eterm t, + int *constant) +{ + Eterm *p = tuple_val(t); + Uint a = arityval(*p); + DMCRet ret; + int i; + int c; + + if (a < 2) { + RETURN_TERM_ERROR("Special form 'and' called without arguments " + "in %T.", t, context, *constant); + } + *constant = 0; + for (i = a; i > 1; --i) { + if ((ret = dmc_expr(context, heap, text, p[i], &c)) != retOk) + return ret; + if (c) + do_emit_constant(context, text, p[i]); + } + DMC_PUSH(*text, matchAnd); + DMC_PUSH(*text, (Uint) a - 1); + context->stack_used -= (a - 2); + return retOk; +} + +static DMCRet dmc_or(DMCContext *context, + DMCHeap *heap, + DMC_STACK_TYPE(Uint) *text, + Eterm t, + int *constant) +{ + Eterm *p = tuple_val(t); + Uint a = arityval(*p); + DMCRet ret; + int i; + int c; + + if (a < 2) { + RETURN_TERM_ERROR("Special form 'or' called without arguments " + "in %T.", t, context, *constant); + } + *constant = 0; + for (i = a; i > 1; --i) { + if ((ret = dmc_expr(context, heap, text, p[i], &c)) != retOk) + return ret; + if (c) + do_emit_constant(context, text, p[i]); + } + DMC_PUSH(*text, matchOr); + DMC_PUSH(*text, (Uint) a - 1); + context->stack_used -= (a - 2); + return retOk; +} + + +static DMCRet dmc_andalso(DMCContext *context, + DMCHeap *heap, + DMC_STACK_TYPE(Uint) *text, + Eterm t, + int *constant) +{ + Eterm *p = tuple_val(t); + Uint a = arityval(*p); + DMCRet ret; + int i; + int c; + Uint lbl; + Uint lbl_next; + Uint lbl_val; + + if (a < 2) { + RETURN_TERM_ERROR("Special form 'andalso' called without" + " arguments " + "in %T.", t, context, *constant); + } + *constant = 0; + lbl = 0; + for (i = 2; i <= a; ++i) { + if ((ret = dmc_expr(context, heap, text, p[i], &c)) != retOk) + return ret; + if (c) + do_emit_constant(context, text, p[i]); + if (i == a) { + DMC_PUSH(*text, matchJump); + } else { + DMC_PUSH(*text, matchAndAlso); + } + DMC_PUSH(*text, lbl); + lbl = DMC_STACK_NUM(*text)-1; + --(context->stack_used); + } + DMC_PUSH(*text, matchPushC); + DMC_PUSH(*text, am_true); + lbl_val = DMC_STACK_NUM(*text); + while (lbl) { + lbl_next = DMC_PEEK(*text, lbl); + DMC_POKE(*text, lbl, lbl_val-lbl-1); + lbl = lbl_next; + } + if (++context->stack_used > context->stack_need) + context->stack_need = context->stack_used; + return retOk; +} + +static DMCRet dmc_orelse(DMCContext *context, + DMCHeap *heap, + DMC_STACK_TYPE(Uint) *text, + Eterm t, + int *constant) +{ + Eterm *p = tuple_val(t); + Uint a = arityval(*p); + DMCRet ret; + int i; + int c; + Uint lbl; + Uint lbl_next; + Uint lbl_val; + + if (a < 2) { + RETURN_TERM_ERROR("Special form 'orelse' called without arguments " + "in %T.", t, context, *constant); + } + *constant = 0; + lbl = 0; + for (i = 2; i <= a; ++i) { + if ((ret = dmc_expr(context, heap, text, p[i], &c)) != retOk) + return ret; + if (c) + do_emit_constant(context, text, p[i]); + if (i == a) { + DMC_PUSH(*text, matchJump); + } else { + DMC_PUSH(*text, matchOrElse); + } + DMC_PUSH(*text, lbl); + lbl = DMC_STACK_NUM(*text)-1; + --(context->stack_used); + } + DMC_PUSH(*text, matchPushC); + DMC_PUSH(*text, am_false); + lbl_val = DMC_STACK_NUM(*text); + while (lbl) { + lbl_next = DMC_PEEK(*text, lbl); + DMC_POKE(*text, lbl, lbl_val-lbl-1); + lbl = lbl_next; + } + if (++context->stack_used > context->stack_need) + context->stack_need = context->stack_used; + return retOk; +} + +static DMCRet dmc_message(DMCContext *context, + DMCHeap *heap, + DMC_STACK_TYPE(Uint) *text, + Eterm t, + int *constant) +{ + Eterm *p = tuple_val(t); + Uint a = arityval(*p); + DMCRet ret; + int c; + + + if (!(context->cflags & DCOMP_TRACE)) { + RETURN_ERROR("Special form 'message' used in wrong dialect.", + context, + *constant); + } + if (context->is_guard) { + RETURN_ERROR("Special form 'message' called in guard context.", + context, + *constant); + } + + if (a != 2) { + RETURN_TERM_ERROR("Special form 'message' called with wrong " + "number of arguments in %T.", t, context, + *constant); + } + *constant = 0; + if ((ret = dmc_expr(context, heap, text, p[2], &c)) != retOk) { + return ret; + } + if (c) { + do_emit_constant(context, text, p[2]); + } + DMC_PUSH(*text, matchReturn); + DMC_PUSH(*text, matchPushC); + DMC_PUSH(*text, am_true); + /* Push as much as we remove, stack_need is untouched */ + return retOk; +} + +static DMCRet dmc_self(DMCContext *context, + DMCHeap *heap, + DMC_STACK_TYPE(Uint) *text, + Eterm t, + int *constant) +{ + Eterm *p = tuple_val(t); + Uint a = arityval(*p); + + if (a != 1) { + RETURN_TERM_ERROR("Special form 'self' called with arguments " + "in %T.", t, context, *constant); + } + *constant = 0; + DMC_PUSH(*text, matchSelf); + if (++context->stack_used > context->stack_need) + context->stack_need = context->stack_used; + return retOk; +} + +static DMCRet dmc_return_trace(DMCContext *context, + DMCHeap *heap, + DMC_STACK_TYPE(Uint) *text, + Eterm t, + int *constant) +{ + Eterm *p = tuple_val(t); + Uint a = arityval(*p); + + if (!(context->cflags & DCOMP_TRACE)) { + RETURN_ERROR("Special form 'return_trace' used in wrong dialect.", + context, + *constant); + } + if (context->is_guard) { + RETURN_ERROR("Special form 'return_trace' called in " + "guard context.", context, *constant); + } + + if (a != 1) { + RETURN_TERM_ERROR("Special form 'return_trace' called with " + "arguments in %T.", t, context, *constant); + } + *constant = 0; + DMC_PUSH(*text, matchSetReturnTrace); /* Pushes 'true' on the stack */ + if (++context->stack_used > context->stack_need) + context->stack_need = context->stack_used; + return retOk; +} + +static DMCRet dmc_exception_trace(DMCContext *context, + DMCHeap *heap, + DMC_STACK_TYPE(Uint) *text, + Eterm t, + int *constant) +{ + Eterm *p = tuple_val(t); + Uint a = arityval(*p); + + if (!(context->cflags & DCOMP_TRACE)) { + RETURN_ERROR("Special form 'exception_trace' used in wrong dialect.", + context, + *constant); + } + if (context->is_guard) { + RETURN_ERROR("Special form 'exception_trace' called in " + "guard context.", context, *constant); + } + + if (a != 1) { + RETURN_TERM_ERROR("Special form 'exception_trace' called with " + "arguments in %T.", t, context, *constant); + } + *constant = 0; + DMC_PUSH(*text, matchSetExceptionTrace); /* Pushes 'true' on the stack */ + if (++context->stack_used > context->stack_need) + context->stack_need = context->stack_used; + return retOk; +} + + + +static DMCRet dmc_is_seq_trace(DMCContext *context, + DMCHeap *heap, + DMC_STACK_TYPE(Uint) *text, + Eterm t, + int *constant) +{ + Eterm *p = tuple_val(t); + Uint a = arityval(*p); + + if (!(context->cflags & DCOMP_TRACE)) { + RETURN_ERROR("Special form 'is_seq_trace' used in wrong dialect.", + context, + *constant); + } + if (a != 1) { + RETURN_TERM_ERROR("Special form 'is_seq_trace' called with " + "arguments in %T.", t, context, *constant); + } + *constant = 0; + DMC_PUSH(*text, matchIsSeqTrace); + /* Pushes 'true' or 'false' on the stack */ + if (++context->stack_used > context->stack_need) + context->stack_need = context->stack_used; + return retOk; +} + +static DMCRet dmc_set_seq_token(DMCContext *context, + DMCHeap *heap, + DMC_STACK_TYPE(Uint) *text, + Eterm t, + int *constant) +{ + Eterm *p = tuple_val(t); + Uint a = arityval(*p); + DMCRet ret; + int c; + + + if (!(context->cflags & DCOMP_TRACE)) { + RETURN_ERROR("Special form 'set_seq_token' used in wrong dialect.", + context, + *constant); + } + if (context->is_guard) { + RETURN_ERROR("Special form 'set_seq_token' called in " + "guard context.", context, *constant); + } + + if (a != 3) { + RETURN_TERM_ERROR("Special form 'set_seq_token' called with wrong " + "number of arguments in %T.", t, context, + *constant); + } + *constant = 0; + if ((ret = dmc_expr(context, heap, text, p[3], &c)) != retOk) { + return ret; + } + if (c) { + do_emit_constant(context, text, p[3]); + } + if ((ret = dmc_expr(context, heap, text, p[2], &c)) != retOk) { + return ret; + } + if (c) { + do_emit_constant(context, text, p[2]); + } + if (context->cflags & DCOMP_FAKE_DESTRUCTIVE) { + DMC_PUSH(*text, matchSetSeqTokenFake); + } else { + DMC_PUSH(*text, matchSetSeqToken); + } + --context->stack_used; /* Remove two and add one */ + return retOk; +} + +static DMCRet dmc_get_seq_token(DMCContext *context, + DMCHeap *heap, + DMC_STACK_TYPE(Uint) *text, + Eterm t, + int *constant) +{ + Eterm *p = tuple_val(t); + Uint a = arityval(*p); + + if (!(context->cflags & DCOMP_TRACE)) { + RETURN_ERROR("Special form 'get_seq_token' used in wrong dialect.", + context, + *constant); + } + if (context->is_guard) { + RETURN_ERROR("Special form 'get_seq_token' called in " + "guard context.", context, *constant); + } + if (a != 1) { + RETURN_TERM_ERROR("Special form 'get_seq_token' called with " + "arguments in %T.", t, context, + *constant); + } + + *constant = 0; + DMC_PUSH(*text, matchGetSeqToken); + context->eheap_need += (6 /* A 5-tuple is built */ + + EXTERNAL_THING_HEAD_SIZE + 2 /* Sender can + be an external + pid */); + if (++context->stack_used > context->stack_need) + context->stack_need = context->stack_used; + return retOk; +} + + + +static DMCRet dmc_display(DMCContext *context, + DMCHeap *heap, + DMC_STACK_TYPE(Uint) *text, + Eterm t, + int *constant) +{ + Eterm *p = tuple_val(t); + Uint a = arityval(*p); + DMCRet ret; + int c; + + + if (!(context->cflags & DCOMP_TRACE)) { + RETURN_ERROR("Special form 'display' used in wrong dialect.", + context, + *constant); + } + if (context->is_guard) { + RETURN_ERROR("Special form 'display' called in guard context.", + context, + *constant); + } + + if (a != 2) { + RETURN_TERM_ERROR("Special form 'display' called with wrong " + "number of arguments in %T.", t, context, + *constant); + } + *constant = 0; + if ((ret = dmc_expr(context, heap, text, p[2], &c)) != retOk) { + return ret; + } + if (c) { + do_emit_constant(context, text, p[2]); + } + DMC_PUSH(*text, matchDisplay); + /* Push as much as we remove, stack_need is untouched */ + return retOk; +} + +static DMCRet dmc_process_dump(DMCContext *context, + DMCHeap *heap, + DMC_STACK_TYPE(Uint) *text, + Eterm t, + int *constant) +{ + Eterm *p = tuple_val(t); + Uint a = arityval(*p); + + if (!(context->cflags & DCOMP_TRACE)) { + RETURN_ERROR("Special form 'process_dump' used in wrong dialect.", + context, + *constant); + } + if (context->is_guard) { + RETURN_ERROR("Special form 'process_dump' called in " + "guard context.", context, *constant); + } + + if (a != 1) { + RETURN_TERM_ERROR("Special form 'process_dump' called with " + "arguments in %T.", t, context, *constant); + } + *constant = 0; + DMC_PUSH(*text, matchProcessDump); /* Creates binary */ + if (++context->stack_used > context->stack_need) + context->stack_need = context->stack_used; + return retOk; +} + +static DMCRet dmc_enable_trace(DMCContext *context, + DMCHeap *heap, + DMC_STACK_TYPE(Uint) *text, + Eterm t, + int *constant) +{ + Eterm *p = tuple_val(t); + Uint a = arityval(*p); + DMCRet ret; + int c; + + + if (!(context->cflags & DCOMP_TRACE)) { + RETURN_ERROR("Special form 'enable_trace' used in wrong dialect.", + context, + *constant); + } + if (context->is_guard) { + RETURN_ERROR("Special form 'enable_trace' called in guard context.", + context, + *constant); + } + + switch (a) { + case 2: + *constant = 0; + if ((ret = dmc_expr(context, heap, text, p[2], &c)) != retOk) { + return ret; + } + if (c) { + do_emit_constant(context, text, p[2]); + } + DMC_PUSH(*text, matchEnableTrace); + /* Push as much as we remove, stack_need is untouched */ + break; + case 3: + *constant = 0; + if ((ret = dmc_expr(context, heap, text, p[3], &c)) != retOk) { + return ret; + } + if (c) { + do_emit_constant(context, text, p[3]); + } + if ((ret = dmc_expr(context, heap, text, p[2], &c)) != retOk) { + return ret; + } + if (c) { + do_emit_constant(context, text, p[2]); + } + DMC_PUSH(*text, matchEnableTrace2); + --context->stack_used; /* Remove two and add one */ + break; + default: + RETURN_TERM_ERROR("Special form 'enable_trace' called with wrong " + "number of arguments in %T.", t, context, + *constant); + } + return retOk; +} + +static DMCRet dmc_disable_trace(DMCContext *context, + DMCHeap *heap, + DMC_STACK_TYPE(Uint) *text, + Eterm t, + int *constant) +{ + Eterm *p = tuple_val(t); + Uint a = arityval(*p); + DMCRet ret; + int c; + + + if (!(context->cflags & DCOMP_TRACE)) { + RETURN_ERROR("Special form 'disable_trace' used in wrong dialect.", + context, + *constant); + } + if (context->is_guard) { + RETURN_ERROR("Special form 'disable_trace' called in guard context.", + context, + *constant); + } + + switch (a) { + case 2: + *constant = 0; + if ((ret = dmc_expr(context, heap, text, p[2], &c)) != retOk) { + return ret; + } + if (c) { + do_emit_constant(context, text, p[2]); + } + DMC_PUSH(*text, matchDisableTrace); + /* Push as much as we remove, stack_need is untouched */ + break; + case 3: + *constant = 0; + if ((ret = dmc_expr(context, heap, text, p[3], &c)) != retOk) { + return ret; + } + if (c) { + do_emit_constant(context, text, p[3]); + } + if ((ret = dmc_expr(context, heap, text, p[2], &c)) != retOk) { + return ret; + } + if (c) { + do_emit_constant(context, text, p[2]); + } + DMC_PUSH(*text, matchDisableTrace2); + --context->stack_used; /* Remove two and add one */ + break; + default: + RETURN_TERM_ERROR("Special form 'disable_trace' called with wrong " + "number of arguments in %T.", t, context, + *constant); + } + return retOk; +} + +static DMCRet dmc_trace(DMCContext *context, + DMCHeap *heap, + DMC_STACK_TYPE(Uint) *text, + Eterm t, + int *constant) +{ + Eterm *p = tuple_val(t); + Uint a = arityval(*p); + DMCRet ret; + int c; + + + if (!(context->cflags & DCOMP_TRACE)) { + RETURN_ERROR("Special form 'trace' used in wrong dialect.", + context, + *constant); + } + if (context->is_guard) { + RETURN_ERROR("Special form 'trace' called in guard context.", + context, + *constant); + } + + switch (a) { + case 3: + *constant = 0; + if ((ret = dmc_expr(context, heap, text, p[3], &c)) != retOk) { + return ret; + } + if (c) { + do_emit_constant(context, text, p[3]); + } + if ((ret = dmc_expr(context, heap, text, p[2], &c)) != retOk) { + return ret; + } + if (c) { + do_emit_constant(context, text, p[2]); + } + DMC_PUSH(*text, matchTrace2); + --context->stack_used; /* Remove two and add one */ + break; + case 4: + *constant = 0; + if ((ret = dmc_expr(context, heap, text, p[4], &c)) != retOk) { + return ret; + } + if (c) { + do_emit_constant(context, text, p[4]); + } + if ((ret = dmc_expr(context, heap, text, p[3], &c)) != retOk) { + return ret; + } + if (c) { + do_emit_constant(context, text, p[3]); + } + if ((ret = dmc_expr(context, heap, text, p[2], &c)) != retOk) { + return ret; + } + if (c) { + do_emit_constant(context, text, p[2]); + } + DMC_PUSH(*text, matchTrace3); + context->stack_used -= 2; /* Remove three and add one */ + break; + default: + RETURN_TERM_ERROR("Special form 'trace' called with wrong " + "number of arguments in %T.", t, context, + *constant); + } + return retOk; +} + + + +static DMCRet dmc_caller(DMCContext *context, + DMCHeap *heap, + DMC_STACK_TYPE(Uint) *text, + Eterm t, + int *constant) +{ + Eterm *p = tuple_val(t); + Uint a = arityval(*p); + + if (!(context->cflags & DCOMP_TRACE)) { + RETURN_ERROR("Special form 'caller' used in wrong dialect.", + context, + *constant); + } + if (context->is_guard) { + RETURN_ERROR("Special form 'caller' called in " + "guard context.", context, *constant); + } + + if (a != 1) { + RETURN_TERM_ERROR("Special form 'caller' called with " + "arguments in %T.", t, context, *constant); + } + *constant = 0; + DMC_PUSH(*text, matchCaller); /* Creates binary */ + context->eheap_need += 4; /* A 3-tuple is built */ + if (++context->stack_used > context->stack_need) + context->stack_need = context->stack_used; + return retOk; +} + + + +static DMCRet dmc_silent(DMCContext *context, + DMCHeap *heap, + DMC_STACK_TYPE(Uint) *text, + Eterm t, + int *constant) +{ + Eterm *p = tuple_val(t); + Uint a = arityval(*p); + DMCRet ret; + int c; + + if (!(context->cflags & DCOMP_TRACE)) { + RETURN_ERROR("Special form 'silent' used in wrong dialect.", + context, + *constant); + } + if (context->is_guard) { + RETURN_ERROR("Special form 'silent' called in " + "guard context.", context, *constant); + } + + if (a != 2) { + RETURN_TERM_ERROR("Special form 'silent' called with wrong " + "number of arguments in %T.", t, context, + *constant); + } + *constant = 0; + if ((ret = dmc_expr(context, heap, text, p[2], &c)) != retOk) { + return ret; + } + if (c) { + do_emit_constant(context, text, p[2]); + } + DMC_PUSH(*text, matchSilent); + DMC_PUSH(*text, matchPushC); + DMC_PUSH(*text, am_true); + /* Push as much as we remove, stack_need is untouched */ + return retOk; +} + + + +static DMCRet dmc_fun(DMCContext *context, + DMCHeap *heap, + DMC_STACK_TYPE(Uint) *text, + Eterm t, + int *constant) +{ + Eterm *p = tuple_val(t); + Uint a = arityval(*p); + int c; + int i; + DMCRet ret; + DMCGuardBif *b; + + /* Special forms. */ + switch (p[1]) { + case am_const: + return dmc_const(context, heap, text, t, constant); + case am_and: + return dmc_and(context, heap, text, t, constant); + case am_or: + return dmc_or(context, heap, text, t, constant); + case am_andalso: + case am_andthen: + return dmc_andalso(context, heap, text, t, constant); + case am_orelse: + return dmc_orelse(context, heap, text, t, constant); + case am_self: + return dmc_self(context, heap, text, t, constant); + case am_message: + return dmc_message(context, heap, text, t, constant); + case am_is_seq_trace: + return dmc_is_seq_trace(context, heap, text, t, constant); + case am_set_seq_token: + return dmc_set_seq_token(context, heap, text, t, constant); + case am_get_seq_token: + return dmc_get_seq_token(context, heap, text, t, constant); + case am_return_trace: + return dmc_return_trace(context, heap, text, t, constant); + case am_exception_trace: + return dmc_exception_trace(context, heap, text, t, constant); + case am_display: + return dmc_display(context, heap, text, t, constant); + case am_process_dump: + return dmc_process_dump(context, heap, text, t, constant); + case am_enable_trace: + return dmc_enable_trace(context, heap, text, t, constant); + case am_disable_trace: + return dmc_disable_trace(context, heap, text, t, constant); + case am_trace: + return dmc_trace(context, heap, text, t, constant); + case am_caller: + return dmc_caller(context, heap, text, t, constant); + case am_silent: + return dmc_silent(context, heap, text, t, constant); + case am_set_tcw: + if (context->cflags & DCOMP_FAKE_DESTRUCTIVE) { + b = dmc_lookup_bif(am_set_tcw_fake, ((int) a) - 1); + } else { + b = dmc_lookup_bif(p[1], ((int) a) - 1); + } + break; + default: + b = dmc_lookup_bif(p[1], ((int) a) - 1); + } + + + if (b == NULL) { + if (context->err_info != NULL) { + /* Ugly, should define a better RETURN_TERM_ERROR interface... */ + char buff[100]; + sprintf(buff, "Function %%T/%d does_not_exist.", (int)a - 1); + RETURN_TERM_ERROR(buff, p[1], context, *constant); + } else { + return retFail; + } + } + ASSERT(b->arity == ((int) a) - 1); + if (! (b->flags & + (1 << + ((context->cflags & DCOMP_DIALECT_MASK) + + (context->is_guard ? DBIF_GUARD : DBIF_BODY))))) { + /* Body clause used in wrong context. */ + if (context->err_info != NULL) { + /* Ugly, should define a better RETURN_TERM_ERROR interface... */ + char buff[100]; + sprintf(buff, + "Function %%T/%d cannot be called in this context.", + (int)a - 1); + RETURN_TERM_ERROR(buff, p[1], context, *constant); + } else { + return retFail; + } + } + + *constant = 0; + + for (i = a; i > 1; --i) { + if ((ret = dmc_expr(context, heap, text, p[i], &c)) != retOk) + return ret; + if (c) + do_emit_constant(context, text, p[i]); + } + switch (b->arity) { + case 0: + DMC_PUSH(*text, matchCall0); + break; + case 1: + DMC_PUSH(*text, matchCall1); + break; + case 2: + DMC_PUSH(*text, matchCall2); + break; + case 3: + DMC_PUSH(*text, matchCall3); + break; + default: + erl_exit(1,"ets:match() internal error, " + "guard with more than 3 arguments."); + } + DMC_PUSH(*text, (Uint) b->biff); + context->stack_used -= (((int) a) - 2); + if (context->stack_used > context->stack_need) + context->stack_need = context->stack_used; + return retOk; +} + +static DMCRet dmc_expr(DMCContext *context, + DMCHeap *heap, + DMC_STACK_TYPE(Uint) *text, + Eterm t, + int *constant) +{ + DMCRet ret; + Eterm tmp; + Eterm *p; + + + switch (t & _TAG_PRIMARY_MASK) { + case TAG_PRIMARY_LIST: + if ((ret = dmc_list(context, heap, text, t, constant)) != retOk) + return ret; + break; + case TAG_PRIMARY_BOXED: + if (!BOXED_IS_TUPLE(t)) { + goto simple_term; + } + p = tuple_val(t); +#ifdef HARDDEBUG + erts_fprintf(stderr,"%d %d %d %d\n",arityval(*p),is_tuple(tmp = p[1]), + is_atom(p[1]),db_is_variable(p[1])); +#endif + if (arityval(*p) == 1 && is_tuple(tmp = p[1])) { + if ((ret = dmc_tuple(context, heap, text, tmp, constant)) != retOk) + return ret; + } else if (arityval(*p) >= 1 && is_atom(p[1]) && + !(db_is_variable(p[1]) >= 0)) { + if ((ret = dmc_fun(context, heap, text, t, constant)) != retOk) + return ret; + } else + RETURN_TERM_ERROR("%T is neither a function call, nor a tuple " + "(tuples are written {{ ... }}).", t, + context, *constant); + break; + case TAG_PRIMARY_IMMED1: + if (db_is_variable(t) >= 0) { + if ((ret = dmc_variable(context, heap, text, t, constant)) + != retOk) + return ret; + break; + } else if (t == am_DollarUnderscore) { + if ((ret = dmc_whole_expression(context, heap, text, t, constant)) + != retOk) + return ret; + break; + } else if (t == am_DollarDollar) { + if ((ret = dmc_all_bindings(context, heap, text, t, constant)) + != retOk) + return ret; + break; + } + /* Fall through */ + default: + simple_term: + *constant = 1; + } + return retOk; +} + + +static DMCRet compile_guard_expr(DMCContext *context, + DMCHeap *heap, + DMC_STACK_TYPE(Uint) *text, + Eterm l) +{ + DMCRet ret; + int constant; + Eterm t; + + if (l != NIL) { + if (!is_list(l)) + RETURN_ERROR("Match expression is not a list.", + context, constant); + if (!(context->is_guard)) { + DMC_PUSH(*text, matchCatch); + } + while (is_list(l)) { + constant = 0; + t = CAR(list_val(l)); + if ((ret = dmc_expr(context, heap, text, t, &constant)) != + retOk) + return ret; + if (constant) { + do_emit_constant(context, text, t); + } + l = CDR(list_val(l)); + if (context->is_guard) { + DMC_PUSH(*text,matchTrue); + } else { + DMC_PUSH(*text,matchWaste); + } + --context->stack_used; + } + if (l != NIL) + RETURN_ERROR("Match expression is not a proper list.", + context, constant); + if (!(context->is_guard) && (context->cflags & DCOMP_TABLE)) { + ASSERT(matchWaste == DMC_TOP(*text)); + (void) DMC_POP(*text); + DMC_PUSH(*text, matchReturn); /* Same impact on stack as + matchWaste */ + } + } + return retOk; +} + + + + +/* +** Match compilation utility code +*/ + +/* +** Handling of bif's in match guard expressions +*/ + +static DMCGuardBif *dmc_lookup_bif(Eterm t, int arity) +{ + /* + ** Place for optimization, bsearch is slower than inlining it... + */ + DMCGuardBif node = {0,NULL,0}; + node.name = t; + node.arity = arity; + return bsearch(&node, + guard_tab, + sizeof(guard_tab) / sizeof(DMCGuardBif), + sizeof(DMCGuardBif), + (int (*)(const void *, const void *)) &cmp_guard_bif); +} + +#ifdef DMC_DEBUG +static Eterm dmc_lookup_bif_reversed(void *f) +{ + int i; + for (i = 0; i < (sizeof(guard_tab) / sizeof(DMCGuardBif)); ++i) + if (f == guard_tab[i].biff) + return guard_tab[i].name; + return am_undefined; +} +#endif + +/* For sorting. */ +static int cmp_uint(void *a, void *b) +{ + if (*((unsigned *)a) < *((unsigned *)b)) + return -1; + else + return (*((unsigned *)a) > *((unsigned *)b)); +} + +static int cmp_guard_bif(void *a, void *b) +{ + int ret; + if (( ret = ((int) atom_val(((DMCGuardBif *) a)->name)) - + ((int) atom_val(((DMCGuardBif *) b)->name)) ) == 0) { + ret = ((DMCGuardBif *) a)->arity - ((DMCGuardBif *) b)->arity; + } + return ret; +} + +/* +** Compact the variables in a match expression i e make {$1, $100, $1000} +** become {$0,$1,$2}. +*/ +static int match_compact(ErlHeapFragment *expr, DMCErrInfo *err_info) +{ + int i, j, a, n, x; + DMC_STACK_TYPE(unsigned) heap; + Eterm *p; + char buff[25] = "$"; /* large enough for 64 bit to */ + int ret; + + DMC_INIT_STACK(heap); + + p = expr->mem; + i = expr->size; + while (i--) { + if (is_thing(*p)) { + a = thing_arityval(*p); + ASSERT(a <= i); + i -= a; + p += a; + } else if (is_atom(*p) && (n = db_is_variable(*p)) >= 0) { + x = DMC_STACK_NUM(heap); + for (j = 0; j < x && DMC_PEEK(heap,j) != n; ++j) + ; + + if (j == x) + DMC_PUSH(heap,n); + } + ++p; + } + qsort(DMC_STACK_DATA(heap), DMC_STACK_NUM(heap), sizeof(unsigned), + (int (*)(const void *, const void *)) &cmp_uint); + + if (err_info != NULL) { /* lint needs a translation table */ + err_info->var_trans = erts_alloc(ERTS_ALC_T_DB_TRANS_TAB, + sizeof(unsigned)*DMC_STACK_NUM(heap)); + sys_memcpy(err_info->var_trans, DMC_STACK_DATA(heap), + DMC_STACK_NUM(heap) * sizeof(unsigned)); + err_info->num_trans = DMC_STACK_NUM(heap); + } + + p = expr->mem; + i = expr->size; + while (i--) { + if (is_thing(*p)) { + a = thing_arityval(*p); + i -= a; + p += a; + } else if (is_atom(*p) && (n = db_is_variable(*p)) >= 0) { + x = DMC_STACK_NUM(heap); +#ifdef HARDDEBUG + erts_fprintf(stderr, "%T"); +#endif + for (j = 0; j < x && DMC_PEEK(heap,j) != n; ++j) + ; + ASSERT(j < x); + sprintf(buff+1,"%u", (unsigned) j); + /* Yes, writing directly into terms, they ARE off heap */ + *p = am_atom_put(buff, strlen(buff)); + } + ++p; + } + ret = DMC_STACK_NUM(heap); + DMC_FREE(heap); + return ret; +} + +/* +** Simple size object that takes care of function calls and constant tuples +*/ +static Uint my_size_object(Eterm t) +{ + Uint sum = 0; + Eterm tmp; + Eterm *p; + switch (t & _TAG_PRIMARY_MASK) { + case TAG_PRIMARY_LIST: + sum += 2 + my_size_object(CAR(list_val(t))) + + my_size_object(CDR(list_val(t))); + break; + case TAG_PRIMARY_BOXED: + if ((((*boxed_val(t)) & + _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE) != + (_TAG_HEADER_ARITYVAL >> _TAG_PRIMARY_SIZE)) { + goto simple_term; + } + + if (arityval(*tuple_val(t)) == 1 && is_tuple(tmp = tuple_val(t)[1])) { + Uint i,n; + p = tuple_val(tmp); + n = arityval(p[0]); + sum += 1 + n; + for (i = 1; i <= n; ++i) + sum += my_size_object(p[i]); + } else if (arityval(*tuple_val(t)) == 2 && + is_atom(tmp = tuple_val(t)[1]) && + tmp == am_const) { + sum += size_object(tuple_val(t)[2]); + } else { + erl_exit(1,"Internal error, sizing unrecognized object in " + "(d)ets:match compilation."); + } + break; + default: + simple_term: + sum += size_object(t); + break; + } + return sum; +} + +static Eterm my_copy_struct(Eterm t, Eterm **hp, ErlOffHeap* off_heap) +{ + Eterm ret = NIL, a, b; + Eterm *p; + Uint sz; + switch (t & _TAG_PRIMARY_MASK) { + case TAG_PRIMARY_LIST: + a = my_copy_struct(CAR(list_val(t)), hp, off_heap); + b = my_copy_struct(CDR(list_val(t)), hp, off_heap); + ret = CONS(*hp, a, b); + *hp += 2; + break; + case TAG_PRIMARY_BOXED: + if (BOXED_IS_TUPLE(t)) { + if (arityval(*tuple_val(t)) == 1 && + is_tuple(a = tuple_val(t)[1])) { + Uint i,n; + Eterm *savep = *hp; + ret = make_tuple(savep); + p = tuple_val(a); + n = arityval(p[0]); + *hp += n + 1; + *savep++ = make_arityval(n); + for(i = 1; i <= n; ++i) + *savep++ = my_copy_struct(p[i], hp, off_heap); + } else if (arityval(*tuple_val(t)) == 2 && + is_atom(a = tuple_val(t)[1]) && + a == am_const) { + /* A {const, XXX} expression */ + b = tuple_val(t)[2]; + sz = size_object(b); + ret = copy_struct(b,sz,hp,off_heap); + } else { + erl_exit(1, "Trying to constant-copy non constant expression " + "0x%08x in (d)ets:match compilation.", (unsigned long) t); + } + } else { + sz = size_object(t); + ret = copy_struct(t,sz,hp,off_heap); + } + break; + default: + ret = t; + } + return ret; +} + +/* +** Compiled match bif interface +*/ +/* +** erlang:match_spec_test(MatchAgainst, MatchSpec, Type) -> +** {ok, Return, Flags, Errors} | {error, Errors} +** MatchAgainst -> if Type == trace: list() else tuple() +** MatchSpec -> MatchSpec with body corresponding to Type +** Type -> trace | table (only trace implemented in R5C) +** Return -> if Type == trace TraceReturn else {BodyReturn, VariableBindings} +** TraceReturn -> {true | false | term()} +** BodyReturn -> term() +** VariableBindings -> [term(), ...] +** Errors -> [OneError, ...] +** OneError -> {error, string()} | {warning, string()} +** Flags -> [Flag, ...] +** Flag -> return_trace (currently only flag) +*/ +BIF_RETTYPE match_spec_test_3(BIF_ALIST_3) +{ + Eterm res; +#ifdef DMC_DEBUG + if (BIF_ARG_3 == am_atom_put("dis",3)) { + test_disassemble_next = 1; + BIF_RET(am_true); + } else +#endif + if (BIF_ARG_3 == am_trace) { + res = match_spec_test(BIF_P, BIF_ARG_1, BIF_ARG_2, 1); + if (is_value(res)) { + BIF_RET(res); + } + } else if (BIF_ARG_3 == am_table) { + res = match_spec_test(BIF_P, BIF_ARG_1, BIF_ARG_2, 0); + if (is_value(res)) { + BIF_RET(res); + } + } + BIF_ERROR(BIF_P, BADARG); +} + +static Eterm match_spec_test(Process *p, Eterm against, Eterm spec, int trace) +{ + Eterm lint_res; + Binary *mps; + Eterm res; + Eterm ret; + Eterm flg; + Eterm *hp; + Eterm *arr; + int n; + Eterm l; + Uint32 ret_flags; + Uint sz; + Eterm *save_cp; + + if (trace && !(is_list(against) || against == NIL)) { + return THE_NON_VALUE; + } + if (trace) { + lint_res = db_match_set_lint(p, spec, DCOMP_TRACE | DCOMP_FAKE_DESTRUCTIVE); + mps = db_match_set_compile(p, spec, DCOMP_TRACE | DCOMP_FAKE_DESTRUCTIVE); + } else { + lint_res = db_match_set_lint(p, spec, DCOMP_TABLE | DCOMP_FAKE_DESTRUCTIVE); + mps = db_match_set_compile(p, spec, DCOMP_TABLE | DCOMP_FAKE_DESTRUCTIVE); + } + + if (mps == NULL) { + hp = HAlloc(p,3); + ret = TUPLE2(hp, am_error, lint_res); + } else { +#ifdef DMC_DEBUG + if (test_disassemble_next) { + test_disassemble_next = 0; + db_match_dis(mps); + } +#endif /* DMC_DEBUG */ + l = against; + n = 0; + while (is_list(l)) { + ++n; + l = CDR(list_val(l)); + } + if (trace) { + if (n) + arr = erts_alloc(ERTS_ALC_T_DB_TMP, sizeof(Eterm) * n); + else + arr = NULL; + l = against; + n = 0; + while (is_list(l)) { + arr[n] = CAR(list_val(l)); + ++n; + l = CDR(list_val(l)); + } + } else { + n = 0; + arr = (Eterm *) against; + } + + /* We are in the context of a BIF, + {caller} should return 'undefined' */ + save_cp = p->cp; + p->cp = NULL; + res = erts_match_set_run(p, mps, arr, n, &ret_flags); + p->cp = save_cp; + if (is_non_value(res)) { + res = am_false; + } + sz = size_object(res); + if (ret_flags & MATCH_SET_EXCEPTION_TRACE) sz += 2; + if (ret_flags & MATCH_SET_RETURN_TRACE) sz += 2; + hp = HAlloc(p, 5 + sz); + res = copy_struct(res, sz, &hp, &MSO(p)); + flg = NIL; + if (ret_flags & MATCH_SET_EXCEPTION_TRACE) { + flg = CONS(hp, am_exception_trace, flg); + hp += 2; + } + if (ret_flags & MATCH_SET_RETURN_TRACE) { + flg = CONS(hp, am_return_trace, flg); + hp += 2; + } + if (trace && arr != NULL) { + erts_free(ERTS_ALC_T_DB_TMP, arr); + } + erts_bin_free(mps); + ret = TUPLE4(hp, am_atom_put("ok",2), res, flg, lint_res); + } + return ret; +} + +static Eterm seq_trace_fake(Process *p, Eterm arg1) +{ + Eterm result = seq_trace_info_1(p,arg1); + if (is_tuple(result) && *tuple_val(result) == 2) { + return (tuple_val(result))[2]; + } + return result; +} + +#ifdef DMC_DEBUG +/* +** Disassemble match program +*/ +static void db_match_dis(Binary *bp) +{ + MatchProg *prog = Binary2MatchProg(bp); + Uint *t = prog->text; + Uint n; + Eterm p; + int first; + ErlHeapFragment *tmp; + + while (t < prog->prog_end) { + switch (*t) { + case matchTryMeElse: + ++t; + n = *t; + ++t; + erts_printf("TryMeElse\t%bpu\n", n); + break; + case matchArray: + ++t; + n = *t; + ++t; + erts_printf("Array\t%bpu\n", n); + break; + case matchArrayBind: + ++t; + n = *t; + ++t; + erts_printf("ArrayBind\t%bpu\n", n); + break; + case matchTuple: + ++t; + n = *t; + ++t; + erts_printf("Tuple\t%bpu\n", n); + break; + case matchPushT: + ++t; + n = *t; + ++t; + erts_printf("PushT\t%bpu\n", n); + break; + case matchPushL: + ++t; + erts_printf("PushL\n"); + break; + case matchPop: + ++t; + erts_printf("Pop\n"); + break; + case matchBind: + ++t; + n = *t; + ++t; + erts_printf("Bind\t%bpu\n", n); + break; + case matchCmp: + ++t; + n = *t; + ++t; + erts_printf("Cmp\t%bpu\n", n); + break; + case matchEqBin: + ++t; + p = (Eterm) *t; + ++t; + erts_printf("EqBin\t%p (%T)\n", t, p); + break; + case matchEqRef: + ++t; + n = thing_arityval(*t); + ++t; + erts_printf("EqRef\t(%d) {", (int) n); + first = 1; + while (n--) { + if (first) + first = 0; + else + erts_printf(", "); +#ifdef ARCH_64 + erts_printf("0x%016bpx", *t); +#else + erts_printf("0x%08bpx", *t); +#endif + ++t; + } + erts_printf("}\n"); + break; + case matchEqBig: + ++t; + n = thing_arityval(*t); + ++t; + erts_printf("EqBig\t(%d) {", (int) n); + first = 1; + while (n--) { + if (first) + first = 0; + else + erts_printf(", "); +#ifdef ARCH_64 + erts_printf("0x%016bpx", *t); +#else + erts_printf("0x%08bpx", *t); +#endif + ++t; + } + erts_printf("}\n"); + break; + case matchEqFloat: + ++t; + { + double num; + memcpy(&num,t, 2 * sizeof(*t)); + t += 2; + erts_printf("EqFloat\t%f\n", num); + } + break; + case matchEq: + ++t; + p = (Eterm) *t; + ++t; + erts_printf("Eq \t%T\n", p); + break; + case matchList: + ++t; + erts_printf("List\n"); + break; + case matchHalt: + ++t; + erts_printf("Halt\n"); + break; + case matchSkip: + ++t; + erts_printf("Skip\n"); + break; + case matchPushC: + ++t; + p = (Eterm) *t; + ++t; + erts_printf("PushC\t%T\n", p); + break; + case matchConsA: + ++t; + erts_printf("ConsA\n"); + break; + case matchConsB: + ++t; + erts_printf("ConsB\n"); + break; + case matchMkTuple: + ++t; + n = *t; + ++t; + erts_printf("MkTuple\t%bpu\n", n); + break; + case matchOr: + ++t; + n = *t; + ++t; + erts_printf("Or\t%bpu\n", n); + break; + case matchAnd: + ++t; + n = *t; + ++t; + erts_printf("And\t%bpu\n", n); + break; + case matchOrElse: + ++t; + n = *t; + ++t; + erts_printf("OrElse\t%bpu\n", n); + break; + case matchAndAlso: + ++t; + n = *t; + ++t; + erts_printf("AndAlso\t%bpu\n", n); + break; + case matchCall0: + ++t; + p = dmc_lookup_bif_reversed((void *) *t); + ++t; + erts_printf("Call0\t%T\n", p); + break; + case matchCall1: + ++t; + p = dmc_lookup_bif_reversed((void *) *t); + ++t; + erts_printf("Call1\t%T\n", p); + break; + case matchCall2: + ++t; + p = dmc_lookup_bif_reversed((void *) *t); + ++t; + erts_printf("Call2\t%T\n", p); + break; + case matchCall3: + ++t; + p = dmc_lookup_bif_reversed((void *) *t); + ++t; + erts_printf("Call3\t%T\n", p); + break; + case matchPushV: + ++t; + n = (Uint) *t; + ++t; + erts_printf("PushV\t%bpu\n", n); + break; + case matchTrue: + ++t; + erts_printf("True\n"); + break; + case matchPushExpr: + ++t; + erts_printf("PushExpr\n"); + break; + case matchPushArrayAsList: + ++t; + erts_printf("PushArrayAsList\n"); + break; + case matchPushArrayAsListU: + ++t; + erts_printf("PushArrayAsListU\n"); + break; + case matchSelf: + ++t; + erts_printf("Self\n"); + break; + case matchWaste: + ++t; + erts_printf("Waste\n"); + break; + case matchReturn: + ++t; + erts_printf("Return\n"); + break; + case matchProcessDump: + ++t; + erts_printf("ProcessDump\n"); + break; + case matchDisplay: + ++t; + erts_printf("Display\n"); + break; + case matchIsSeqTrace: + ++t; + erts_printf("IsSeqTrace\n"); + break; + case matchSetSeqToken: + ++t; + erts_printf("SetSeqToken\n"); + break; + case matchSetSeqTokenFake: + ++t; + erts_printf("SetSeqTokenFake\n"); + break; + case matchGetSeqToken: + ++t; + erts_printf("GetSeqToken\n"); + break; + case matchSetReturnTrace: + ++t; + erts_printf("SetReturnTrace\n"); + break; + case matchSetExceptionTrace: + ++t; + erts_printf("SetReturnTrace\n"); + break; + case matchCatch: + ++t; + erts_printf("Catch\n"); + break; + case matchEnableTrace: + ++t; + erts_printf("EnableTrace\n"); + break; + case matchDisableTrace: + ++t; + erts_printf("DisableTrace\n"); + break; + case matchEnableTrace2: + ++t; + erts_printf("EnableTrace2\n"); + break; + case matchDisableTrace2: + ++t; + erts_printf("DisableTrace2\n"); + break; + case matchTrace2: + ++t; + erts_printf("Trace2\n"); + break; + case matchTrace3: + ++t; + erts_printf("Trace3\n"); + break; + case matchCaller: + ++t; + erts_printf("Caller\n"); + break; + default: + erts_printf("??? (0x%08x)\n", *t); + ++t; + break; + } + } + erts_printf("\n\nterm_save: {"); + first = 1; + for (tmp = prog->term_save; tmp; tmp = tmp->next) { + if (first) + first = 0; + else + erts_printf(", "); + erts_printf("0x%08x", (unsigned long) tmp); + } + erts_printf("}\n"); + erts_printf("num_bindings: %d\n", prog->num_bindings); + erts_printf("heap_size: %bpu\n", prog->heap_size); + erts_printf("eheap_offset: %bpu\n", prog->eheap_offset); + erts_printf("stack_offset: %bpu\n", prog->stack_offset); + erts_printf("text: 0x%08x\n", (unsigned long) prog->text); + erts_printf("stack_size: %d (words)\n", prog->heap_size-prog->stack_offset); + +} + +#endif /* DMC_DEBUG */ + + diff --git a/erts/emulator/beam/erl_db_util.h b/erts/emulator/beam/erl_db_util.h new file mode 100644 index 0000000000..4fc7b4f52e --- /dev/null +++ b/erts/emulator/beam/erl_db_util.h @@ -0,0 +1,405 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1998-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifndef _DB_UTIL_H +#define _DB_UTIL_H + +#include "global.h" +#include "erl_message.h" + +/*#define HARDDEBUG 1*/ + +#ifdef DEBUG +/* +** DMC_DEBUG does NOT need DEBUG, but DEBUG needs DMC_DEBUG +*/ +#define DMC_DEBUG 1 +#endif + +/* + * These values can be returned from the functions performing the + * BIF operation for different types of tables. When the + * actual operations have been performed, the BIF function + * checks for negative returns and issues BIF_ERRORS based + * upon these values. + */ +#define DB_ERROR_NONE 0 /* No error */ +#define DB_ERROR_BADITEM -1 /* The item was malformed ie no + tuple or to small*/ +#define DB_ERROR_BADTABLE -2 /* The Table is inconsisitent */ +#define DB_ERROR_SYSRES -3 /* Out of system resources */ +#define DB_ERROR_BADKEY -4 /* Returned if a key that should + exist does not. */ +#define DB_ERROR_BADPARAM -5 /* Returned if a specified slot does + not exist (hash table only) or + the state parameter in db_match_object + is broken.*/ +#define DB_ERROR_UNSPEC -10 /* Unspecified error */ + + +/* + * A datatype for a database entry stored out of a process heap + */ +typedef struct db_term { + ErlOffHeap off_heap; /* Off heap data for term. */ + Uint size; /* Size of term in "words" */ + Eterm tpl[1]; /* Untagged "constant pointer" to top tuple */ + /* (assumed to be first in buffer) */ +} DbTerm; + +/* "Assign" a value to DbTerm.tpl */ +#define DBTERM_SET_TPL(dbtermPtr,tplPtr) ASSERT((tplPtr)==(dbtermPtr->tpl)) +/* Get start of term buffer */ +#define DBTERM_BUF(dbtermPtr) ((dbtermPtr)->tpl) + +union db_table; +typedef union db_table DbTable; + +/* Info about a database entry while it's being updated + * (by update_counter or update_element) + */ +typedef struct { + DbTable* tb; + DbTerm* dbterm; + void** bp; /* {Hash|Tree}DbTerm** */ + Uint new_size; + int mustResize; + void* lck; +} DbUpdateHandle; + + +typedef struct db_table_method +{ + int (*db_create)(Process *p, DbTable* tb); + int (*db_first)(Process* p, + DbTable* tb, /* [in out] */ + Eterm* ret /* [out] */); + int (*db_next)(Process* p, + DbTable* tb, /* [in out] */ + Eterm key, /* [in] */ + Eterm* ret /* [out] */); + int (*db_last)(Process* p, + DbTable* tb, /* [in out] */ + Eterm* ret /* [out] */); + int (*db_prev)(Process* p, + DbTable* tb, /* [in out] */ + Eterm key, + Eterm* ret); + int (*db_put)(DbTable* tb, /* [in out] */ + Eterm obj, + int key_clash_fail); /* DB_ERROR_BADKEY if key exists */ + int (*db_get)(Process* p, + DbTable* tb, /* [in out] */ + Eterm key, + Eterm* ret); + int (*db_get_element)(Process* p, + DbTable* tb, /* [in out] */ + Eterm key, + int index, + Eterm* ret); + int (*db_member)(DbTable* tb, /* [in out] */ + Eterm key, + Eterm* ret); + int (*db_erase)(DbTable* tb, /* [in out] */ + Eterm key, + Eterm* ret); + int (*db_erase_object)(DbTable* tb, /* [in out] */ + Eterm obj, + Eterm* ret); + int (*db_slot)(Process* p, + DbTable* tb, /* [in out] */ + Eterm slot, + Eterm* ret); + int (*db_select_chunk)(Process* p, + DbTable* tb, /* [in out] */ + Eterm pattern, + Sint chunk_size, + int reverse, + Eterm* ret); + int (*db_select)(Process* p, + DbTable* tb, /* [in out] */ + Eterm pattern, + int reverse, + Eterm* ret); + int (*db_select_delete)(Process* p, + DbTable* tb, /* [in out] */ + Eterm pattern, + Eterm* ret); + int (*db_select_continue)(Process* p, + DbTable* tb, /* [in out] */ + Eterm continuation, + Eterm* ret); + int (*db_select_delete_continue)(Process* p, + DbTable* tb, /* [in out] */ + Eterm continuation, + Eterm* ret); + int (*db_select_count)(Process* p, + DbTable* tb, /* [in out] */ + Eterm pattern, + Eterm* ret); + int (*db_select_count_continue)(Process* p, + DbTable* tb, /* [in out] */ + Eterm continuation, + Eterm* ret); + + int (*db_delete_all_objects)(Process* p, + DbTable* db /* [in out] */ ); + + int (*db_free_table)(DbTable* db /* [in out] */ ); + int (*db_free_table_continue)(DbTable* db); /* [in out] */ + + void (*db_print)(int to, + void* to_arg, + int show, + DbTable* tb /* [in out] */ ); + + void (*db_foreach_offheap)(DbTable* db, /* [in out] */ + void (*func)(ErlOffHeap *, void *), + void *arg); + void (*db_check_table)(DbTable* tb); + + /* Lookup a dbterm for updating. Return false if not found. + */ + int (*db_lookup_dbterm)(DbTable*, Eterm key, + DbUpdateHandle* handle); /* [out] */ + + /* Must be called for each db_lookup_dbterm that returned true, + ** even if dbterm was not updated. + */ + void (*db_finalize_dbterm)(DbUpdateHandle* handle); + +} DbTableMethod; + +/* + * This structure contains data for all different types of database + * tables. Note that these fields must match the same fields + * in the table-type specific structures. + * The reason it is placed here and not in db.h is that some table + * operations may be the same on different types of tables. + */ + +typedef struct db_fixation { + Eterm pid; + Uint counter; + struct db_fixation *next; +} DbFixation; + + +typedef struct db_table_common { + erts_refc_t ref; + erts_refc_t fixref; /* fixation counter */ +#ifdef ERTS_SMP + erts_smp_rwmtx_t rwlock; /* rw lock on table */ + erts_smp_mtx_t fixlock; /* Protects fixations,megasec,sec,microsec */ + int is_thread_safe; /* No fine locking inside table needed */ + Uint32 type; /* table type, *read only* after creation */ +#endif + Eterm owner; /* Pid of the creator */ + Eterm heir; /* Pid of the heir */ + Eterm heir_data; /* To send in ETS-TRANSFER (is_immed or (DbTerm*) */ + SysTimeval heir_started; /* To further identify the heir */ + Eterm the_name; /* an atom */ + Eterm id; /* atom | integer */ + DbTableMethod* meth; /* table methods */ + erts_smp_atomic_t nitems; /* Total number of items in table */ + erts_smp_atomic_t memory_size;/* Total memory size. NOTE: in bytes! */ + Uint megasec,sec,microsec; /* Last fixation time */ + DbFixation* fixations; /* List of processes who have done safe_fixtable, + "local" fixations not included. */ + /* All 32-bit fields */ + Uint32 status; /* bit masks defined below */ + int slot; /* slot index in meta_main_tab */ + int keypos; /* defaults to 1 */ +} DbTableCommon; + +/* These are status bit patterns */ +#define DB_NORMAL (1 << 0) +#define DB_PRIVATE (1 << 1) +#define DB_PROTECTED (1 << 2) +#define DB_PUBLIC (1 << 3) +#define DB_BAG (1 << 4) +#define DB_SET (1 << 5) +/*#define DB_LHASH (1 << 6)*/ +#define DB_FINE_LOCKED (1 << 7) /* fine grained locking enabled */ +#define DB_DUPLICATE_BAG (1 << 8) +#define DB_ORDERED_SET (1 << 9) +#define DB_DELETE (1 << 10) /* table is being deleted */ + +#define ERTS_ETS_TABLE_TYPES (DB_BAG|DB_SET|DB_DUPLICATE_BAG|DB_ORDERED_SET|DB_FINE_LOCKED) + +#define IS_HASH_TABLE(Status) (!!((Status) & \ + (DB_BAG | DB_SET | DB_DUPLICATE_BAG))) +#define IS_TREE_TABLE(Status) (!!((Status) & \ + DB_ORDERED_SET)) +#define NFIXED(T) (erts_refc_read(&(T)->common.fixref,0)) +#define IS_FIXED(T) (NFIXED(T) != 0) + +Eterm erts_ets_copy_object(Eterm, Process*); + +/* optimised version of copy_object (normal case? atomic object) */ +#define COPY_OBJECT(obj, p, objp) \ + if (IS_CONST(obj)) { *(objp) = (obj); } \ + else { *objp = erts_ets_copy_object(obj, p); } + +#define DB_READ (DB_PROTECTED|DB_PUBLIC) +#define DB_WRITE DB_PUBLIC +#define DB_INFO (DB_PROTECTED|DB_PUBLIC|DB_PRIVATE) + +/* tb is an DbTableCommon and obj is an Eterm (tagged) */ +#define TERM_GETKEY(tb, obj) db_getkey((tb)->common.keypos, (obj)) + +#define ONLY_WRITER(P,T) (((T)->common.status & (DB_PRIVATE|DB_PROTECTED)) \ + && (T)->common.owner == (P)->id) + +#define ONLY_READER(P,T) (((T)->common.status & DB_PRIVATE) && \ +(T)->common.owner == (P)->id) + +/* Function prototypes */ +Eterm db_get_trace_control_word_0(Process *p); +Eterm db_set_trace_control_word_1(Process *p, Eterm val); + +void db_initialize_util(void); +Eterm db_getkey(int keypos, Eterm obj); +void db_free_term_data(DbTerm* p); +void* db_get_term(DbTableCommon *tb, DbTerm* old, Uint offset, Eterm obj); +int db_has_variable(Eterm obj); +int db_is_variable(Eterm obj); +void db_do_update_element(DbUpdateHandle* handle, + Sint position, + Eterm newval); +void db_finalize_update_element(DbUpdateHandle* handle); +Eterm db_add_counter(Eterm** hpp, Eterm counter, Eterm incr); +Eterm db_match_set_lint(Process *p, Eterm matchexpr, Uint flags); +Binary *db_match_set_compile(Process *p, Eterm matchexpr, + Uint flags); +void erts_db_match_prog_destructor(Binary *); + +typedef struct match_prog { + ErlHeapFragment *term_save; /* Only if needed, a list of message + buffers for off heap copies + (i.e. binaries)*/ + int single_variable; /* ets:match needs to know this. */ + int num_bindings; /* Size of heap */ + /* The following two are only filled in when match specs + are used for tracing */ + struct erl_heap_fragment *saved_program_buf; + Eterm saved_program; + Uint heap_size; /* size of: heap + eheap + stack */ + Uint eheap_offset; + Uint stack_offset; +#ifdef DMC_DEBUG + Uint* prog_end; /* End of program */ +#endif + Uint text[1]; /* Beginning of program */ +} MatchProg; + +/* + * The heap-eheap-stack block of a MatchProg is nowadays allocated + * when the match program is run. + * - heap: variable bindings + * - eheap: erlang heap storage + * - eheap: a "large enough" stack + */ + +#define DMC_ERR_STR_LEN 100 + +typedef enum { dmcWarning, dmcError} DMCErrorSeverity; + +typedef struct dmc_error { + char error_string[DMC_ERR_STR_LEN + 1]; /* printf format string + with %d for the variable + number (if applicable) */ + int variable; /* -1 if no variable is referenced + in error string */ + struct dmc_error *next; + DMCErrorSeverity severity; /* Error or warning */ +} DMCError; + +typedef struct dmc_err_info { + unsigned int *var_trans; /* Translations of variable names, + initiated to NULL + and free'd with sys_free if != NULL + after compilation */ + int num_trans; + int error_added; /* indicates if the error list contains + any fatal errors (dmcError severity) */ + DMCError *first; /* List of errors */ +} DMCErrInfo; + +/* +** Compilation flags +** +** The dialect is in the 3 least significant bits and are to be interspaced by +** by at least 2 (decimal), thats why ((Uint) 2) isn't used. This is to be +** able to add DBIF_GUARD or DBIF BODY to it to use in the match_spec bif +** table. The rest of the word is used like ordinary flags, one bit for each +** flag. Note that DCOMP_TABLE and DCOMP_TRACE are mutually exclusive. +*/ +#define DCOMP_TABLE ((Uint) 1) /* Ets and dets. The body returns a value, + * and the parameter to the execution is a tuple. */ +#define DCOMP_TRACE ((Uint) 4) /* Trace. More functions are allowed, and the + * parameter to the execution will be an array. */ +#define DCOMP_DIALECT_MASK ((Uint) 0x7) /* To mask out the bits marking + dialect */ +#define DCOMP_FAKE_DESTRUCTIVE ((Uint) 8) /* When this is active, no setting of + trace control words or seq_trace tokens will be done. */ + + +Binary *db_match_compile(Eterm *matchexpr, Eterm *guards, + Eterm *body, int num_matches, + Uint flags, + DMCErrInfo *err_info); +/* Returns newly allocated MatchProg binary with refc == 0*/ +Eterm db_prog_match(Process *p, Binary *prog, Eterm term, int arity, + Uint32 *return_flags /* Zeroed on enter */); +/* returns DB_ERROR_NONE if matches, 1 if not matches and some db error on + error. */ +DMCErrInfo *db_new_dmc_err_info(void); +/* Returns allocated error info, where errors are collected for lint. */ +Eterm db_format_dmc_err_info(Process *p, DMCErrInfo *ei); +/* Formats an error info structure into a list of tuples. */ +void db_free_dmc_err_info(DMCErrInfo *ei); +/* Completely free's an error info structure, including all recorded + errors */ +Eterm db_make_mp_binary(Process *p, Binary *mp, Eterm **hpp); +/* Convert a match program to a erlang "magic" binary to be returned to userspace, + increments the reference counter. */ +int erts_db_is_compiled_ms(Eterm term); + +/* +** Convenience when compiling into Binary structures +*/ +#define IsMatchProgBinary(BP) \ + (((BP)->flags & BIN_FLAG_MAGIC) \ + && ERTS_MAGIC_BIN_DESTRUCTOR((BP)) == erts_db_match_prog_destructor) + +#define Binary2MatchProg(BP) \ + (ASSERT_EXPR(IsMatchProgBinary((BP))), \ + ((MatchProg *) ERTS_MAGIC_BIN_DATA((BP)))) +/* +** Debugging +*/ +#ifdef HARDDEBUG +void db_check_tables(void); /* in db.c */ +#define CHECK_TABLES() db_check_tables() +#else +#define CHECK_TABLES() +#endif + +#endif /* _DB_UTIL_H */ diff --git a/erts/emulator/beam/erl_debug.c b/erts/emulator/beam/erl_debug.c new file mode 100644 index 0000000000..34ce87bc5d --- /dev/null +++ b/erts/emulator/beam/erl_debug.c @@ -0,0 +1,899 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1998-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "erl_process.h" +#include "erl_nmgc.h" +#include "big.h" +#include "bif.h" +#include "beam_catches.h" +#include "erl_debug.h" + +#define WITHIN(ptr, x, y) ((x) <= (ptr) && (ptr) < (y)) + +#if defined(HYBRID) +#if defined(INCREMENTAL) +/* Hybrid + Incremental */ +#define IN_HEAP(p, ptr) \ + (WITHIN((ptr), p->heap, p->hend) || \ + (OLD_HEAP(p) && WITHIN((ptr), OLD_HEAP(p), OLD_HEND(p))) || \ + WITHIN((ptr), global_heap, global_hend) || \ + (inc_fromspc && WITHIN((ptr), inc_fromspc, inc_fromend)) || \ + WITHIN((ptr), global_old_heap, global_old_hend)) + +#define IN_MA(ptr) \ + (WITHIN((ptr), global_heap, global_hend) || \ + (inc_fromspc && WITHIN((ptr), inc_fromspc, inc_fromend)) || \ + WITHIN((ptr), global_old_heap, global_old_hend)) +#else +/* Hybrid */ +#define IN_HEAP(p, ptr) \ + (WITHIN((ptr), p->heap, p->hend) || \ + (OLD_HEAP(p) && WITHIN((ptr), OLD_HEAP(p), OLD_HEND(p))) || \ + WITHIN((ptr), global_heap, global_hend) || \ + (global_old_heap && WITHIN((ptr),global_old_heap,global_old_hend))) +#endif +#else +/* Private */ +#define IN_HEAP(p, ptr) \ + (WITHIN((ptr), p->heap, p->hend) || \ + (OLD_HEAP(p) && WITHIN((ptr), OLD_HEAP(p), OLD_HEND(p)))) +#endif + + +#ifdef __GNUC__ +/* + * Does not work in Microsoft C. Since this is debugging code that will + * hardly be used on Windows, get rid of it unless we have Gnu compiler. + */ +#define PTR_SIZE 2*(int)sizeof(long) + +static const char dashes[PTR_SIZE+3] = { + [0 ... PTR_SIZE+1] = '-' +}; +#endif + +#if defined(DEBUG) && defined(__GNUC__) + +/* + * This file defines functions for use within a debugger like gdb + * and the declarations below is just to make gcc quiet. + */ + +void pps(Process*, Eterm*); +void ptd(Process*, Eterm); +void paranoid_display(int, void*, Process*, Eterm); +static int dcount; + +static int pdisplay1(int to, void *to_arg, Process* p, Eterm obj); + +void ptd(Process* p, Eterm x) +{ + pdisplay1(ERTS_PRINT_STDERR, NULL, p, x); + erts_putc(ERTS_PRINT_STDERR, NULL, '\n'); +} + +/* + * Paranoid version of display which doesn't crasch as easily if there + * are errors in the data structures. + */ + +void +paranoid_display(int to, void *to_arg, Process* p, Eterm obj) +{ + dcount = 100000; + pdisplay1(to, to_arg, p, obj); +} + +static int +pdisplay1(int to, void *to_arg, Process* p, Eterm obj) +{ + int i, k; + Eterm* nobj; + + if (dcount-- <= 0) + return(1); + + if (is_CP(obj)) { + erts_print(to, to_arg, "#", obj); + return 1; + } + + i = BIG_SIZE(nobj); + if (BIG_SIGN(nobj)) + erts_print(to, to_arg, "-#integer(%d) = {", i); + else + erts_print(to, to_arg, "#integer(%d) = {", i); + erts_print(to, to_arg, "%d", BIG_DIGIT(nobj, 0)); + for (k = 1; k < i; k++) + erts_print(to, to_arg, ",%d", BIG_DIGIT(nobj, k)); + erts_putc(to, to_arg, '}'); + break; + case REF_DEF: + case EXTERNAL_REF_DEF: { + Uint32 *ref_num; + erts_print(to, to_arg, "#Ref<%lu", ref_channel_no(obj)); + ref_num = ref_numbers(obj); + for (i = ref_no_of_numbers(obj)-1; i >= 0; i--) + erts_print(to, to_arg, ",%lu", ref_num[i]); + erts_print(to, to_arg, ">"); + break; + } + case PID_DEF: + case EXTERNAL_PID_DEF: + erts_print(to, to_arg, "<%lu.%lu.%lu>", + pid_channel_no(obj), + pid_number(obj), + pid_serial(obj)); + break; + case PORT_DEF: + case EXTERNAL_PORT_DEF: + erts_print(to, to_arg, "#Port<%lu.%lu>", + port_channel_no(obj), + port_number(obj)); + break; + case LIST_DEF: + erts_putc(to, to_arg, '['); + nobj = list_val(obj); + while (1) { + if (!IN_HEAP(p, nobj)) { + erts_print(to, to_arg, "#", obj); + return 1; + } + if (pdisplay1(to, to_arg, p, *nobj++) != 0) + return(1); + if (is_not_list(*nobj)) + break; + erts_putc(to, to_arg, ','); + nobj = list_val(*nobj); + } + if (is_not_nil(*nobj)) { + erts_putc(to, to_arg, '|'); + if (pdisplay1(to, to_arg, p, *nobj) != 0) + return(1); + } + erts_putc(to, to_arg, ']'); + break; + case TUPLE_DEF: + nobj = tuple_val(obj); /* pointer to arity */ + i = arityval(*nobj); /* arity */ + erts_putc(to, to_arg, '{'); + while (i--) { + if (pdisplay1(to, to_arg, p, *++nobj) != 0) return(1); + if (i >= 1) erts_putc(to, to_arg, ','); + } + erts_putc(to, to_arg, '}'); + break; + case FLOAT_DEF: { + FloatDef ff; + GET_DOUBLE(obj, ff); +#ifdef _OSE_ + erts_print(to, to_arg, "%e", ff.fd); +#else + erts_print(to, to_arg, "%.20e", ff.fd); +#endif + } + break; + case BINARY_DEF: + erts_print(to, to_arg, "#Bin"); + break; + default: + erts_print(to, to_arg, "unknown object %x", obj); + } + return(0); +} + +void +pps(Process* p, Eterm* stop) +{ + int to = ERTS_PRINT_STDOUT; + void *to_arg = NULL; + Eterm* sp = STACK_START(p) - 1; + + if (stop <= STACK_END(p)) { + stop = STACK_END(p) + 1; + } + + while(sp >= stop) { + erts_print(to, to_arg, "%0*lx: ", PTR_SIZE, (Eterm) sp); + if (is_catch(*sp)) { + erts_print(to, to_arg, "catch %d", (Uint)catch_pc(*sp)); + } else { + paranoid_display(to, to_arg, p, *sp); + } + erts_putc(to, to_arg, '\n'); + sp--; + } +} + +#endif /* DEBUG */ + +static int verify_eterm(Process *p,Eterm element); +static int verify_eterm(Process *p,Eterm element) +{ + Eterm *ptr; + ErlHeapFragment* mbuf; + + switch (primary_tag(element)) { + case TAG_PRIMARY_LIST: ptr = list_val(element); break; + case TAG_PRIMARY_BOXED: ptr = boxed_val(element); break; + default: /* Immediate or header/cp */ return 1; + } + + if (p) { + if (IN_HEAP(p, ptr)) + return 1; + + for (mbuf = p->mbuf; mbuf; mbuf = mbuf->next) { + if (WITHIN(ptr, &mbuf->mem[0], &mbuf->mem[0] + mbuf->size)) { + return 1; + } + } + } +#ifdef INCREMENTAL + else { + if (IN_MA(ptr)) + return 1; + } +#endif + + return 0; +} + +void erts_check_stack(Process *p) +{ + Eterm *elemp; + Eterm *stack_start = p->heap + p->heap_sz; + Eterm *stack_end = p->htop; + + if (p->stop > stack_start) + erl_exit(1, + "<%lu.%lu.%lu>: Stack underflow\n", + internal_pid_channel_no(p->id), + internal_pid_number(p->id), + internal_pid_serial(p->id)); + + if (p->stop < stack_end) + erl_exit(1, + "<%lu.%lu.%lu>: Stack overflow\n", + internal_pid_channel_no(p->id), + internal_pid_number(p->id), + internal_pid_serial(p->id)); + + for (elemp = p->stop; elemp < stack_start; elemp++) { + int in_mbuf = 0; + Eterm *ptr; + ErlHeapFragment* mbuf; + switch (primary_tag(*elemp)) { + case TAG_PRIMARY_LIST: ptr = list_val(*elemp); break; + case TAG_PRIMARY_BOXED: ptr = boxed_val(*elemp); break; + default: /* Immediate or cp */ continue; + } + if (IN_HEAP(p, ptr)) + continue; + for (mbuf = p->mbuf; mbuf; mbuf = mbuf->next) + if (WITHIN(ptr, &mbuf->mem[0], &mbuf->mem[0] + mbuf->size)) { + in_mbuf = 1; + break; + } + if (in_mbuf) + continue; + + erl_exit(1, + "<%lu.%lu.%lu>: Wild stack pointer\n", + internal_pid_channel_no(p->id), + internal_pid_number(p->id), + internal_pid_serial(p->id)); + } + +} + +#if defined(CHECK_FOR_HOLES) +static void check_memory(Eterm *start, Eterm *end); + +void erts_check_for_holes(Process* p) +{ + ErlHeapFragment* hf; + Eterm* start; + + start = p->last_htop ? p->last_htop : HEAP_START(p); + check_memory(start, HEAP_TOP(p)); + p->last_htop = HEAP_TOP(p); + + for (hf = MBUF(p); hf != 0; hf = hf->next) { + if (hf == p->last_mbuf) { + break; + } + check_memory(hf->mem, hf->mem+hf->size); + } + p->last_mbuf = MBUF(p); +} + +static void check_memory(Eterm *start, Eterm *end) +{ + Eterm *pos = start; + + while (pos < end) { + Eterm hval = *pos++; + + if (hval == ERTS_HOLE_MARKER) { + erts_fprintf(stderr,"%s, line %d: ERTS_HOLE_MARKER found at 0x%0*lx\n", + __FILE__, __LINE__,PTR_SIZE,(unsigned long)(pos-1)); + print_untagged_memory(start,end); /* DEBUGSTUFF */ + abort(); + } else if (is_thing(hval)) { + pos += (thing_arityval(hval)); + } + } +} +#endif + +#ifdef __GNUC__ + +/* + * erts_check_heap and erts_check_memory will run through the heap + * silently if everything is ok. If there are strange (untagged) data + * in the heap or wild pointers, the system will be halted with an + * error message. + */ +void erts_check_heap(Process *p) +{ + ErlHeapFragment* bp = MBUF(p); + + erts_check_memory(p,HEAP_START(p),HEAP_TOP(p)); + if (OLD_HEAP(p) != NULL) { + erts_check_memory(p,OLD_HEAP(p),OLD_HTOP(p)); + } + + while (bp) { + erts_check_memory(p,bp->mem,bp->mem + bp->size); + bp = bp->next; + } +} + +void erts_check_memory(Process *p, Eterm *start, Eterm *end) +{ + Eterm *pos = start; + + while (pos < end) { + Eterm hval = *pos++; + +#ifdef DEBUG + if (hval == DEBUG_BAD_WORD) { + print_untagged_memory(start, end); + erl_exit(1, "Uninitialized HAlloc'ed memory found @ 0x%0*lx!\n", + PTR_SIZE,(unsigned long)(pos - 1)); + } +#endif + + if (is_thing(hval)) { + pos += thing_arityval(hval); + continue; + } + + if (verify_eterm(p,hval)) + continue; + + erl_exit(1, "Wild pointer found @ 0x%0*lx!\n", + PTR_SIZE,(unsigned long)(pos - 1)); + } +} + +void verify_process(Process *p) +{ +#define VERIFY_AREA(name,ptr,sz) { \ + int n = (sz); \ + while (n--) if(!verify_eterm(p,*(ptr+n))) \ + erl_exit(1,"Wild pointer found in " name " of %T!\n",p->id); } + +#define VERIFY_ETERM(name,eterm) { \ + if(!verify_eterm(p,eterm)) \ + erl_exit(1,"Wild pointer found in " name " of %T!\n",p->id); } + + + ErlMessage* mp = p->msg.first; + + VERBOSE(DEBUG_MEMORY,("Verify process: %T...\n",p->id)); + + while (mp != NULL) { + VERIFY_ETERM("message term",ERL_MESSAGE_TERM(mp)); + VERIFY_ETERM("message token",ERL_MESSAGE_TOKEN(mp)); + mp = mp->next; + } + + erts_check_stack(p); + erts_check_heap(p); + + if (p->dictionary) + VERIFY_AREA("dictionary",p->dictionary->data, p->dictionary->used); + VERIFY_ETERM("seq trace token",p->seq_trace_token); + VERIFY_ETERM("group leader",p->group_leader); + VERIFY_ETERM("fvalue",p->fvalue); + VERIFY_ETERM("ftrace",p->ftrace); + +#ifdef HYBRID + VERIFY_AREA("rrma",p->rrma,p->nrr); +#endif + + VERBOSE(DEBUG_MEMORY,("...done\n")); + +#undef VERIFY_AREA +#undef VERIFY_ETERM +} + +void verify_everything() +{ +#ifdef HYBRID + Uint i; + Uint n = erts_num_active_procs; + +#ifdef INCREMENTAL_FREE_SIZES_NEEDS_TO_BE_TAGGED_AS_HEADERS_WITH_ARITY + INC_Page *page = inc_used_mem; +#endif + + for (i = 0; i < n; i++) { + verify_process(erts_active_procs[i]); + } + + erts_check_memory(NULL,global_heap,global_htop); + +#ifdef INCREMENTAL_FREE_SIZES_NEEDS_TO_BE_TAGGED_AS_HEADERS_WITH_ARITY + while (page) + { + Eterm *end = page + INC_PAGE_SIZE; + Eterm *pos = page->start; + + while( pos < end) { + Eterm val = *pos++; + if(is_header(val)) + pos += thing_arityval(val); + else + verify_eterm(NULL,val); + } + page = page->next; + } +#endif +#endif /* HYBRID */ +} + +/* + * print_untagged_memory will print the contents of given memory area. + */ +void print_untagged_memory(Eterm *pos, Eterm *end) +{ + int i = 0; + erts_printf("| %*s | Range: 0x%0*lx - 0x%0*lx%*s|\n", + PTR_SIZE, "", + PTR_SIZE,(unsigned long)pos, + PTR_SIZE,(unsigned long)(end - 1),2 * PTR_SIZE - 2,""); + erts_printf("| %-*s | %-*s |\n",PTR_SIZE+2,"Address", + 4*PTR_SIZE+11,"Contents"); + erts_printf("|-%s-|-%s-%s-%s-%s-|\n",dashes,dashes,dashes,dashes,dashes); + while( pos < end ) { + if (i == 0) + erts_printf("| 0x%0*lx | ", PTR_SIZE, (unsigned long)pos); + erts_printf("0x%0*lx ",PTR_SIZE,(unsigned long)*pos); + pos++; i++; + if (i == 4) { + erts_printf("|\n"); + i = 0; + } + } + while (i && i < 4) { + erts_printf("%*s",PTR_SIZE+3,""); + i++; + } + if (i != 0) + erts_printf("|\n"); + erts_printf("+-%s-+-%s-%s-%s-%s-+\n",dashes,dashes,dashes,dashes,dashes); +} + +/* + * print_tagged_memory will print contents of given memory area and + * display it as if it was tagged Erlang terms (which it hopefully + * is). This function knows about forwarding pointers to be able to + * print a heap during garbage collection. erts_printf("%T",val) + * do not know about forwarding pointers though, so it will still + * crash if they are encoutered... + */ +void print_tagged_memory(Eterm *pos, Eterm *end) +{ + erts_printf("+-%s-+-%s-+\n",dashes,dashes); + erts_printf("| 0x%0*lx - 0x%0*lx |\n", + PTR_SIZE,(unsigned long)pos, + PTR_SIZE,(unsigned long)(end - 1)); + erts_printf("| %-*s | %-*s |\n",PTR_SIZE,"Address",PTR_SIZE,"Contents"); + erts_printf("|-%s-|-%s-|\n",dashes,dashes); + while( pos < end ) { + Eterm val = pos[0]; + erts_printf("| 0x%0*lx | 0x%0*lx | ", + PTR_SIZE,(unsigned long)pos, PTR_SIZE,(unsigned long)val); + ++pos; + if( is_arity_value(val) ) { + erts_printf("Arity(%lu)", arityval(val)); + } else if( is_thing(val) ) { + unsigned int ari = thing_arityval(val); + erts_printf("Thing Arity(%u) Tag(%lu)", ari, thing_subtag(val)); + while( ari ) { + erts_printf("\n| 0x%0*lx | 0x%0*lx | THING", + PTR_SIZE, (unsigned long)pos, + PTR_SIZE, (unsigned long)*pos); + ++pos; + --ari; + } + } else { + switch (primary_tag(val)) { + case TAG_PRIMARY_BOXED: + if (!is_header(*boxed_val(val))) { + erts_printf("Moved -> 0x%0*lx\n",PTR_SIZE, + (unsigned long)*boxed_val(val)); + continue; + } + break; + + case TAG_PRIMARY_LIST: + if (is_non_value(*list_val(val))) { + erts_printf("Moved -> 0x%0*lx\n",PTR_SIZE, + (unsigned long)*(list_val(val) + 1)); + continue; + } + break; + } + erts_printf("%.30T", val); + } + erts_printf("\n"); + } + erts_printf("+-%s-+-%s-+\n",dashes,dashes); +} + +#ifdef HYBRID +void print_ma_info(void) +{ + erts_printf("Message Area (start - top - end): " + "0x%0*lx - 0x%0*lx - 0x%0*lx\n", + PTR_SIZE, (unsigned long)global_heap, + PTR_SIZE, (unsigned long)global_htop, + PTR_SIZE, (unsigned long)global_hend); +#ifndef INCREMENTAL + erts_printf(" High water: 0x%0*lx " + "Old gen: 0x%0*lx - 0x%0*lx - 0x%0*lx\n", + PTR_SIZE, (unsigned long)global_high_water, + PTR_SIZE, (unsigned long)global_old_heap, + PTR_SIZE, (unsigned long)global_old_htop, + PTR_SIZE, (unsigned long)global_old_hend); +#endif +} + +void print_message_area(void) +{ + Eterm *pos = global_heap; + Eterm *end = global_htop; + + erts_printf("From: 0x%0*lx to 0x%0*lx\n", + PTR_SIZE,(unsigned long)pos,PTR_SIZE,(unsigned long)end); + erts_printf("(Old generation: 0x%0*lx to 0x%0*lx\n", + PTR_SIZE, (unsigned long)global_old_heap, + PTR_SIZE, (unsigned long)global_old_hend); + erts_printf("| %-*s | %-*s |\n",PTR_SIZE,"Address",PTR_SIZE,"Contents"); + erts_printf("|-%s-|-%s-|\n",dashes,dashes); + while( pos < end ) { + Eterm val = pos[0]; + erts_printf("| 0x%0*lx | 0x%0*lx | ", + PTR_SIZE,(unsigned long)pos,PTR_SIZE,(unsigned long)val); + ++pos; + if( is_arity_value(val) ) { + erts_printf("Arity(%lu)", arityval(val)); + } else if( is_thing(val) ) { + unsigned int ari = thing_arityval(val); + erts_printf("Thing Arity(%u) Tag(%lu)", ari, thing_subtag(val)); + while( ari ) { + erts_printf("\n| 0x%0*lx | 0x%0*lx | THING", + PTR_SIZE, (unsigned long)pos, + PTR_SIZE, (unsigned long)*pos); + ++pos; + --ari; + } + } else + erts_printf("%.30T", val); + erts_printf("\n"); + } + erts_printf("+-%s-+-%s-+\n",dashes,dashes); +} + +void check_message_area() +{ + Eterm *pos = global_heap; + Eterm *end = global_htop; + + while( pos < end ) { + Eterm val = *pos++; + if(is_header(val)) + pos += thing_arityval(val); + else if(!is_immed(val)) + if ((ptr_val(val) < global_heap || ptr_val(val) >= global_htop) && + (ptr_val(val) < global_old_heap || + ptr_val(val) >= global_old_hend)) + { + erts_printf("check_message_area: Stray pointer found\n"); + print_message_area(); + erts_printf("Crashing to make it look real...\n"); + pos = 0; + } + } +} +#endif /* HYBRID */ + +static void print_process_memory(Process *p); +static void print_process_memory(Process *p) +{ + ErlHeapFragment* bp = MBUF(p); + + erts_printf("==============================\n"); + erts_printf("|| Memory info for %T ||\n",p->id); + erts_printf("==============================\n"); + + erts_printf("-- %-*s ---%s-%s-%s-%s--\n", + PTR_SIZE, "PCB", dashes, dashes, dashes, dashes); + + if (p->msg.first != NULL) { + ErlMessage* mp; + erts_printf(" Message Queue:\n"); + mp = p->msg.first; + while (mp != NULL) { + erts_printf("| 0x%0*lx | 0x%0*lx |\n",PTR_SIZE, + ERL_MESSAGE_TERM(mp),PTR_SIZE,ERL_MESSAGE_TOKEN(mp)); + mp = mp->next; + } + } + + if (p->dictionary != NULL) { + int n = p->dictionary->used; + Eterm *ptr = p->dictionary->data; + erts_printf(" Dictionary: "); + while (n--) erts_printf("0x%0*lx ",PTR_SIZE,(unsigned long)ptr++); + erts_printf("\n"); + } + + if (p->arity > 0) { + int n = p->arity; + Eterm *ptr = p->arg_reg; + erts_printf(" Argument Registers: "); + while (n--) erts_printf("0x%0*lx ",PTR_SIZE,(unsigned long)*ptr++); + erts_printf("\n"); + } + + erts_printf(" Trace Token: 0x%0*lx\n",PTR_SIZE,p->seq_trace_token); + erts_printf(" Group Leader: 0x%0*lx\n",PTR_SIZE,p->group_leader); + erts_printf(" Fvalue: 0x%0*lx\n",PTR_SIZE,p->fvalue); + erts_printf(" Ftrace: 0x%0*lx\n",PTR_SIZE,p->ftrace); + +#ifdef HYBRID + if (p->nrr > 0) { + int i; + erts_printf(" Remembered Roots:\n"); + for (i = 0; i < p->nrr; i++) + if (p->rrsrc[i] != NULL) + erts_printf("0x%0*lx -> 0x%0*lx\n", + PTR_SIZE, (unsigned long)p->rrsrc[i], + PTR_SIZE, (unsigned long)p->rrma[i]); + erts_printf("\n"); + } +#endif + + erts_printf("+- %-*s -+ 0x%0*lx 0x%0*lx %s-%s-+\n", + PTR_SIZE, "Stack", + PTR_SIZE, (unsigned long)STACK_TOP(p), + PTR_SIZE, (unsigned long)STACK_START(p), + dashes, dashes); + print_untagged_memory(STACK_TOP(p),STACK_START(p)); + + erts_printf("+- %-*s -+ 0x%0*lx 0x%0*lx 0x%0*lx 0x%0*lx +\n", + PTR_SIZE, "Heap", + PTR_SIZE, (unsigned long)HEAP_START(p), + PTR_SIZE, (unsigned long)HIGH_WATER(p), + PTR_SIZE, (unsigned long)HEAP_TOP(p), + PTR_SIZE, (unsigned long)HEAP_END(p)); + print_untagged_memory(HEAP_START(p),HEAP_TOP(p)); + + if (OLD_HEAP(p)) { + erts_printf("+- %-*s -+ 0x%0*lx 0x%0*lx 0x%0*lx %s-+\n", + PTR_SIZE, "Old Heap", + PTR_SIZE, (unsigned long)OLD_HEAP(p), + PTR_SIZE, (unsigned long)OLD_HTOP(p), + PTR_SIZE, (unsigned long)OLD_HEND(p), + dashes); + print_untagged_memory(OLD_HEAP(p),OLD_HTOP(p)); + } + + if (bp) + erts_printf("+- %-*s -+-%s-%s-%s-%s-+\n", + PTR_SIZE, "heap fragments", + dashes, dashes, dashes, dashes); + while (bp) { + print_untagged_memory(bp->mem,bp->mem + bp->size); + bp = bp->next; + } +} + + +void print_memory(Process *p) +{ + if (p != NULL) { + print_process_memory(p); + } +#ifdef HYBRID + else { + Uint i; + Uint n = erts_num_active_procs; + + for (i = 0; i < n; i++) { + Process *p = erts_active_procs[i]; + print_process_memory(p); + } + + erts_printf("==================\n"); + erts_printf("|| Message area ||\n"); + erts_printf("==================\n"); + erts_printf("+-%s-+-%s-%s-%s-%s-+\n", + dashes,dashes,dashes,dashes,dashes); + erts_printf("| %-*s | 0x%0*lx - 0x%0*lx - 0x%0*lx%*s|\n", + PTR_SIZE, "Young", + PTR_SIZE, (unsigned long)global_heap, + PTR_SIZE, (unsigned long)global_htop, + PTR_SIZE, (unsigned long)global_hend, + PTR_SIZE, ""); + erts_printf("+-%s-+-%s-%s-%s-%s-+\n", + dashes,dashes,dashes,dashes,dashes); + + print_untagged_memory(global_heap,global_htop); + + + erts_printf("+-%s-+-%s-%s-%s-%s-+\n", + dashes,dashes,dashes,dashes,dashes); + erts_printf("| %-*s | 0x%0*lx - 0x%0*lx %*s |\n", + PTR_SIZE, "Old", + PTR_SIZE, (unsigned long)global_old_heap, + PTR_SIZE, (unsigned long)global_old_hend, + 2 * PTR_SIZE, ""); + erts_printf("+-%s-+-%s-%s-%s-%s-+\n", + dashes,dashes,dashes,dashes,dashes); + +#ifdef INCREMENTAL + { + INC_Page *page = inc_used_mem; + /* Genom att gå igenom fri-listan först kan vi markera de + områden som inte är allokerade och bara skriva ut de som + lever. + char markarea[INC_PAGESIZE]; + */ + + while (page) { + Eterm *ptr = (Eterm*)page->start; + Eterm *end = (Eterm*)page->start + INC_PAGESIZE; + + erts_printf("| %*s | This: 0x%0*lx Next: 0x%0*lx %*s|\n", + PTR_SIZE, "", + PTR_SIZE, (unsigned long)page, + PTR_SIZE, (unsigned long)page->next, + 2 * PTR_SIZE - 8, ""); + print_untagged_memory(ptr,end); + page = page->next; + } + } + + { + INC_MemBlock *this = inc_free_list; + + erts_printf("-- %-*s --%s-%s-%s-%s-\n",PTR_SIZE+2,"Free list", + dashes,dashes,dashes,dashes); + while (this) { + erts_printf("Block @ 0x%0*lx sz: %8d prev: 0x%0*lx next: 0x%0*lx\n", + PTR_SIZE, (unsigned long)this,this->size, + PTR_SIZE, (unsigned long)this->prev, + PTR_SIZE, (unsigned long)this->next); + this = this->next; + } + erts_printf("--%s---%s-%s-%s-%s--\n", + dashes,dashes,dashes,dashes,dashes); + } + + if (inc_fromspc != NULL) { + erts_printf("-- fromspace - 0x%0*lx 0x%0*lx " + "------------------------------\n", + PTR_SIZE, (unsigned long)inc_fromspc, + PTR_SIZE, (unsigned long)inc_fromend); + print_untagged_memory(inc_fromspc,inc_fromend); + } +#endif /* INCREMENTAL */ + } +#endif /* HYBRID */ +} + +void print_memory_info(Process *p) +{ + if (p != NULL) { + erts_printf("======================================\n"); + erts_printf("|| Memory info for %-12T ||\n",p->id); + erts_printf("======================================\n"); + erts_printf("+- local heap ----%s-%s-%s-%s-+\n", + dashes,dashes,dashes,dashes); + erts_printf("| Young | 0x%0*lx - (0x%0*lx) - 0x%0*lx - 0x%0*lx |\n", + PTR_SIZE, (unsigned long)HEAP_START(p), + PTR_SIZE, (unsigned long)HIGH_WATER(p), + PTR_SIZE, (unsigned long)HEAP_TOP(p), + PTR_SIZE, (unsigned long)HEAP_END(p)); + if (OLD_HEAP(p) != NULL) + erts_printf("| Old | 0x%0*lx - 0x%0*lx - 0x%0*lx %*s |\n", + PTR_SIZE, (unsigned long)OLD_HEAP(p), + PTR_SIZE, (unsigned long)OLD_HTOP(p), + PTR_SIZE, (unsigned long)OLD_HEND(p), + PTR_SIZE, ""); + } else { + erts_printf("=================\n"); + erts_printf("|| Memory info ||\n"); + erts_printf("=================\n"); + } +#ifdef HYBRID + erts_printf("|- message area --%s-%s-%s-%s-|\n", + dashes,dashes,dashes,dashes); + erts_printf("| Young | 0x%0*lx - 0x%0*lx - 0x%0*lx %*s |\n", + PTR_SIZE, (unsigned long)global_heap, + PTR_SIZE, (unsigned long)global_htop, + PTR_SIZE, (unsigned long)global_hend, + PTR_SIZE, ""); + erts_printf("| Old | 0x%0*lx - 0x%0*lx %*s |\n", + PTR_SIZE, (unsigned long)global_old_heap, + PTR_SIZE, (unsigned long)global_old_hend, + 2 * PTR_SIZE, ""); +#endif +#ifdef INCREMENTAL + if (inc_fromspc != NULL) + erts_printf("| Frmsp | 0x%0*lx - 0x%0*lx %*s |\n", + PTR_SIZE, (unsigned long)inc_fromspc, + PTR_SIZE, (unsigned long)inc_fromend, + 2 * PTR_SIZE, ""); +#endif + erts_printf("+-----------------%s-%s-%s-%s-+\n",dashes,dashes,dashes,dashes); +} +#endif + diff --git a/erts/emulator/beam/erl_debug.h b/erts/emulator/beam/erl_debug.h new file mode 100644 index 0000000000..74f4a00b63 --- /dev/null +++ b/erts/emulator/beam/erl_debug.h @@ -0,0 +1,102 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2004-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ +#ifndef _ERL_DEBUG_H_ +#define _ERL_DEBUG_H_ + +#ifdef DEBUG + +#ifdef HIPE +#include "hipe_debug.h" +#endif + +/* Heap areas will be filled with this value when they are deallocated + * after a garbage collection. This value used to be 0xff, but that is + * an immediate and might not crash the system if it is encountered. + * The value is now 0x01, the cons of death. + */ +#define DEBUG_BAD_BYTE 0x01 +#define DEBUG_BAD_WORD 0x01010101 + +/* + * VERBOSE. Use the -v option to enable the different categories. + */ +#define VERBOSE(flag, format) (flag & verbose ? erts_printf format : 0) + +#define DEBUG_DEFAULT 0x0000 /* No flags are set per default */ +#define DEBUG_SYSTEM 0x0001 /* Misc system info at startup and end */ +#define DEBUG_PRIVATE_GC 0x0002 /* GC of private heaps */ +#define DEBUG_HYBRID_GC 0x0004 /* GC of the message area */ +#define DEBUG_ALLOCATION 0x0008 /* HAlloc. To find holes in the heap */ +#define DEBUG_MESSAGES 0x0010 /* Message passing */ +#define DEBUG_THREADS 0x0020 /* Thread-related stuff */ +#define DEBUG_PROCESSES 0x0040 /* Process creation and removal */ +#define DEBUG_MEMORY 0x0080 /* Display results of memory checks */ + +extern Uint32 verbose; + +void upp(byte*, int); +void pat(Eterm); +void pinfo(void); +void pp(Process*); +void ppi(Eterm); +void pba(Process*, int); +void td(Eterm); +void ps(Process*, Eterm*); + +#undef ERTS_OFFHEAP_DEBUG +#define ERTS_OFFHEAP_DEBUG + +#else /* Non-debug mode */ + +#define VERBOSE(flag,format) + +#endif /* DEBUG */ + +#ifdef ERTS_OFFHEAP_DEBUG +#define ERTS_CHK_OFFHEAP(P) erts_check_off_heap((P)) +#define ERTS_CHK_OFFHEAP2(P, HT) erts_check_off_heap2((P), (HT)) +void erts_check_off_heap(Process *); +void erts_check_off_heap2(Process *, Eterm *); +#else +#define ERTS_CHK_OFFHEAP(P) +#define ERTS_CHK_OFFHEAP2(P, HT) +#endif + +/* + * These functions can be handy when developing, and perhaps useful + * even outside debugging. + */ +extern void erts_check_off_heap(Process *p); +extern void erts_check_stack(Process *p); +extern void erts_check_heap(Process *p); +extern void erts_check_memory(Process *p, Eterm *start, Eterm *end); +extern void verify_process(Process *p); +extern void verify_everything(void); +extern void print_tagged_memory(Eterm *start, Eterm *end); +extern void print_untagged_memory(Eterm *start, Eterm *end); +extern void print_memory(Process *p); +extern void print_memory_info(Process *p); + +#ifdef HYBRID +extern void print_ma_info(void); +extern void print_message_area(void); +extern void check_message_area(void); +#endif + +#endif /* _ERL_DEBUG_H_ */ diff --git a/erts/emulator/beam/erl_driver.h b/erts/emulator/beam/erl_driver.h new file mode 100644 index 0000000000..cdb584b282 --- /dev/null +++ b/erts/emulator/beam/erl_driver.h @@ -0,0 +1,626 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1999-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* + * Include file for erlang driver writers. + */ + +#ifndef __ERL_DRIVER_H__ +#define __ERL_DRIVER_H__ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#ifdef SIZEOF_CHAR +# define SIZEOF_CHAR_SAVED__ SIZEOF_CHAR +# undef SIZEOF_CHAR +#endif +#ifdef SIZEOF_SHORT +# define SIZEOF_SHORT_SAVED__ SIZEOF_SHORT +# undef SIZEOF_SHORT +#endif +#ifdef SIZEOF_INT +# define SIZEOF_INT_SAVED__ SIZEOF_INT +# undef SIZEOF_INT +#endif +#ifdef SIZEOF_LONG +# define SIZEOF_LONG_SAVED__ SIZEOF_LONG +# undef SIZEOF_LONG +#endif +#ifdef SIZEOF_LONG_LONG +# define SIZEOF_LONG_LONG_SAVED__ SIZEOF_LONG_LONG +# undef SIZEOF_LONG_LONG +#endif +#include "erl_int_sizes_config.h" +#if defined(SIZEOF_CHAR_SAVED__) && SIZEOF_CHAR_SAVED__ != SIZEOF_CHAR +# error SIZEOF_CHAR mismatch +#endif +#if defined(SIZEOF_SHORT_SAVED__) && SIZEOF_SHORT_SAVED__ != SIZEOF_SHORT +# error SIZEOF_SHORT mismatch +#endif +#if defined(SIZEOF_INT_SAVED__) && SIZEOF_INT_SAVED__ != SIZEOF_INT +# error SIZEOF_INT mismatch +#endif +#if defined(SIZEOF_LONG_SAVED__) && SIZEOF_LONG_SAVED__ != SIZEOF_LONG +# error SIZEOF_LONG mismatch +#endif +#if defined(SIZEOF_LONG_LONG_SAVED__) && SIZEOF_LONG_LONG_SAVED__ != SIZEOF_LONG_LONG +# error SIZEOF_LONG_LONG mismatch +#endif + +#include + +#if defined(VXWORKS) +# include +typedef struct iovec SysIOVec; +#elif defined(__WIN32__) || defined(_WIN32) || defined(_WIN32_) +#ifndef STATIC_ERLANG_DRIVER + /* Windows dynamic drivers, everything is different... */ +#define ERL_DRIVER_TYPES_ONLY +#define WIN32_DYNAMIC_ERL_DRIVER +#endif +/* + * This structure can be cast to a WSABUF structure. + */ +typedef struct _SysIOVec { + unsigned long iov_len; + char* iov_base; +} SysIOVec; +#else /* Unix */ +# ifdef HAVE_SYS_UIO_H +# include +# include +typedef struct iovec SysIOVec; +# else +typedef struct { + char* iov_base; + size_t iov_len; +} SysIOVec; +# endif +#endif + +#ifndef EXTERN +# ifdef __cplusplus +# define EXTERN extern "C" +# else +# define EXTERN extern +# endif +#endif + +/* Values for mode arg to driver_select() */ +#define ERL_DRV_READ (1 << 0) +#define ERL_DRV_WRITE (1 << 1) +#define ERL_DRV_USE (1 << 2) +#define ERL_DRV_USE_NO_CALLBACK (ERL_DRV_USE | (1 << 3)) + +/* Old deprecated */ +#define DO_READ ERL_DRV_READ +#define DO_WRITE ERL_DRV_WRITE + +#define ERL_DRV_EXTENDED_MARKER (0xfeeeeeed) +#define ERL_DRV_EXTENDED_MAJOR_VERSION 1 +#define ERL_DRV_EXTENDED_MINOR_VERSION 4 + +/* + * The emulator will refuse to load a driver with different major + * version than the one used by the emulator. + */ + + +/* Values for set_port_control_flags() */ + +#define PORT_CONTROL_FLAG_BINARY (1 << 0) +#define PORT_CONTROL_FLAG_HEAVY (1 << 1) + +/* Values for get_port_flags() */ + +#define PORT_FLAG_BINARY (1 << 0) +#define PORT_FLAG_LINE (1 << 1) + + +#define ERL_DRV_FLAG_USE_PORT_LOCKING (1 << 0) +#define ERL_DRV_FLAG_SOFT_BUSY (1 << 1) + +/* + * A binary as seen in a driver. Note that a binary should never be + * altered by the driver when it has been sent to Erlang. + */ + +typedef struct erl_drv_binary { + long orig_size; /* total length of binary */ + char orig_bytes[1]; /* the data (char instead of byte!) */ +} ErlDrvBinary; + + +/* + * Note: These types are incomplete to catch type errors easier. + */ + +typedef struct _erl_drv_data* ErlDrvData; /* Data to be used by the driver itself. */ +#ifndef ERL_SYS_DRV +typedef struct _erl_drv_event* ErlDrvEvent; /* An event to be selected on. */ +typedef struct _erl_drv_port* ErlDrvPort; /* A port descriptor. */ +#endif +typedef struct _erl_drv_port* ErlDrvThreadData; /* Thread data. */ + +#if !defined(__WIN32__) && !defined(_WIN32) && !defined(_WIN32_) && !defined(USE_SELECT) +struct erl_drv_event_data { + short events; + short revents; +}; +#endif +typedef struct erl_drv_event_data *ErlDrvEventData; /* Event data */ + +/* + * Used in monitors... + */ +typedef unsigned long ErlDrvTermData; +typedef unsigned long ErlDrvUInt; +typedef signed long ErlDrvSInt; + +#if defined(__WIN32__) +typedef unsigned __int64 ErlDrvUInt64; +typedef __int64 ErlDrvSInt64; +#elif SIZEOF_LONG == 8 +typedef unsigned long ErlDrvUInt64; +typedef long ErlDrvSInt64; +#elif SIZEOF_LONG_LONG == 8 +typedef unsigned long long ErlDrvUInt64; +typedef long long ErlDrvSInt64; +#else +#error No 64-bit integer type +#endif + +/* + * A driver monitor + */ +typedef struct { + unsigned char data[sizeof(void *)*4]; +} ErlDrvMonitor; + + +/* + * System info + */ + +typedef struct { + int driver_major_version; + int driver_minor_version; + char *erts_version; + char *otp_release; + int thread_support; + int smp_support; + int async_threads; + int scheduler_threads; +} ErlDrvSysInfo; + +typedef struct { + unsigned long megasecs; + unsigned long secs; + unsigned long microsecs; +} ErlDrvNowData; + +/* + * Error codes that can be return from driver. + */ + +/* + * Exception code from open_port/2 will be {'EXIT',{einval,Where}}. + */ +#define ERL_DRV_ERROR_GENERAL ((ErlDrvData) -1) + +/* + * Exception code from open_port/2 will be {'EXIT',{Errno,Where}}, + * where Errno is a textual representation of the errno variable + * (e.g. eacces if errno is EACCES). + */ +#define ERL_DRV_ERROR_ERRNO ((ErlDrvData) -2) + +/* + * Exception code from open_port/2 will be {'EXIT',{badarg,Where}}. + */ +#define ERL_DRV_ERROR_BADARG ((ErlDrvData) -3) + +typedef struct erl_io_vec { + int vsize; /* length of vectors */ + int size; /* total size in bytes */ + SysIOVec* iov; + ErlDrvBinary** binv; +} ErlIOVec; + +/* + * erl driver thread types + */ + +typedef struct ErlDrvTid_ *ErlDrvTid; +typedef struct ErlDrvMutex_ ErlDrvMutex; +typedef struct ErlDrvCond_ ErlDrvCond; +typedef struct ErlDrvRWLock_ ErlDrvRWLock; +typedef int ErlDrvTSDKey; + +typedef struct { + int suggested_stack_size; +} ErlDrvThreadOpts; + +/* + * + */ +typedef struct erl_drv_port_data_lock * ErlDrvPDL; + +/* + * This structure defines a driver. + */ + +typedef struct erl_drv_entry { + int (*init)(void); /* called at system start up for statically + linked drivers, and after loading for + dynamically loaded drivers */ + +#ifndef ERL_SYS_DRV + ErlDrvData (*start)(ErlDrvPort port, char *command); + /* called when open_port/2 is invoked. + return value -1 means failure. */ +#else + ErlDrvData (*start)(ErlDrvPort port, char *command, SysDriverOpts* opts); + /* special options, only for system driver */ +#endif + void (*stop)(ErlDrvData drv_data); + /* called when port is closed, and when the + emulator is halted. */ + void (*output)(ErlDrvData drv_data, char *buf, int len); + /* called when we have output from erlang to + the port */ + void (*ready_input)(ErlDrvData drv_data, ErlDrvEvent event); + /* called when we have input from one of + the driver's handles) */ + void (*ready_output)(ErlDrvData drv_data, ErlDrvEvent event); + /* called when output is possible to one of + the driver's handles */ + char *driver_name; /* name supplied as command + in open_port XXX ? */ + void (*finish)(void); /* called before unloading the driver - + DYNAMIC DRIVERS ONLY */ + void *handle; /* Reserved -- Used by emulator internally */ + int (*control)(ErlDrvData drv_data, unsigned int command, char *buf, + int len, char **rbuf, int rlen); + /* "ioctl" for drivers - invoked by + port_control/3) */ + void (*timeout)(ErlDrvData drv_data); /* Handling of timeout in driver */ + void (*outputv)(ErlDrvData drv_data, ErlIOVec *ev); + /* called when we have output from erlang + to the port */ + void (*ready_async)(ErlDrvData drv_data, ErlDrvThreadData thread_data); + void (*flush)(ErlDrvData drv_data); + /* called when the port is about to be + closed, and there is data in the + driver queue that needs to be flushed + before 'stop' can be called */ + int (*call)(ErlDrvData drv_data, unsigned int command, char *buf, + int len, char **rbuf, int rlen, unsigned int *flags); + /* Works mostly like 'control', a syncronous + call into the driver. */ + void (*event)(ErlDrvData drv_data, ErlDrvEvent event, + ErlDrvEventData event_data); + /* Called when an event selected by + driver_event() has occurred */ + int extended_marker; /* ERL_DRV_EXTENDED_MARKER */ + int major_version; /* ERL_DRV_EXTENDED_MAJOR_VERSION */ + int minor_version; /* ERL_DRV_EXTENDED_MINOR_VERSION */ + int driver_flags; /* ERL_DRV_FLAGs */ + void *handle2; /* Reserved -- Used by emulator internally */ + void (*process_exit)(ErlDrvData drv_data, ErlDrvMonitor *monitor); + /* Called when a process monitor fires */ + void (*stop_select)(ErlDrvEvent event, void* reserved); + /* Called on behalf of driver_select when + it is safe to release 'event'. A typical + unix driver would call close(event) */ + /* When adding entries here, dont forget to pad in obsolete/driver.h */ +} ErlDrvEntry; + +/* + * This macro is used to name a dynamic driver's init function in + * a way that doesn't lead to conflicts. This is crucial when using + * operating systems that has one namespace for all symbols + * (e.g. VxWorks). Example: if you have an dynamic driver C source + * file named echo_drv.c, you use the macro like this: + * + * DRIVER_INIT(echo_drv) + * { + * .... + * } + * + * This function will be called by the Erlang I/O system when the driver is loaded. + * It must initialize a ErlDrvEntry structure and return a pointer to it. + */ + +/* For windows dynamic drivers */ +#ifndef ERL_DRIVER_TYPES_ONLY + +#if defined(VXWORKS) +# define DRIVER_INIT(DRIVER_NAME) ErlDrvEntry* DRIVER_NAME ## _init(void) +#elif defined(__WIN32__) +# define DRIVER_INIT(DRIVER_NAME) __declspec(dllexport) ErlDrvEntry* driver_init(void) +#else +# define DRIVER_INIT(DRIVER_NAME) ErlDrvEntry* driver_init(void) +#endif + +/* + * These are the functions available for driver writers. + */ +EXTERN int driver_select(ErlDrvPort port, ErlDrvEvent event, int mode, int on); +EXTERN int driver_event(ErlDrvPort port, ErlDrvEvent event, + ErlDrvEventData event_data); +EXTERN int driver_output(ErlDrvPort port, char *buf, int len); +EXTERN int driver_output2(ErlDrvPort port, char *hbuf, int hlen, + char *buf, int len); +EXTERN int driver_output_binary(ErlDrvPort port, char *hbuf, int hlen, + ErlDrvBinary* bin, int offset, int len); +EXTERN int driver_outputv(ErlDrvPort port, char* hbuf, int hlen, ErlIOVec *ev, + int skip); +EXTERN int driver_vec_to_buf(ErlIOVec *ev, char *buf, int len); +EXTERN int driver_set_timer(ErlDrvPort port, unsigned long time); +EXTERN int driver_cancel_timer(ErlDrvPort port); +EXTERN int driver_read_timer(ErlDrvPort port, unsigned long *time_left); + +/* + * Get plain-text error message from within a driver + */ +EXTERN char* erl_errno_id(int error); + +/* + * The following functions are used to initiate a close of a port + * from a driver. + */ +EXTERN int driver_failure_eof(ErlDrvPort port); +EXTERN int driver_failure_atom(ErlDrvPort port, char *string); +EXTERN int driver_failure_posix(ErlDrvPort port, int error); +EXTERN int driver_failure(ErlDrvPort port, int error); +EXTERN int driver_exit (ErlDrvPort port, int err); + + +/* + * Port Data Lock + */ + +EXTERN ErlDrvPDL driver_pdl_create(ErlDrvPort); +EXTERN void driver_pdl_lock(ErlDrvPDL); +EXTERN void driver_pdl_unlock(ErlDrvPDL); +EXTERN long driver_pdl_get_refc(ErlDrvPDL); +EXTERN long driver_pdl_inc_refc(ErlDrvPDL); +EXTERN long driver_pdl_dec_refc(ErlDrvPDL); + +/* + * Process monitors + */ +EXTERN int +driver_monitor_process(ErlDrvPort port, ErlDrvTermData process, + ErlDrvMonitor *monitor); +EXTERN int +driver_demonitor_process(ErlDrvPort port, const ErlDrvMonitor *monitor); +EXTERN ErlDrvTermData +driver_get_monitored_process(ErlDrvPort port, const ErlDrvMonitor *monitor); +EXTERN int driver_compare_monitors(const ErlDrvMonitor *monitor1, + const ErlDrvMonitor *monitor2); + +/* + * Port attributes + */ +EXTERN void set_busy_port(ErlDrvPort port, int on); +EXTERN void set_port_control_flags(ErlDrvPort port, int flags); + +EXTERN int get_port_flags(ErlDrvPort port); + + +/* Binary interface */ + +/* + * NOTE: DO NOT overwrite a binary with new data (if the data is delivered); + * since the binary is a shared object it MUST be written once. + */ + +EXTERN ErlDrvBinary* driver_alloc_binary(int size); +EXTERN ErlDrvBinary* driver_realloc_binary(ErlDrvBinary *bin, int size); +EXTERN void driver_free_binary(ErlDrvBinary *bin); + +/* Referenc count on driver binaries */ +EXTERN long driver_binary_get_refc(ErlDrvBinary *dbp); +EXTERN long driver_binary_inc_refc(ErlDrvBinary *dbp); +EXTERN long driver_binary_dec_refc(ErlDrvBinary *dbp); + +/* Allocation interface */ +EXTERN void *driver_alloc(size_t size); +EXTERN void *driver_realloc(void *ptr, size_t size); +EXTERN void driver_free(void *ptr); + +/* Queue interface */ +EXTERN int driver_enq(ErlDrvPort port, char* buf, int len); +EXTERN int driver_pushq(ErlDrvPort port, char* buf, int len); +EXTERN int driver_deq(ErlDrvPort port, int size); +EXTERN int driver_sizeq(ErlDrvPort port); +EXTERN int driver_enq_bin(ErlDrvPort port, ErlDrvBinary *bin, int offset, + int len); +EXTERN int driver_pushq_bin(ErlDrvPort port, ErlDrvBinary *bin, int offset, + int len); + +EXTERN int driver_peekqv(ErlDrvPort port, ErlIOVec *ev); +EXTERN SysIOVec* driver_peekq(ErlDrvPort port, int *vlen); +EXTERN int driver_enqv(ErlDrvPort port, ErlIOVec *ev, int skip); +EXTERN int driver_pushqv(ErlDrvPort port, ErlIOVec *ev, int skip); + +/* + * Add and remove driver entries. + */ +EXTERN void add_driver_entry(ErlDrvEntry *de); +EXTERN int remove_driver_entry(ErlDrvEntry *de); + +/* + * System info + */ +EXTERN void driver_system_info(ErlDrvSysInfo *sip, size_t si_size); + +/* + * erl driver thread functions. + */ + +EXTERN ErlDrvMutex *erl_drv_mutex_create(char *name); +EXTERN void erl_drv_mutex_destroy(ErlDrvMutex *mtx); +EXTERN int erl_drv_mutex_trylock(ErlDrvMutex *mtx); +EXTERN void erl_drv_mutex_lock(ErlDrvMutex *mtx); +EXTERN void erl_drv_mutex_unlock(ErlDrvMutex *mtx); +EXTERN ErlDrvCond *erl_drv_cond_create(char *name); +EXTERN void erl_drv_cond_destroy(ErlDrvCond *cnd); +EXTERN void erl_drv_cond_signal(ErlDrvCond *cnd); +EXTERN void erl_drv_cond_broadcast(ErlDrvCond *cnd); +EXTERN void erl_drv_cond_wait(ErlDrvCond *cnd, ErlDrvMutex *mtx); +EXTERN ErlDrvRWLock *erl_drv_rwlock_create(char *name); +EXTERN void erl_drv_rwlock_destroy(ErlDrvRWLock *rwlck); +EXTERN int erl_drv_rwlock_tryrlock(ErlDrvRWLock *rwlck); +EXTERN void erl_drv_rwlock_rlock(ErlDrvRWLock *rwlck); +EXTERN void erl_drv_rwlock_runlock(ErlDrvRWLock *rwlck); +EXTERN int erl_drv_rwlock_tryrwlock(ErlDrvRWLock *rwlck); +EXTERN void erl_drv_rwlock_rwlock(ErlDrvRWLock *rwlck); +EXTERN void erl_drv_rwlock_rwunlock(ErlDrvRWLock *rwlck); +EXTERN int erl_drv_tsd_key_create(char *name, ErlDrvTSDKey *key); +EXTERN void erl_drv_tsd_key_destroy(ErlDrvTSDKey key); +EXTERN void erl_drv_tsd_set(ErlDrvTSDKey key, void *data); +EXTERN void *erl_drv_tsd_get(ErlDrvTSDKey key); +EXTERN ErlDrvThreadOpts *erl_drv_thread_opts_create(char *name); +EXTERN void erl_drv_thread_opts_destroy(ErlDrvThreadOpts *opts); +EXTERN int erl_drv_thread_create(char *name, + ErlDrvTid *tid, + void * (*func)(void *), + void *args, + ErlDrvThreadOpts *opts); +EXTERN ErlDrvTid erl_drv_thread_self(void); +EXTERN int erl_drv_equal_tids(ErlDrvTid tid1, ErlDrvTid tid2); +EXTERN void erl_drv_thread_exit(void *resp); +EXTERN int erl_drv_thread_join(ErlDrvTid, void **respp); + +/* + * Misc. + */ +EXTERN int null_func(void); + +#endif /* !ERL_DRIVER_TYPES_ONLY */ + +/* Constants for return flags from the 'port_call' callback */ +#define DRIVER_CALL_KEEP_BUFFER 0x1 + +/* ErlDrvTerm is the type to use for casts when building + * terms that should be sent to connected process, + * for instance a tuple on the form {tcp, Port, [Tag|Binary]} + * + * ErlDrvTerm spec[] = { + * ERL_DRV_ATOM, driver_mk_atom("tcp"), + * ERL_DRV_PORT, driver_mk_port(drv->ix), + * ERL_DRV_INT, REPLY_TAG, + * ERL_DRV_BINARY, (ErlDrvTerm)bin, 50, 0, + * ERL_DRV_LIST, 2, + * ERL_DRV_TUPLE, 3, + * } + * + */ + +#define TERM_DATA(x) ((ErlDrvTermData) (x)) + +/* Possible types to send from driver Argument type */ +#define ERL_DRV_NIL ((ErlDrvTermData) 1) /* None */ +#define ERL_DRV_ATOM ((ErlDrvTermData) 2) /* driver_mk_atom(string) */ +#define ERL_DRV_INT ((ErlDrvTermData) 3) /* ErlDrvSInt */ +#define ERL_DRV_PORT ((ErlDrvTermData) 4) /* driver_mk_port(ix) */ +#define ERL_DRV_BINARY ((ErlDrvTermData) 5) /* ErlDrvBinary*, + * ErlDrvUInt size, + * ErlDrvUInt offs */ +#define ERL_DRV_STRING ((ErlDrvTermData) 6) /* char*, ErlDrvUInt */ +#define ERL_DRV_TUPLE ((ErlDrvTermData) 7) /* ErlDrvUInt */ +#define ERL_DRV_LIST ((ErlDrvTermData) 8) /* ErlDrvUInt */ +#define ERL_DRV_STRING_CONS ((ErlDrvTermData) 9) /* char*, ErlDrvUInt */ +#define ERL_DRV_PID ((ErlDrvTermData) 10) /* driver_connected,... */ + +#define ERL_DRV_FLOAT ((ErlDrvTermData) 11) /* double * */ +#define ERL_DRV_EXT2TERM ((ErlDrvTermData) 12) /* char *, ErlDrvUInt */ +#define ERL_DRV_UINT ((ErlDrvTermData) 13) /* ErlDrvUInt */ +#define ERL_DRV_BUF2BINARY ((ErlDrvTermData) 14) /* char *, ErlDrvUInt */ +#define ERL_DRV_INT64 ((ErlDrvTermData) 15) /* ErlDrvSInt64 * */ +#define ERL_DRV_UINT64 ((ErlDrvTermData) 16) /* ErlDrvUInt64 * */ + +#ifndef ERL_DRIVER_TYPES_ONLY + +/* make terms for driver_output_term and driver_send_term */ +EXTERN ErlDrvTermData driver_mk_atom(char*); +EXTERN ErlDrvTermData driver_mk_port(ErlDrvPort); +EXTERN ErlDrvTermData driver_connected(ErlDrvPort); +EXTERN ErlDrvTermData driver_caller(ErlDrvPort); +extern const ErlDrvTermData driver_term_nil; +EXTERN ErlDrvTermData driver_mk_term_nil(void); +EXTERN ErlDrvPort driver_create_port(ErlDrvPort creator_port, + ErlDrvTermData connected, /* pid */ + char* name, /* driver name */ + ErlDrvData drv_data); + + +/* output term data to the port owner */ +EXTERN int driver_output_term(ErlDrvPort ix, ErlDrvTermData* data, int len); +/* output term data to a specific process */ +EXTERN int driver_send_term(ErlDrvPort ix, ErlDrvTermData to, + ErlDrvTermData* data, int len); + +/* Async IO functions */ +EXTERN long driver_async(ErlDrvPort ix, + unsigned int* key, + void (*async_invoke)(void*), + void* async_data, + void (*async_free)(void*)); + + +EXTERN int driver_async_cancel(unsigned int key); + +/* Locks the driver in the machine "forever", there is + no unlock function. Note that this is almost never useful, as an open + port towards the driver locks it until the port is closed, why unexpected + unloading "never" happens. */ +EXTERN int driver_lock_driver(ErlDrvPort ix); + +/* Get the current 'now' timestamp (analogue to erlang:now()) */ +EXTERN int driver_get_now(ErlDrvNowData *now); + + +/* These were removed from the ANSI version, now they're back. */ + +EXTERN void *driver_dl_open(char *); +EXTERN void *driver_dl_sym(void *, char *); +EXTERN int driver_dl_close(void *); +EXTERN char *driver_dl_error(void); + +/* environment */ +EXTERN int erl_drv_putenv(char *key, char *value); +EXTERN int erl_drv_getenv(char *key, char *value, size_t *value_size); + +#endif /* !ERL_DRIVER_TYPES_ONLY */ + +#ifdef WIN32_DYNAMIC_ERL_DRIVER +# include "erl_win_dyn_driver.h" +#endif + +#endif + + + + diff --git a/erts/emulator/beam/erl_drv_thread.c b/erts/emulator/beam/erl_drv_thread.c new file mode 100644 index 0000000000..50d8c25c46 --- /dev/null +++ b/erts/emulator/beam/erl_drv_thread.c @@ -0,0 +1,706 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2007-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "global.h" +#include + +#define ERL_DRV_THR_OPTS_SIZE(LAST_FIELD) \ + (((size_t) &((ErlDrvThreadOpts *) 0)->LAST_FIELD) \ + + sizeof(((ErlDrvThreadOpts *) 0)->LAST_FIELD)) + +static void +fatal_error(int err, char *func) +{ + char *estr = strerror(err); + if (!estr) { + if (err == ENOTSUP) + estr = "Not supported"; + else + estr = "Unknown error"; + } + erl_exit(ERTS_ABORT_EXIT, "Fatal error in %s: %s [%d]\n", func, estr, err); +} + +#define ERL_DRV_TSD_KEYS_INC 10 +#define ERL_DRV_TSD_EXTRA 10 +#define ERL_DRV_INVALID_TSD_KEY INT_MAX + +#ifdef USE_THREADS + +struct ErlDrvMutex_ { + ethr_mutex mtx; + char *name; +}; + +struct ErlDrvCond_ { + ethr_cond cnd; + char *name; +}; + +struct ErlDrvRWLock_ { + ethr_rwmutex rwmtx; + char *name; +}; + +struct ErlDrvTid_ { + ethr_tid tid; + void* (*func)(void*); + void* arg; + int drv_thr; + Uint tsd_len; + void **tsd; + char *name; +}; + +static ethr_tsd_key tid_key; + +static ethr_thr_opts def_ethr_opts = ETHR_THR_OPTS_DEFAULT_INITER; + +#else /* USE_THREADS */ +static Uint tsd_len; +static void **tsd; +#endif + +static ErlDrvTSDKey next_tsd_key; +static ErlDrvTSDKey max_used_tsd_key; +static ErlDrvTSDKey used_tsd_keys_len; +static char **used_tsd_keys; +static erts_mtx_t tsd_mtx; +static char *no_name; + +#ifdef USE_THREADS + +static void +thread_exit_handler(void) +{ + struct ErlDrvTid_ *dtid = ethr_tsd_get(tid_key); + if (dtid) { + if (dtid->tsd) + erts_free(ERTS_ALC_T_DRV_TSD, dtid->tsd); + if (!dtid->drv_thr) + erts_free(ERTS_ALC_T_DRV_TID, dtid); + } +} + +static void * +erl_drv_thread_wrapper(void *vdtid) +{ + int res; + struct ErlDrvTid_ *dtid = (struct ErlDrvTid_ *) vdtid; + res = ethr_tsd_set(tid_key, vdtid); + if (res != 0) + fatal_error(res, "erl_drv_thread_wrapper()"); + return (*dtid->func)(dtid->arg); +} + +#endif + +void erl_drv_thr_init(void) +{ + int i; +#ifdef USE_THREADS + int res = ethr_tsd_key_create(&tid_key); + if (res == 0) + res = ethr_install_exit_handler(thread_exit_handler); + if (res != 0) + fatal_error(res, "erl_drv_thr_init()"); +#else + tsd_len = 0; + tsd = NULL; +#endif + + no_name = "unknown"; + next_tsd_key = 0; + max_used_tsd_key = -1; + used_tsd_keys_len = ERL_DRV_TSD_KEYS_INC; + used_tsd_keys = erts_alloc(ERTS_ALC_T_DRV_TSD, + sizeof(char *)*ERL_DRV_TSD_KEYS_INC); + for (i = 0; i < ERL_DRV_TSD_KEYS_INC; i++) + used_tsd_keys[i] = NULL; + erts_mtx_init(&tsd_mtx, "drv_tsd"); +} + +/* + * These functions implement the driver thread interface in erl_driver.h. + * NOTE: Only use this interface from drivers. From within the emulator use + * either the erl_threads.h, the erl_smp.h or the ethread.h interface. + */ + +ErlDrvMutex * +erl_drv_mutex_create(char *name) +{ +#ifdef USE_THREADS + ErlDrvMutex *dmtx = erts_alloc_fnf(ERTS_ALC_T_DRV_MTX, + (sizeof(ErlDrvMutex) + + (name ? sys_strlen(name) + 1 : 0))); + if (dmtx) { + if (ethr_mutex_init(&dmtx->mtx) != 0) { + erts_free(ERTS_ALC_T_DRV_MTX, (void *) dmtx); + dmtx = NULL; + } + else if (!name) + dmtx->name = no_name; + else { + dmtx->name = ((char *) dmtx) + sizeof(ErlDrvMutex); + sys_strcpy(dmtx->name, name); + } + } + return dmtx; +#else + return (ErlDrvMutex *) NULL; +#endif +} + +void +erl_drv_mutex_destroy(ErlDrvMutex *dmtx) +{ +#ifdef USE_THREADS + int res = dmtx ? ethr_mutex_destroy(&dmtx->mtx) : EINVAL; + if (res != 0) + fatal_error(res, "erl_drv_mutex_destroy()"); + erts_free(ERTS_ALC_T_DRV_MTX, (void *) dmtx); +#endif +} + +int +erl_drv_mutex_trylock(ErlDrvMutex *dmtx) +{ +#ifdef USE_THREADS + int res = dmtx ? ethr_mutex_trylock(&dmtx->mtx) : EINVAL; + if (res != 0 && res != EBUSY) + fatal_error(res, "erl_drv_mutex_trylock()"); + return res; +#else + return 0; +#endif +} + +void +erl_drv_mutex_lock(ErlDrvMutex *dmtx) +{ +#ifdef USE_THREADS + int res = dmtx ? ethr_mutex_lock(&dmtx->mtx) : EINVAL; + if (res != 0) + fatal_error(res, "erl_drv_mutex_lock()"); +#endif +} + +void +erl_drv_mutex_unlock(ErlDrvMutex *dmtx) +{ +#ifdef USE_THREADS + int res = dmtx ? ethr_mutex_unlock(&dmtx->mtx) : EINVAL; + if (res != 0) + fatal_error(res, "erl_drv_mutex_unlock()"); +#endif +} + +ErlDrvCond * +erl_drv_cond_create(char *name) +{ +#ifdef USE_THREADS + ErlDrvCond *dcnd = erts_alloc_fnf(ERTS_ALC_T_DRV_CND, + (sizeof(ErlDrvCond) + + (name ? sys_strlen(name) + 1 : 0))); + if (dcnd) { + if (ethr_cond_init(&dcnd->cnd) != 0) { + erts_free(ERTS_ALC_T_DRV_CND, (void *) dcnd); + dcnd = NULL; + } + else if (!name) + dcnd->name = no_name; + else { + dcnd->name = ((char *) dcnd) + sizeof(ErlDrvCond); + sys_strcpy(dcnd->name, name); + } + } + return dcnd; +#else + return (ErlDrvCond *) NULL; +#endif +} + +void +erl_drv_cond_destroy(ErlDrvCond *dcnd) +{ +#ifdef USE_THREADS + int res = dcnd ? ethr_cond_destroy(&dcnd->cnd) : EINVAL; + if (res != 0) + fatal_error(res, "erl_drv_cond_destroy()"); + erts_free(ERTS_ALC_T_DRV_CND, (void *) dcnd); +#endif +} + + +void +erl_drv_cond_signal(ErlDrvCond *dcnd) +{ +#ifdef USE_THREADS + int res = dcnd ? ethr_cond_signal(&dcnd->cnd) : EINVAL; + if (res != 0) + fatal_error(res, "erl_drv_cond_signal()"); +#endif +} + +void +erl_drv_cond_broadcast(ErlDrvCond *dcnd) +{ +#ifdef USE_THREADS + int res = dcnd ? ethr_cond_broadcast(&dcnd->cnd) : EINVAL; + if (res != 0) + fatal_error(res, "erl_drv_cond_broadcast()"); +#endif +} + + +void +erl_drv_cond_wait(ErlDrvCond *dcnd, ErlDrvMutex *dmtx) +{ +#ifdef USE_THREADS + int res; + if (!dcnd || !dmtx) { + res = EINVAL; + error: + fatal_error(res, "erl_drv_cond_wait()"); + } + while (1) { + res = ethr_cond_wait(&dcnd->cnd, &dmtx->mtx); + if (res == 0) + break; + if (res != EINTR) + goto error; + } +#endif +} + +ErlDrvRWLock * +erl_drv_rwlock_create(char *name) +{ +#ifdef USE_THREADS + ErlDrvRWLock *drwlck = erts_alloc_fnf(ERTS_ALC_T_DRV_RWLCK, + (sizeof(ErlDrvRWLock) + + (name ? sys_strlen(name) + 1 : 0))); + if (drwlck) { + if (ethr_rwmutex_init(&drwlck->rwmtx) != 0) { + erts_free(ERTS_ALC_T_DRV_RWLCK, (void *) drwlck); + drwlck = NULL; + } + else if (!name) + drwlck->name = no_name; + else { + drwlck->name = ((char *) drwlck) + sizeof(ErlDrvRWLock); + sys_strcpy(drwlck->name, name); + } + } + return drwlck; +#else + return (ErlDrvRWLock *) NULL; +#endif +} + +void +erl_drv_rwlock_destroy(ErlDrvRWLock *drwlck) +{ +#ifdef USE_THREADS + int res = drwlck ? ethr_rwmutex_destroy(&drwlck->rwmtx) : EINVAL; + if (res != 0) + fatal_error(res, "erl_drv_rwlock_destroy()"); + erts_free(ERTS_ALC_T_DRV_RWLCK, (void *) drwlck); +#endif +} + +int +erl_drv_rwlock_tryrlock(ErlDrvRWLock *drwlck) +{ +#ifdef USE_THREADS + int res = drwlck ? ethr_rwmutex_tryrlock(&drwlck->rwmtx) : EINVAL; + if (res != 0 && res != EBUSY) + fatal_error(res, "erl_drv_rwlock_tryrlock()"); + return res; +#else + return 0; +#endif +} + +void +erl_drv_rwlock_rlock(ErlDrvRWLock *drwlck) +{ +#ifdef USE_THREADS + int res = drwlck ? ethr_rwmutex_rlock(&drwlck->rwmtx) : EINVAL; + if (res != 0) + fatal_error(res, "erl_drv_rwlock_rlock()"); +#endif +} + +void +erl_drv_rwlock_runlock(ErlDrvRWLock *drwlck) +{ +#ifdef USE_THREADS + int res = drwlck ? ethr_rwmutex_runlock(&drwlck->rwmtx) : EINVAL; + if (res != 0) + fatal_error(res, "erl_drv_rwlock_runlock()"); +#endif +} + +int +erl_drv_rwlock_tryrwlock(ErlDrvRWLock *drwlck) +{ +#ifdef USE_THREADS + int res = drwlck ? ethr_rwmutex_tryrwlock(&drwlck->rwmtx) : EINVAL; + if (res != 0 && res != EBUSY) + fatal_error(res, "erl_drv_rwlock_tryrwlock()"); + return res; +#else + return 0; +#endif +} + +void +erl_drv_rwlock_rwlock(ErlDrvRWLock *drwlck) +{ +#ifdef USE_THREADS + int res = drwlck ? ethr_rwmutex_rwlock(&drwlck->rwmtx) : EINVAL; + if (res != 0) + fatal_error(res, "erl_drv_rwlock_rwlock()"); +#endif +} + +void +erl_drv_rwlock_rwunlock(ErlDrvRWLock *drwlck) +{ +#ifdef USE_THREADS + int res = drwlck ? ethr_rwmutex_rwunlock(&drwlck->rwmtx) : EINVAL; + if (res != 0) + fatal_error(res, "erl_drv_rwlock_rwunlock()"); +#endif +} + +int +erl_drv_tsd_key_create(char *name, ErlDrvTSDKey *key) +{ + char *name_copy; + Uint old_used_tsd_keys_len; + ErlDrvTSDKey res; + + if (!key) + fatal_error(EINVAL, "erl_drv_tsd_key_create()"); + + if (!name) + name_copy = no_name; + else { + name_copy = erts_alloc_fnf(ERTS_ALC_T_DRV_TSD, + sizeof(char)*(strlen(name) + 1)); + if (!name_copy) { + *key = -1; + return ENOMEM; + } + sys_strcpy(name_copy, name); + } + + erts_mtx_lock(&tsd_mtx); + + *key = next_tsd_key; + + if (next_tsd_key < 0) + res = ENOMEM; + else { + res = 0; + + ASSERT(!used_tsd_keys[next_tsd_key]); + used_tsd_keys[next_tsd_key] = name_copy; + + if (max_used_tsd_key < next_tsd_key) + max_used_tsd_key = next_tsd_key; + + if (max_used_tsd_key + 1 >= used_tsd_keys_len) { + int i; + old_used_tsd_keys_len = used_tsd_keys_len; + if (used_tsd_keys_len + ERL_DRV_TSD_KEYS_INC >= INT_MAX) + next_tsd_key = -1; + else { + char **new_used_tsd_keys; + used_tsd_keys_len += ERL_DRV_TSD_KEYS_INC; + new_used_tsd_keys = erts_realloc_fnf(ERTS_ALC_T_DRV_TSD, + used_tsd_keys, + (sizeof(char *) + * used_tsd_keys_len)); + if (!new_used_tsd_keys) + next_tsd_key = -1; + else { + used_tsd_keys = new_used_tsd_keys; + for (i = old_used_tsd_keys_len; i < used_tsd_keys_len; i++) + used_tsd_keys[i] = NULL; + } + } + } + + if (next_tsd_key >= 0) { + do { + next_tsd_key++; + } while (used_tsd_keys[next_tsd_key]); + } + ASSERT(next_tsd_key < used_tsd_keys_len); + } + + erts_mtx_unlock(&tsd_mtx); + + return res; +} + +void +erl_drv_tsd_key_destroy(ErlDrvTSDKey key) +{ + erts_mtx_lock(&tsd_mtx); + + if (key < 0 || max_used_tsd_key < key || !used_tsd_keys[key]) + fatal_error(EINVAL, "erl_drv_tsd_key_destroy()"); + + if (used_tsd_keys[key] != no_name) + erts_free(ERTS_ALC_T_DRV_TSD, used_tsd_keys[key]); + + used_tsd_keys[key] = NULL; + if (next_tsd_key < 0 || key < next_tsd_key) + next_tsd_key = key; + + erts_mtx_unlock(&tsd_mtx); +} + + +#ifdef USE_THREADS +#define ERL_DRV_TSD__ (dtid->tsd) +#define ERL_DRV_TSD_LEN__ (dtid->tsd_len) +#else +#define ERL_DRV_TSD__ (tsd) +#define ERL_DRV_TSD_LEN__ (tsd_len) +#endif + +void +erl_drv_tsd_set(ErlDrvTSDKey key, void *data) +{ +#ifdef USE_THREADS + struct ErlDrvTid_ *dtid = (struct ErlDrvTid_ *) erl_drv_thread_self(); +#endif + + if (key < 0 || max_used_tsd_key < key || !used_tsd_keys[key]) + fatal_error(EINVAL, "erl_drv_tsd_set()"); + + if (!ERL_DRV_TSD__) { + ErlDrvTSDKey i; + ERL_DRV_TSD_LEN__ = key + ERL_DRV_TSD_EXTRA; + ERL_DRV_TSD__ = erts_alloc(ERTS_ALC_T_DRV_TSD, + sizeof(void *)*ERL_DRV_TSD_LEN__); + for (i = 0; i < ERL_DRV_TSD_LEN__; i++) + ERL_DRV_TSD__[i] = NULL; + } + else if (ERL_DRV_TSD_LEN__ <= key) { + ErlDrvTSDKey i = ERL_DRV_TSD_LEN__; + ERL_DRV_TSD_LEN__ = key + ERL_DRV_TSD_EXTRA; + ERL_DRV_TSD__ = erts_realloc(ERTS_ALC_T_DRV_TSD, + ERL_DRV_TSD__, + sizeof(void *)*ERL_DRV_TSD_LEN__); + for (; i < ERL_DRV_TSD_LEN__; i++) + ERL_DRV_TSD__[i] = NULL; + } + ERL_DRV_TSD__[key] = data; +} + +void * +erl_drv_tsd_get(ErlDrvTSDKey key) +{ +#ifdef USE_THREADS + struct ErlDrvTid_ *dtid = ethr_tsd_get(tid_key); +#endif + if (key < 0 || max_used_tsd_key < key || !used_tsd_keys[key]) + fatal_error(EINVAL, "erl_drv_tsd_get()"); +#ifdef USE_THREADS + if (!dtid) + return NULL; +#endif + if (ERL_DRV_TSD_LEN__ < key) + return NULL; + return ERL_DRV_TSD__[key]; +} + +#undef ERL_DRV_TSD_LEN__ +#undef ERL_DRV_TSD__ + +ErlDrvThreadOpts * +erl_drv_thread_opts_create(char *name) +{ + ErlDrvThreadOpts *opts = erts_alloc_fnf(ERTS_ALC_T_DRV_THR_OPTS, + sizeof(ErlDrvThreadOpts)); + if (!opts) + return NULL; + opts->suggested_stack_size = -1; + return opts; +} + +void +erl_drv_thread_opts_destroy(ErlDrvThreadOpts *opts) +{ + if (!opts) + fatal_error(EINVAL, "erl_drv_thread_opts_destroy()"); + erts_free(ERTS_ALC_T_DRV_THR_OPTS, opts); +} + +int +erl_drv_thread_create(char *name, + ErlDrvTid *tid, + void* (*func)(void*), + void* arg, + ErlDrvThreadOpts *opts) +{ +#ifdef USE_THREADS + int res; + struct ErlDrvTid_ *dtid; + ethr_thr_opts ethr_opts; + ethr_thr_opts *use_opts; + + if (!opts) + use_opts = NULL; + else { + sys_memcpy((void *) ðr_opts, + (void *) &def_ethr_opts, + sizeof(ethr_thr_opts)); + ethr_opts.suggested_stack_size = opts->suggested_stack_size; + use_opts = ðr_opts; + } + + dtid = erts_alloc_fnf(ERTS_ALC_T_DRV_TID, + (sizeof(struct ErlDrvTid_) + + (name ? sys_strlen(name) + 1 : 0))); + if (!dtid) + return ENOMEM; + + dtid->drv_thr = 1; + dtid->func = func; + dtid->arg = arg; + dtid->tsd = NULL; + dtid->tsd_len = 0; + if (!name) + dtid->name = no_name; + else { + dtid->name = ((char *) dtid) + sizeof(struct ErlDrvTid_); + sys_strcpy(dtid->name, name); + } +#ifdef ERTS_ENABLE_LOCK_COUNT + res = erts_lcnt_thr_create(&dtid->tid, erl_drv_thread_wrapper, dtid, use_opts); +#else + res = ethr_thr_create(&dtid->tid, erl_drv_thread_wrapper, dtid, use_opts); +#endif + + if (res != 0) { + erts_free(ERTS_ALC_T_DRV_TID, dtid); + return res; + } + + *tid = (ErlDrvTid) dtid; + return 0; +#else + return ENOTSUP; +#endif +} + +ErlDrvTid +erl_drv_thread_self(void) +{ +#ifdef USE_THREADS + struct ErlDrvTid_ *dtid = ethr_tsd_get(tid_key); + if (!dtid) { + int res; + /* This is a thread not spawned by this interface. thread_exit_handler() + will clean it up when it terminates. */ + dtid = erts_alloc(ERTS_ALC_T_DRV_TID, sizeof(struct ErlDrvTid_)); + dtid->drv_thr = 0; /* Not a driver thread */ + dtid->tid = ethr_self(); + dtid->func = NULL; + dtid->arg = NULL; + dtid->tsd = NULL; + dtid->tsd_len = 0; + dtid->name = no_name; + res = ethr_tsd_set(tid_key, (void *) dtid); + if (res != 0) + fatal_error(res, "erl_drv_thread_self()"); + } + return (ErlDrvTid) dtid; +#else + return (ErlDrvTid) NULL; +#endif +} + +int +erl_drv_equal_tids(ErlDrvTid tid1, ErlDrvTid tid2) +{ +#ifdef USE_THREADS + int res; + struct ErlDrvTid_ *dtid1 = (struct ErlDrvTid_ *) tid1; + struct ErlDrvTid_ *dtid2 = (struct ErlDrvTid_ *) tid2; + if (!dtid1 || !dtid2) + fatal_error(EINVAL, "erl_drv_equal_tids()"); + + res = dtid1 == dtid2; + + ASSERT(res + ? ethr_equal_tids(dtid1->tid, dtid2->tid) + : !ethr_equal_tids(dtid1->tid, dtid2->tid)); + + return res; +#else + return 1; +#endif +} + +void +erl_drv_thread_exit(void *res) +{ +#ifdef USE_THREADS + struct ErlDrvTid_ *dtid = ethr_tsd_get(tid_key); + if (dtid && dtid->drv_thr) { + ethr_thr_exit(res); + fatal_error(0, "erl_drv_thread_exit()"); + } +#endif + fatal_error(EACCES, "erl_drv_thread_exit()"); +} + +int +erl_drv_thread_join(ErlDrvTid tid, void **respp) +{ +#ifdef USE_THREADS + int res; + struct ErlDrvTid_ *dtid = (struct ErlDrvTid_ *) tid; + + ASSERT(dtid); + + if (!dtid->drv_thr) + return EINVAL; + + res = ethr_thr_join(dtid->tid, respp); + if (res == 0) + erts_free(ERTS_ALC_T_DRV_TID, dtid); + return res; +#else + return ENOTSUP; +#endif +} + diff --git a/erts/emulator/beam/erl_fun.c b/erts/emulator/beam/erl_fun.c new file mode 100644 index 0000000000..79e844b315 --- /dev/null +++ b/erts/emulator/beam/erl_fun.c @@ -0,0 +1,315 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2000-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "erl_fun.h" +#include "hash.h" + +static Hash erts_fun_table; + +#include "erl_smp.h" + +static erts_smp_rwmtx_t erts_fun_table_lock; + +#define erts_fun_read_lock() erts_smp_rwmtx_rlock(&erts_fun_table_lock) +#define erts_fun_read_unlock() erts_smp_rwmtx_runlock(&erts_fun_table_lock) +#define erts_fun_write_lock() erts_smp_rwmtx_rwlock(&erts_fun_table_lock) +#define erts_fun_write_unlock() erts_smp_rwmtx_rwunlock(&erts_fun_table_lock) +#define erts_fun_init_lock() erts_smp_rwmtx_init(&erts_fun_table_lock, \ + "fun_tab") + +static HashValue fun_hash(ErlFunEntry* obj); +static int fun_cmp(ErlFunEntry* obj1, ErlFunEntry* obj2); +static ErlFunEntry* fun_alloc(ErlFunEntry* template); +static void fun_free(ErlFunEntry* obj); + +/* + * The address field of every fun that has no loaded code will point + * to unloaded_fun[]. The -1 in unloaded_fun[0] will be interpreted + * as an illegal arity when attempting to call a fun. + */ +static Eterm unloaded_fun_code[3] = {NIL, -1, 0}; +static Eterm* unloaded_fun = unloaded_fun_code + 2; + +void +erts_init_fun_table(void) +{ + HashFunctions f; + + erts_fun_init_lock(); + f.hash = (H_FUN) fun_hash; + f.cmp = (HCMP_FUN) fun_cmp; + f.alloc = (HALLOC_FUN) fun_alloc; + f.free = (HFREE_FUN) fun_free; + + hash_init(ERTS_ALC_T_FUN_TABLE, &erts_fun_table, "fun_table", 16, f); +} + +void +erts_fun_info(int to, void *to_arg) +{ + int lock = !ERTS_IS_CRASH_DUMPING; + if (lock) + erts_fun_read_lock(); + hash_info(to, to_arg, &erts_fun_table); + if (lock) + erts_fun_read_unlock(); +} + +int erts_fun_table_sz(void) +{ + int sz; + int lock = !ERTS_IS_CRASH_DUMPING; + if (lock) + erts_fun_read_lock(); + sz = hash_table_sz(&erts_fun_table); + if (lock) + erts_fun_read_unlock(); + return sz; +} + +ErlFunEntry* +erts_put_fun_entry(Eterm mod, int uniq, int index) +{ + ErlFunEntry template; + ErlFunEntry* fe; + long refc; + ASSERT(is_atom(mod)); + template.old_uniq = uniq; + template.old_index = index; + template.module = mod; + erts_fun_write_lock(); + fe = (ErlFunEntry *) hash_put(&erts_fun_table, (void*) &template); + sys_memset(fe->uniq, 0, sizeof(fe->uniq)); + fe->index = 0; + refc = erts_refc_inctest(&fe->refc, 0); + if (refc < 2) /* New or pending delete */ + erts_refc_inc(&fe->refc, 1); + erts_fun_write_unlock(); + return fe; +} + +ErlFunEntry* +erts_put_fun_entry2(Eterm mod, int old_uniq, int old_index, + byte* uniq, int index, int arity) +{ + ErlFunEntry template; + ErlFunEntry* fe; + long refc; + + ASSERT(is_atom(mod)); + template.old_uniq = old_uniq; + template.old_index = old_index; + template.module = mod; + erts_fun_write_lock(); + fe = (ErlFunEntry *) hash_put(&erts_fun_table, (void*) &template); + sys_memcpy(fe->uniq, uniq, sizeof(fe->uniq)); + fe->index = index; + fe->arity = arity; + refc = erts_refc_inctest(&fe->refc, 0); + if (refc < 2) /* New or pending delete */ + erts_refc_inc(&fe->refc, 1); + erts_fun_write_unlock(); + return fe; +} + +struct my_key { + Eterm mod; + byte* uniq; + int index; + ErlFunEntry* fe; +}; + +ErlFunEntry* +erts_get_fun_entry(Eterm mod, int uniq, int index) +{ + ErlFunEntry template; + ErlFunEntry *ret; + + ASSERT(is_atom(mod)); + template.old_uniq = uniq; + template.old_index = index; + template.module = mod; + erts_fun_read_lock(); + ret = (ErlFunEntry *) hash_get(&erts_fun_table, (void*) &template); + if (ret) { + long refc = erts_refc_inctest(&ret->refc, 1); + if (refc < 2) /* Pending delete */ + erts_refc_inc(&ret->refc, 1); + } + erts_fun_read_unlock(); + return ret; +} + +static void +erts_erase_fun_entry_unlocked(ErlFunEntry* fe) +{ + hash_erase(&erts_fun_table, (void *) fe); +} + +void +erts_erase_fun_entry(ErlFunEntry* fe) +{ + erts_fun_write_lock(); +#ifdef ERTS_SMP + /* + * We have to check refc again since someone might have looked up + * the fun entry and incremented refc after last check. + */ + if (erts_refc_dectest(&fe->refc, -1) <= 0) +#endif + { + if (fe->address != unloaded_fun) + erl_exit(1, + "Internal error: " + "Invalid reference count found on #Fun<%T.%d.%d>: " + " About to erase fun still referred by code.\n", + fe->module, fe->old_index, fe->old_uniq); + erts_erase_fun_entry_unlocked(fe); + } + erts_fun_write_unlock(); +} + +#ifndef HYBRID /* FIND ME! */ +void +erts_cleanup_funs(ErlFunThing* funp) +{ + while (funp) { + ErlFunEntry* fe = funp->fe; + if (erts_refc_dectest(&fe->refc, 0) == 0) { + erts_erase_fun_entry(fe); + } + funp = funp->next; + } +} +#endif + +void +erts_cleanup_funs_on_purge(Eterm* start, Eterm* end) +{ + int limit; + HashBucket** bucket; + ErlFunEntry* to_delete = NULL; + int i; + + erts_fun_write_lock(); + limit = erts_fun_table.size; + bucket = erts_fun_table.bucket; + for (i = 0; i < limit; i++) { + HashBucket* b = bucket[i]; + + while (b) { + ErlFunEntry* fe = (ErlFunEntry *) b; + Eterm* addr = fe->address; + + if (start <= addr && addr < end) { + fe->address = unloaded_fun; + if (erts_refc_dectest(&fe->refc, 0) == 0) { + fe->address = (void *) to_delete; + to_delete = fe; + } + } + b = b->next; + } + } + + while (to_delete != NULL) { + ErlFunEntry* next = (ErlFunEntry *) to_delete->address; + erts_erase_fun_entry_unlocked(to_delete); + to_delete = next; + } + erts_fun_write_unlock(); +} + +void +erts_dump_fun_entries(int to, void *to_arg) +{ + int limit; + HashBucket** bucket; + int i; + int lock = !ERTS_IS_CRASH_DUMPING; + + + if (lock) + erts_fun_read_lock(); + limit = erts_fun_table.size; + bucket = erts_fun_table.bucket; + for (i = 0; i < limit; i++) { + HashBucket* b = bucket[i]; + + while (b) { + ErlFunEntry* fe = (ErlFunEntry *) b; + erts_print(to, to_arg, "=fun\n"); + erts_print(to, to_arg, "Module: %T\n", fe->module); + erts_print(to, to_arg, "Uniq: %d\n", fe->old_uniq); + erts_print(to, to_arg, "Index: %d\n",fe->old_index); + erts_print(to, to_arg, "Address: %p\n", fe->address); +#ifdef HIPE + erts_print(to, to_arg, "Native_address: %p\n", fe->native_address); +#endif + erts_print(to, to_arg, "Refc: %d\n", erts_refc_read(&fe->refc, 1)); + b = b->next; + } + } + if (lock) + erts_fun_read_unlock(); +} + +static HashValue +fun_hash(ErlFunEntry* obj) +{ + return (HashValue) (obj->old_uniq ^ obj->old_index ^ atom_val(obj->module)); +} + +static int +fun_cmp(ErlFunEntry* obj1, ErlFunEntry* obj2) +{ + return !(obj1->module == obj2->module && + obj1->old_uniq == obj2->old_uniq && + obj1->old_index == obj2->old_index); +} + +static ErlFunEntry* +fun_alloc(ErlFunEntry* template) +{ + ErlFunEntry* obj = (ErlFunEntry *) erts_alloc(ERTS_ALC_T_FUN_ENTRY, + sizeof(ErlFunEntry)); + + obj->old_uniq = template->old_uniq; + obj->old_index = template->old_index; + obj->module = template->module; + erts_refc_init(&obj->refc, -1); + obj->address = unloaded_fun; +#ifdef HIPE + obj->native_address = NULL; +#endif + return obj; +} + +static void +fun_free(ErlFunEntry* obj) +{ + erts_free(ERTS_ALC_T_FUN_ENTRY, (void *) obj); +} diff --git a/erts/emulator/beam/erl_fun.h b/erts/emulator/beam/erl_fun.h new file mode 100644 index 0000000000..fb5e75649b --- /dev/null +++ b/erts/emulator/beam/erl_fun.h @@ -0,0 +1,92 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2000-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifndef __ERLFUNTABLE_H__ +#define __ERLFUNTABLE_H__ + +#include "erl_smp.h" + +/* + * Fun entry. + */ + +typedef struct erl_fun_entry { + HashBucket bucket; /* MUST BE LOCATED AT TOP OF STRUCT!!! */ + + byte uniq[16]; /* MD5 for module. */ + int index; /* New style index. */ + int old_uniq; /* Unique number (old_style) */ + int old_index; /* Old style index */ + Eterm* address; /* Pointer to code for fun */ + +#ifdef HIPE + Eterm* native_address; /* Native entry code for fun. */ +#endif + + Uint arity; /* The arity of the fun. */ + Eterm module; /* Tagged atom for module. */ + erts_refc_t refc; /* Reference count: One for code + one for each + fun object in each process. */ +} ErlFunEntry; + +/* + * This structure represents a 'fun' (lambda). It is stored on + * process heaps. It has variable size depending on the size + * of the environment. + */ + +typedef struct erl_fun_thing { + Eterm thing_word; /* Subtag FUN_SUBTAG. */ +#ifndef HYBRID /* FIND ME! */ + struct erl_fun_thing* next; /* Next fun in mso list. */ +#endif + ErlFunEntry* fe; /* Pointer to fun entry. */ +#ifdef HIPE + Eterm* native_address; /* Native code for the fun. */ +#endif + Uint arity; /* The arity of the fun. */ + Uint num_free; /* Number of free variables (in env). */ + /* -- The following may be compound Erlang terms ---------------------- */ + Eterm creator; /* Pid of creator process (contains node). */ + Eterm env[1]; /* Environment (free variables). */ +} ErlFunThing; + +/* ERL_FUN_SIZE does _not_ include space for the environment */ +#define ERL_FUN_SIZE ((sizeof(ErlFunThing)/sizeof(Eterm))-1) + +void erts_init_fun_table(void); +void erts_fun_info(int, void *); +int erts_fun_table_sz(void); + +ErlFunEntry* erts_put_fun_entry(Eterm mod, int uniq, int index); +ErlFunEntry* erts_get_fun_entry(Eterm mod, int uniq, int index); + +ErlFunEntry* erts_put_fun_entry2(Eterm mod, int old_uniq, int old_index, + byte* uniq, int index, int arity); +ErlFunEntry* erts_get_fun_entry2(Eterm mod, int old_uniq, int old_index, + byte* uniq, int index, int arity); + +void erts_erase_fun_entry(ErlFunEntry* fe); +#ifndef HYBRID /* FIND ME! */ +void erts_cleanup_funs(ErlFunThing* funp); +#endif +void erts_cleanup_funs_on_purge(Eterm* start, Eterm* end); +void erts_dump_fun_entries(int, void *); + +#endif diff --git a/erts/emulator/beam/erl_gc.c b/erts/emulator/beam/erl_gc.c new file mode 100644 index 0000000000..6945317e65 --- /dev/null +++ b/erts/emulator/beam/erl_gc.c @@ -0,0 +1,2690 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2002-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "erl_process.h" +#include "erl_db.h" +#include "beam_catches.h" +#include "erl_binary.h" +#include "erl_bits.h" +#include "error.h" +#include "big.h" +#include "erl_gc.h" +#if HIPE +#include "hipe_stack.h" +#endif + +#define ERTS_INACT_WR_PB_LEAVE_MUCH_LIMIT 1 +#define ERTS_INACT_WR_PB_LEAVE_MUCH_PERCENTAGE 20 +#define ERTS_INACT_WR_PB_LEAVE_LIMIT 10 +#define ERTS_INACT_WR_PB_LEAVE_PERCENTAGE 10 + +/* + * Returns number of elements in an array. + */ +#define ALENGTH(a) (sizeof(a)/sizeof(a[0])) + +static erts_smp_spinlock_t info_lck; +static Uint garbage_cols; /* no of garbage collections */ +static Uint reclaimed; /* no of words reclaimed in GCs */ + +# define STACK_SZ_ON_HEAP(p) ((p)->hend - (p)->stop) +# define OverRunCheck(P) \ + if ((P)->stop < (P)->htop) { \ + erts_fprintf(stderr, "hend=%p\n", (p)->hend); \ + erts_fprintf(stderr, "stop=%p\n", (p)->stop); \ + erts_fprintf(stderr, "htop=%p\n", (p)->htop); \ + erts_fprintf(stderr, "heap=%p\n", (p)->heap); \ + erl_exit(ERTS_ABORT_EXIT, "%s, line %d: %T: Overrun stack and heap\n", \ + __FILE__,__LINE__,(P)->id); \ + } + +#ifdef DEBUG +#define ErtsGcQuickSanityCheck(P) \ +do { \ + ASSERT((P)->heap < (P)->hend); \ + ASSERT((P)->heap_sz == (P)->hend - (P)->heap); \ + ASSERT((P)->heap <= (P)->htop && (P)->htop <= (P)->hend); \ + ASSERT((P)->heap <= (P)->stop && (P)->stop <= (P)->hend); \ + ASSERT((P)->heap <= (P)->high_water && (P)->high_water <= (P)->hend);\ + OverRunCheck((P)); \ +} while (0) +#else +#define ErtsGcQuickSanityCheck(P) \ +do { \ + OverRunCheck((P)); \ +} while (0) +#endif +/* + * This structure describes the rootset for the GC. + */ +typedef struct roots { + Eterm* v; /* Pointers to vectors with terms to GC + * (e.g. the stack). + */ + Uint sz; /* Size of each vector. */ +} Roots; + +typedef struct { + Roots def[32]; /* Default storage. */ + Roots* roots; /* Pointer to root set array. */ + Uint size; /* Storage size. */ + int num_roots; /* Number of root arrays. */ +} Rootset; + +static Uint setup_rootset(Process*, Eterm*, int, Rootset*); +static void cleanup_rootset(Rootset *rootset); +static Uint combined_message_size(Process* p); +static void remove_message_buffers(Process* p); +static int major_collection(Process* p, int need, Eterm* objv, int nobj, Uint *recl); +static int minor_collection(Process* p, int need, Eterm* objv, int nobj, Uint *recl); +static void do_minor(Process *p, int new_sz, Eterm* objv, int nobj); +static Eterm* sweep_rootset(Rootset *rootset, Eterm* htop, char* src, Uint src_size); +static Eterm* sweep_one_area(Eterm* n_hp, Eterm* n_htop, char* src, Uint src_size); +static Eterm* sweep_one_heap(Eterm* heap_ptr, Eterm* heap_end, Eterm* htop, + char* src, Uint src_size); +static Eterm* collect_heap_frags(Process* p, Eterm* heap, + Eterm* htop, Eterm* objv, int nobj); +static Uint adjust_after_fullsweep(Process *p, int size_before, + int need, Eterm *objv, int nobj); +static void shrink_new_heap(Process *p, Uint new_sz, Eterm *objv, int nobj); +static void grow_new_heap(Process *p, Uint new_sz, Eterm* objv, int nobj); +static void sweep_proc_bins(Process *p, int fullsweep); +static void sweep_proc_funs(Process *p, int fullsweep); +static void sweep_proc_externals(Process *p, int fullsweep); +static void offset_heap(Eterm* hp, Uint sz, Sint offs, char* area, Uint area_size); +static void offset_heap_ptr(Eterm* hp, Uint sz, Sint offs, char* area, Uint area_size); +static void offset_rootset(Process *p, Sint offs, char* area, Uint area_size, + Eterm* objv, int nobj); +static void offset_off_heap(Process* p, Sint offs, char* area, Uint area_size); +static void offset_mqueue(Process *p, Sint offs, char* area, Uint area_size); + +#ifdef HARDDEBUG +static void disallow_heap_frag_ref_in_heap(Process* p); +static void disallow_heap_frag_ref_in_old_heap(Process* p); +static void disallow_heap_frag_ref(Process* p, Eterm* n_htop, Eterm* objv, int nobj); +#endif + +#ifdef ARCH_64 +# define MAX_HEAP_SIZES 154 +#else +# define MAX_HEAP_SIZES 55 +#endif + +static Sint heap_sizes[MAX_HEAP_SIZES]; /* Suitable heap sizes. */ +static int num_heap_sizes; /* Number of heap sizes. */ + +Uint erts_test_long_gc_sleep; /* Only used for testing... */ + +/* + * Initialize GC global data. + */ +void +erts_init_gc(void) +{ + int i = 0; + + erts_smp_spinlock_init(&info_lck, "gc_info"); + garbage_cols = 0; + reclaimed = 0; + erts_test_long_gc_sleep = 0; + + /* + * Heap sizes start growing in a Fibonacci sequence. + * + * Fib growth is not really ok for really large heaps, for + * example is fib(35) == 14meg, whereas fib(36) == 24meg; + * we really don't want that growth when the heaps are that big. + */ + + heap_sizes[0] = 34; + heap_sizes[1] = 55; + for (i = 2; i < 23; i++) { + heap_sizes[i] = heap_sizes[i-1] + heap_sizes[i-2]; + } + + /* At 1.3 mega words heap, we start to slow down. */ + for (i = 23; i < ALENGTH(heap_sizes); i++) { + heap_sizes[i] = 5*(heap_sizes[i-1]/4); + if (heap_sizes[i] < 0) { + /* Size turned negative. Discard this last size. */ + i--; + break; + } + } + num_heap_sizes = i; +} + +/* + * Find the next heap size equal to or greater than the given size (if offset == 0). + * + * If offset is 1, the next higher heap size is returned (always greater than size). + */ +Uint +erts_next_heap_size(Uint size, Uint offset) +{ + if (size < heap_sizes[0]) { + return heap_sizes[0]; + } else { + Sint* low = heap_sizes; + Sint* high = heap_sizes + num_heap_sizes; + Sint* mid; + + while (low < high) { + mid = low + (high-low) / 2; + if (size < mid[0]) { + high = mid; + } else if (size == mid[0]) { + ASSERT(mid+offset-heap_sizes < num_heap_sizes); + return mid[offset]; + } else if (size < mid[1]) { + ASSERT(mid[0] < size && size <= mid[1]); + ASSERT(mid+offset-heap_sizes < num_heap_sizes); + return mid[offset+1]; + } else { + low = mid + 1; + } + } + erl_exit(1, "no next heap size found: %d, offset %d\n", size, offset); + } + return 0; +} +/* + * Return the next heap size to use. Make sure we never return + * a smaller heap size than the minimum heap size for the process. + * (Use of the erlang:hibernate/3 BIF could have shrinked the + * heap below the minimum heap size.) + */ +static Uint +next_heap_size(Process* p, Uint size, Uint offset) +{ + size = erts_next_heap_size(size, offset); + return size < p->min_heap_size ? p->min_heap_size : size; +} + +Eterm +erts_heap_sizes(Process* p) +{ + int i; + int n = 0; + int big = 0; + Eterm res = NIL; + Eterm* hp; + Eterm* bigp; + + for (i = num_heap_sizes-1; i >= 0; i--) { + n += 2; + if (!MY_IS_SSMALL(heap_sizes[i])) { + big += BIG_UINT_HEAP_SIZE; + } + } + + /* + * We store all big numbers first on the heap, followed + * by all the cons cells. + */ + bigp = HAlloc(p, n+big); + hp = bigp+big; + for (i = num_heap_sizes-1; i >= 0; i--) { + Eterm num; + Sint sz = heap_sizes[i]; + + if (MY_IS_SSMALL(sz)) { + num = make_small(sz); + } else { + num = uint_to_big(sz, bigp); + bigp += BIG_UINT_HEAP_SIZE; + } + res = CONS(hp, num, res); + hp += 2; + } + return res; +} + +void +erts_gc_info(ErtsGCInfo *gcip) +{ + if (gcip) { + erts_smp_spin_lock(&info_lck); + gcip->garbage_collections = garbage_cols; + gcip->reclaimed = reclaimed; + erts_smp_spin_unlock(&info_lck); + } +} + +void +erts_offset_heap(Eterm* hp, Uint sz, Sint offs, Eterm* low, Eterm* high) +{ + offset_heap(hp, sz, offs, (char*) low, ((char *)high)-((char *)low)); +} + +void +erts_offset_heap_ptr(Eterm* hp, Uint sz, Sint offs, + Eterm* low, Eterm* high) +{ + offset_heap_ptr(hp, sz, offs, (char *) low, ((char *)high)-((char *)low)); +} + +#define ptr_within(ptr, low, high) ((ptr) < (high) && (ptr) >= (low)) + +void +erts_offset_off_heap(ErlOffHeap *ohp, Sint offs, Eterm* low, Eterm* high) +{ + if (ohp->mso && ptr_within((Eterm *)ohp->mso, low, high)) { + Eterm** uptr = (Eterm**) (void *) &ohp->mso; + *uptr += offs; + } + +#ifndef HYBRID /* FIND ME! */ + if (ohp->funs && ptr_within((Eterm *)ohp->funs, low, high)) { + Eterm** uptr = (Eterm**) (void *) &ohp->funs; + *uptr += offs; + } +#endif + + if (ohp->externals && ptr_within((Eterm *)ohp->externals, low, high)) { + Eterm** uptr = (Eterm**) (void *) &ohp->externals; + *uptr += offs; + } +} +#undef ptr_within + +Eterm +erts_gc_after_bif_call(Process* p, Eterm result, Eterm* regs, Uint arity) +{ + int cost; + + if (is_non_value(result)) { + if (p->freason == TRAP) { + cost = erts_garbage_collect(p, 0, p->def_arg_reg, p->arity); + } else { + cost = erts_garbage_collect(p, 0, regs, arity); + } + } else { + Eterm val[1]; + + val[0] = result; + cost = erts_garbage_collect(p, 0, val, 1); + result = val[0]; + } + BUMP_REDS(p, cost); + return result; +} + +/* + * Garbage collect a process. + * + * p: Pointer to the process structure. + * need: Number of Eterm words needed on the heap. + * objv: Array of terms to add to rootset; that is to preserve. + * nobj: Number of objects in objv. + */ +int +erts_garbage_collect(Process* p, int need, Eterm* objv, int nobj) +{ + Uint reclaimed_now = 0; + int done = 0; + Uint ms1, s1, us1; + + if (IS_TRACED_FL(p, F_TRACE_GC)) { + trace_gc(p, am_gc_start); + } + + erts_smp_proc_lock(p, ERTS_PROC_LOCK_STATUS); + p->gcstatus = p->status; + p->status = P_GARBING; + if (erts_system_monitor_long_gc != 0) { + get_now(&ms1, &s1, &us1); + } + erts_smp_proc_unlock(p, ERTS_PROC_LOCK_STATUS); + + erts_smp_locked_activity_begin(ERTS_ACTIVITY_GC); + + ERTS_CHK_OFFHEAP(p); + + ErtsGcQuickSanityCheck(p); + if (GEN_GCS(p) >= MAX_GEN_GCS(p)) { + FLAGS(p) |= F_NEED_FULLSWEEP; + } + + /* + * Test which type of GC to do. + */ + while (!done) { + if ((FLAGS(p) & F_NEED_FULLSWEEP) != 0) { + done = major_collection(p, need, objv, nobj, &reclaimed_now); + } else { + done = minor_collection(p, need, objv, nobj, &reclaimed_now); + } + } + + /* + * Finish. + */ + + ERTS_CHK_OFFHEAP(p); + + ErtsGcQuickSanityCheck(p); + + erts_smp_proc_lock(p, ERTS_PROC_LOCK_STATUS); + p->status = p->gcstatus; + erts_smp_proc_unlock(p, ERTS_PROC_LOCK_STATUS); + if (IS_TRACED_FL(p, F_TRACE_GC)) { + trace_gc(p, am_gc_end); + } + + erts_smp_locked_activity_end(ERTS_ACTIVITY_GC); + + if (erts_system_monitor_long_gc != 0) { + Uint ms2, s2, us2; + Sint t; + if (erts_test_long_gc_sleep) + while (0 != erts_milli_sleep(erts_test_long_gc_sleep)); + get_now(&ms2, &s2, &us2); + t = ms2 - ms1; + t = t*1000000 + s2 - s1; + t = t*1000 + ((Sint) (us2 - us1))/1000; + if (t > 0 && (Uint)t > erts_system_monitor_long_gc) { + monitor_long_gc(p, t); + } + } + if (erts_system_monitor_large_heap != 0) { + Uint size = HEAP_SIZE(p); + size += OLD_HEAP(p) ? OLD_HEND(p) - OLD_HEAP(p) : 0; + if (size >= erts_system_monitor_large_heap) + monitor_large_heap(p); + } + + erts_smp_spin_lock(&info_lck); + garbage_cols++; + reclaimed += reclaimed_now; + erts_smp_spin_unlock(&info_lck); + + FLAGS(p) &= ~F_FORCE_GC; + +#ifdef CHECK_FOR_HOLES + /* + * We intentionally do not rescan the areas copied by the GC. + * We trust the GC not to leave any holes. + */ + p->last_htop = p->htop; + p->last_mbuf = 0; +#endif + +#ifdef DEBUG + /* + * The scanning for pointers from the old_heap into the new_heap or + * heap fragments turned out to be costly, so we remember how far we + * have scanned this time and will start scanning there next time. + * (We will not detect wild writes into the old heap, or modifications + * of the old heap in-between garbage collections.) + */ + p->last_old_htop = p->old_htop; +#endif + + return ((int) (HEAP_TOP(p) - HEAP_START(p)) / 10); +} + +/* + * Place all living data on a the new heap; deallocate any old heap. + * Meant to be used by hibernate/3. + */ +void +erts_garbage_collect_hibernate(Process* p) +{ + Uint heap_size; + Eterm* heap; + Eterm* htop; + Rootset rootset; + int n; + char* src; + Uint src_size; + Uint actual_size; + char* area; + Uint area_size; + Sint offs; + + /* + * Preliminaries. + */ + erts_smp_proc_lock(p, ERTS_PROC_LOCK_STATUS); + p->gcstatus = p->status; + p->status = P_GARBING; + erts_smp_proc_unlock(p, ERTS_PROC_LOCK_STATUS); + erts_smp_locked_activity_begin(ERTS_ACTIVITY_GC); + ErtsGcQuickSanityCheck(p); + ASSERT(p->mbuf_sz == 0); + ASSERT(p->mbuf == 0); + ASSERT(p->stop == p->hend); /* Stack must be empty. */ + + /* + * Do it. + */ + + + heap_size = p->heap_sz + (p->old_htop - p->old_heap); + heap = (Eterm*) ERTS_HEAP_ALLOC(ERTS_ALC_T_TMP_HEAP, + sizeof(Eterm)*heap_size); + htop = heap; + + n = setup_rootset(p, p->arg_reg, p->arity, &rootset); + + src = (char *) p->heap; + src_size = (char *) p->htop - src; + htop = sweep_rootset(&rootset, htop, src, src_size); + htop = sweep_one_area(heap, htop, src, src_size); + + if (p->old_heap) { + src = (char *) p->old_heap; + src_size = (char *) p->old_htop - src; + htop = sweep_rootset(&rootset, htop, src, src_size); + htop = sweep_one_area(heap, htop, src, src_size); + } + + cleanup_rootset(&rootset); + + if (MSO(p).mso) { + sweep_proc_bins(p, 1); + } + if (MSO(p).funs) { + sweep_proc_funs(p, 1); + } + if (MSO(p).externals) { + sweep_proc_externals(p, 1); + } + + /* + * Update all pointers. + */ + ERTS_HEAP_FREE(ERTS_ALC_T_HEAP, + (void*)HEAP_START(p), + HEAP_SIZE(p) * sizeof(Eterm)); + if (p->old_heap) { + ERTS_HEAP_FREE(ERTS_ALC_T_OLD_HEAP, + (void*)p->old_heap, + (p->old_hend - p->old_heap) * sizeof(Eterm)); + p->old_heap = p->old_htop = p->old_hend = 0; + } + + p->heap = heap; + p->high_water = htop; + p->htop = htop; + p->hend = p->heap + heap_size; + p->stop = p->hend; + p->heap_sz = heap_size; + + heap_size = actual_size = p->htop - p->heap; + if (heap_size == 0) { + heap_size = 1; /* We want a heap... */ + } + + FLAGS(p) &= ~F_FORCE_GC; + + /* + * Move the heap to its final destination. + * + * IMPORTANT: We have garbage collected to a temporary heap and + * then copy the result to a newly allocated heap of exact size. + * This is intentional and important! Garbage collecting as usual + * and then shrinking the heap by reallocating it caused serious + * fragmentation problems when large amounts of processes were + * hibernated. + */ + + ASSERT(p->hend - p->stop == 0); /* Empty stack */ + ASSERT(actual_size < p->heap_sz); + + heap = ERTS_HEAP_ALLOC(ERTS_ALC_T_HEAP, sizeof(Eterm)*heap_size); + sys_memcpy((void *) heap, (void *) p->heap, actual_size*sizeof(Eterm)); + ERTS_HEAP_FREE(ERTS_ALC_T_TMP_HEAP, p->heap, p->heap_sz*sizeof(Eterm)); + + p->stop = p->hend = heap + heap_size; + + offs = heap - p->heap; + area = (char *) p->heap; + area_size = ((char *) p->htop) - area; + offset_heap(heap, actual_size, offs, area, area_size); + p->high_water = heap + (p->high_water - p->heap); + offset_rootset(p, offs, area, area_size, p->arg_reg, p->arity); + p->htop = heap + actual_size; + p->heap = heap; + p->heap_sz = heap_size; + + +#ifdef CHECK_FOR_HOLES + p->last_htop = p->htop; + p->last_mbuf = 0; +#endif +#ifdef DEBUG + p->last_old_htop = NULL; +#endif + + /* + * Finishing. + */ + + ErtsGcQuickSanityCheck(p); + + erts_smp_proc_lock(p, ERTS_PROC_LOCK_STATUS); + p->status = p->gcstatus; + erts_smp_proc_unlock(p, ERTS_PROC_LOCK_STATUS); + erts_smp_locked_activity_end(ERTS_ACTIVITY_GC); +} + + +void +erts_garbage_collect_literals(Process* p, Eterm* literals, Uint lit_size) +{ + Uint byte_lit_size = sizeof(Eterm)*lit_size; + Uint old_heap_size; + Eterm* temp_lit; + Sint offs; + Rootset rootset; /* Rootset for GC (stack, dictionary, etc). */ + Roots* roots; + char* area; + Uint area_size; + Eterm* old_htop; + int n; + + /* + * Set GC state. + */ + erts_smp_proc_lock(p, ERTS_PROC_LOCK_STATUS); + p->gcstatus = p->status; + p->status = P_GARBING; + erts_smp_proc_unlock(p, ERTS_PROC_LOCK_STATUS); + erts_smp_locked_activity_begin(ERTS_ACTIVITY_GC); + + /* + * We assume that the caller has already done a major collection + * (which has discarded the old heap), so that we don't have to cope + * with pointer to literals on the old heap. We will now allocate + * an old heap to contain the literals. + */ + + ASSERT(p->old_heap == 0); /* Must NOT have an old heap yet. */ + old_heap_size = erts_next_heap_size(lit_size, 0); + p->old_heap = p->old_htop = (Eterm*) ERTS_HEAP_ALLOC(ERTS_ALC_T_OLD_HEAP, + sizeof(Eterm)*old_heap_size); + p->old_hend = p->old_heap + old_heap_size; + + /* + * We soon want to garbage collect the literals. But since a GC is + * destructive (MOVED markers are written), we must copy the literals + * to a temporary area and change all references to literals. + */ + temp_lit = (Eterm *) erts_alloc(ERTS_ALC_T_TMP, byte_lit_size); + sys_memcpy(temp_lit, literals, byte_lit_size); + offs = temp_lit - literals; + offset_heap(temp_lit, lit_size, offs, (char *) literals, byte_lit_size); + offset_heap(p->heap, p->htop - p->heap, offs, (char *) literals, byte_lit_size); + offset_rootset(p, offs, (char *) literals, byte_lit_size, p->arg_reg, p->arity); + + /* + * Now the literals are placed in memory that is safe to write into, + * so now we GC the literals into the old heap. First we go through the + * rootset. + */ + + area = (char *) temp_lit; + area_size = byte_lit_size; + n = setup_rootset(p, p->arg_reg, p->arity, &rootset); + roots = rootset.roots; + old_htop = p->old_htop; + while (n--) { + Eterm* g_ptr = roots->v; + Uint g_sz = roots->sz; + Eterm* ptr; + Eterm val; + + roots++; + + while (g_sz--) { + Eterm gval = *g_ptr; + + switch (primary_tag(gval)) { + case TAG_PRIMARY_BOXED: + ptr = boxed_val(gval); + val = *ptr; + if (IS_MOVED(val)) { + ASSERT(is_boxed(val)); + *g_ptr++ = val; + } else if (in_area(ptr, area, area_size)) { + MOVE_BOXED(ptr,val,old_htop,g_ptr++); + } else { + g_ptr++; + } + break; + case TAG_PRIMARY_LIST: + ptr = list_val(gval); + val = *ptr; + if (is_non_value(val)) { /* Moved */ + *g_ptr++ = ptr[1]; + } else if (in_area(ptr, area, area_size)) { + MOVE_CONS(ptr,val,old_htop,g_ptr++); + } else { + g_ptr++; + } + break; + default: + g_ptr++; + break; + } + } + } + ASSERT(p->old_htop <= old_htop && old_htop <= p->old_hend); + cleanup_rootset(&rootset); + + /* + * Now all references in the rootset to the literals have been updated. + * Now we'll have to go through all heaps updating all other references. + */ + + old_htop = sweep_one_heap(p->heap, p->htop, old_htop, area, area_size); + old_htop = sweep_one_area(p->old_heap, old_htop, area, area_size); + ASSERT(p->old_htop <= old_htop && old_htop <= p->old_hend); + p->old_htop = old_htop; + + /* + * We no longer need this temporary area. + */ + erts_free(ERTS_ALC_T_TMP, (void *) temp_lit); + + /* + * Restore status. + */ + erts_smp_proc_lock(p, ERTS_PROC_LOCK_STATUS); + p->status = p->gcstatus; + erts_smp_proc_unlock(p, ERTS_PROC_LOCK_STATUS); + erts_smp_locked_activity_end(ERTS_ACTIVITY_GC); +} + +static int +minor_collection(Process* p, int need, Eterm* objv, int nobj, Uint *recl) +{ + Uint mature = HIGH_WATER(p) - HEAP_START(p); + + /* + * Allocate an old heap if we don't have one and if we'll need one. + */ + + if (OLD_HEAP(p) == NULL && mature != 0) { + Eterm* n_old; + + /* Note: We choose a larger heap size than strictly needed, + * which seems to reduce the number of fullsweeps. + * This improved Estone by more than 1200 estones on my computer + * (Ultra Sparc 10). + */ + size_t new_sz = erts_next_heap_size(HEAP_TOP(p) - HEAP_START(p), 1); + + /* Create new, empty old_heap */ + n_old = (Eterm *) ERTS_HEAP_ALLOC(ERTS_ALC_T_OLD_HEAP, + sizeof(Eterm)*new_sz); + + OLD_HEND(p) = n_old + new_sz; + OLD_HEAP(p) = OLD_HTOP(p) = n_old; + } + + /* + * Do a minor collection if there is an old heap and if it + * is large enough. + */ + + if (OLD_HEAP(p) && mature <= OLD_HEND(p) - OLD_HTOP(p)) { + ErlMessage *msgp; + Uint size_after; + Uint need_after; + Uint stack_size = STACK_SZ_ON_HEAP(p); + Uint fragments = MBUF_SIZE(p) + combined_message_size(p); + Uint size_before = fragments + (HEAP_TOP(p) - HEAP_START(p)); + Uint new_sz = next_heap_size(p, HEAP_SIZE(p) + fragments, 0); + + do_minor(p, new_sz, objv, nobj); + + /* + * Copy newly received message onto the end of the new heap. + */ + ErtsGcQuickSanityCheck(p); + for (msgp = p->msg.first; msgp; msgp = msgp->next) { + if (msgp->data.attached) { + erts_move_msg_attached_data_to_heap(&p->htop, &p->off_heap, msgp); + ErtsGcQuickSanityCheck(p); + } + } + ErtsGcQuickSanityCheck(p); + + GEN_GCS(p)++; + size_after = HEAP_TOP(p) - HEAP_START(p); + need_after = size_after + need + stack_size; + *recl += (size_before - size_after); + + /* + * Excessively large heaps should be shrunk, but + * don't even bother on reasonable small heaps. + * + * The reason for this is that after tenuring, we often + * use a really small portion of new heap, therefore, unless + * the heap size is substantial, we don't want to shrink. + */ + + if ((HEAP_SIZE(p) > 3000) && (4 * need_after < HEAP_SIZE(p)) && + ((HEAP_SIZE(p) > 8000) || + (HEAP_SIZE(p) > (OLD_HEND(p) - OLD_HEAP(p))))) { + Uint wanted = 3 * need_after; + Uint old_heap_sz = OLD_HEND(p) - OLD_HEAP(p); + + /* + * Additional test to make sure we don't make the heap too small + * compared to the size of the older generation heap. + */ + if (wanted*9 < old_heap_sz) { + Uint new_wanted = old_heap_sz / 8; + if (new_wanted > wanted) { + wanted = new_wanted; + } + } + + if (wanted < MIN_HEAP_SIZE(p)) { + wanted = MIN_HEAP_SIZE(p); + } else { + wanted = next_heap_size(p, wanted, 0); + } + if (wanted < HEAP_SIZE(p)) { + shrink_new_heap(p, wanted, objv, nobj); + } + ASSERT(HEAP_SIZE(p) == next_heap_size(p, HEAP_SIZE(p), 0)); + return 1; /* We are done. */ + } + + if (HEAP_SIZE(p) >= need_after) { + /* + * The heap size turned out to be just right. We are done. + */ + ASSERT(HEAP_SIZE(p) == next_heap_size(p, HEAP_SIZE(p), 0)); + return 1; + } + } + + /* + * Still not enough room after minor collection. Must force a major collection. + */ + FLAGS(p) |= F_NEED_FULLSWEEP; + return 0; +} + +/* + * HiPE native code stack scanning procedures: + * - fullsweep_nstack() + * - gensweep_nstack() + * - offset_nstack() + */ +#if defined(HIPE) + +#define GENSWEEP_NSTACK(p,old_htop,n_htop) \ + do { \ + Eterm *tmp_old_htop = old_htop; \ + Eterm *tmp_n_htop = n_htop; \ + gensweep_nstack((p), &tmp_old_htop, &tmp_n_htop); \ + old_htop = tmp_old_htop; \ + n_htop = tmp_n_htop; \ + } while(0) + +/* + * offset_nstack() can ignore the descriptor-based traversal the other + * nstack procedures use and simply call offset_heap_ptr() instead. + * This relies on two facts: + * 1. The only live non-Erlang terms on an nstack are return addresses, + * and they will be skipped thanks to the low/high range check. + * 2. Dead values, even if mistaken for pointers into the low/high area, + * can be offset safely since they won't be dereferenced. + * + * XXX: WARNING: If HiPE starts storing other non-Erlang values on the + * nstack, such as floats, then this will have to be changed. + */ +#define offset_nstack(p,offs,area,area_size) offset_heap_ptr(hipe_nstack_start((p)),hipe_nstack_used((p)),(offs),(area),(area_size)) + +#else /* !HIPE */ + +#define fullsweep_nstack(p,n_htop) (n_htop) +#define GENSWEEP_NSTACK(p,old_htop,n_htop) do{}while(0) +#define offset_nstack(p,offs,area,area_size) do{}while(0) + +#endif /* HIPE */ + +static void +do_minor(Process *p, int new_sz, Eterm* objv, int nobj) +{ + Rootset rootset; /* Rootset for GC (stack, dictionary, etc). */ + Roots* roots; + Eterm* n_htop; + int n; + Eterm* ptr; + Eterm val; + Eterm gval; + char* heap = (char *) HEAP_START(p); + Uint heap_size = (char *) HEAP_TOP(p) - heap; + Uint mature_size = (char *) HIGH_WATER(p) - heap; + Eterm* old_htop = OLD_HTOP(p); + Eterm* n_heap; + + n_htop = n_heap = (Eterm*) ERTS_HEAP_ALLOC(ERTS_ALC_T_HEAP, + sizeof(Eterm)*new_sz); + + if (MBUF(p) != NULL) { + n_htop = collect_heap_frags(p, n_heap, n_htop, objv, nobj); + } + + n = setup_rootset(p, objv, nobj, &rootset); + roots = rootset.roots; + + GENSWEEP_NSTACK(p, old_htop, n_htop); + while (n--) { + Eterm* g_ptr = roots->v; + Uint g_sz = roots->sz; + + roots++; + while (g_sz--) { + gval = *g_ptr; + + switch (primary_tag(gval)) { + + case TAG_PRIMARY_BOXED: { + ptr = boxed_val(gval); + val = *ptr; + if (IS_MOVED(val)) { + ASSERT(is_boxed(val)); + *g_ptr++ = val; + } else if (in_area(ptr, heap, mature_size)) { + MOVE_BOXED(ptr,val,old_htop,g_ptr++); + } else if (in_area(ptr, heap, heap_size)) { + MOVE_BOXED(ptr,val,n_htop,g_ptr++); + } else { + g_ptr++; + } + break; + } + + case TAG_PRIMARY_LIST: { + ptr = list_val(gval); + val = *ptr; + if (is_non_value(val)) { /* Moved */ + *g_ptr++ = ptr[1]; + } else if (in_area(ptr, heap, mature_size)) { + MOVE_CONS(ptr,val,old_htop,g_ptr++); + } else if (in_area(ptr, heap, heap_size)) { + MOVE_CONS(ptr,val,n_htop,g_ptr++); + } else { + g_ptr++; + } + break; + } + + default: + g_ptr++; + break; + } + } + } + + cleanup_rootset(&rootset); + + /* + * Now all references in the rootset point to the new heap. However, + * most references on the new heap point to the old heap so the next stage + * is to scan through the new heap evacuating data from the old heap + * until all is changed. + */ + + if (mature_size == 0) { + n_htop = sweep_one_area(n_heap, n_htop, heap, heap_size); + } else { + Eterm* n_hp = n_heap; + + while (n_hp != n_htop) { + Eterm* ptr; + Eterm val; + Eterm gval = *n_hp; + + switch (primary_tag(gval)) { + case TAG_PRIMARY_BOXED: { + ptr = boxed_val(gval); + val = *ptr; + if (IS_MOVED(val)) { + ASSERT(is_boxed(val)); + *n_hp++ = val; + } else if (in_area(ptr, heap, mature_size)) { + MOVE_BOXED(ptr,val,old_htop,n_hp++); + } else if (in_area(ptr, heap, heap_size)) { + MOVE_BOXED(ptr,val,n_htop,n_hp++); + } else { + n_hp++; + } + break; + } + case TAG_PRIMARY_LIST: { + ptr = list_val(gval); + val = *ptr; + if (is_non_value(val)) { + *n_hp++ = ptr[1]; + } else if (in_area(ptr, heap, mature_size)) { + MOVE_CONS(ptr,val,old_htop,n_hp++); + } else if (in_area(ptr, heap, heap_size)) { + MOVE_CONS(ptr,val,n_htop,n_hp++); + } else { + n_hp++; + } + break; + } + case TAG_PRIMARY_HEADER: { + if (!header_is_thing(gval)) + n_hp++; + else { + if (header_is_bin_matchstate(gval)) { + ErlBinMatchState *ms = (ErlBinMatchState*) n_hp; + ErlBinMatchBuffer *mb = &(ms->mb); + Eterm* origptr = &(mb->orig); + ptr = boxed_val(*origptr); + val = *ptr; + if (IS_MOVED(val)) { + *origptr = val; + mb->base = binary_bytes(val); + } else if (in_area(ptr, heap, mature_size)) { + MOVE_BOXED(ptr,val,old_htop,origptr); + mb->base = binary_bytes(mb->orig); + } else if (in_area(ptr, heap, heap_size)) { + MOVE_BOXED(ptr,val,n_htop,origptr); + mb->base = binary_bytes(mb->orig); + } + } + n_hp += (thing_arityval(gval)+1); + } + break; + } + default: + n_hp++; + break; + } + } + } + + /* + * And also if we have been tenuring, references on the second generation + * may point to the old (soon to be deleted) new_heap. + */ + + if (OLD_HTOP(p) < old_htop) { + old_htop = sweep_one_area(OLD_HTOP(p), old_htop, heap, heap_size); + } + OLD_HTOP(p) = old_htop; + HIGH_WATER(p) = (HEAP_START(p) != HIGH_WATER(p)) ? n_heap : n_htop; + + if (MSO(p).mso) { + sweep_proc_bins(p, 0); + } + + if (MSO(p).funs) { + sweep_proc_funs(p, 0); + } + if (MSO(p).externals) { + sweep_proc_externals(p, 0); + } + +#ifdef HARDDEBUG + /* + * Go through the old_heap before, and try to find references from the old_heap + * into the old new_heap that has just been evacuated and is about to be freed + * (as well as looking for reference into heap fragments, of course). + */ + disallow_heap_frag_ref_in_old_heap(p); +#endif + + /* Copy stack to end of new heap */ + n = p->hend - p->stop; + sys_memcpy(n_heap + new_sz - n, p->stop, n * sizeof(Eterm)); + p->stop = n_heap + new_sz - n; + + ERTS_HEAP_FREE(ERTS_ALC_T_HEAP, + (void*)HEAP_START(p), + HEAP_SIZE(p) * sizeof(Eterm)); + HEAP_START(p) = n_heap; + HEAP_TOP(p) = n_htop; + HEAP_SIZE(p) = new_sz; + HEAP_END(p) = n_heap + new_sz; + +#ifdef HARDDEBUG + disallow_heap_frag_ref_in_heap(p); +#endif + remove_message_buffers(p); +} + +/* + * Major collection. DISCARD the old heap. + */ + +static int +major_collection(Process* p, int need, Eterm* objv, int nobj, Uint *recl) +{ + Rootset rootset; + Roots* roots; + int size_before; + Eterm* n_heap; + Eterm* n_htop; + char* src = (char *) HEAP_START(p); + Uint src_size = (char *) HEAP_TOP(p) - src; + char* oh = (char *) OLD_HEAP(p); + Uint oh_size = (char *) OLD_HTOP(p) - oh; + int n; + Uint new_sz; + Uint fragments = MBUF_SIZE(p) + combined_message_size(p); + ErlMessage *msgp; + + size_before = fragments + (HEAP_TOP(p) - HEAP_START(p)); + + /* + * Do a fullsweep GC. First figure out the size of the heap + * to receive all live data. + */ + + new_sz = HEAP_SIZE(p) + fragments + (OLD_HTOP(p) - OLD_HEAP(p)); + /* + * We used to do + * + * new_sz += STACK_SZ_ON_HEAP(p); + * + * here for no obvious reason. (The stack size is already counted once + * in HEAP_SIZE(p).) + */ + new_sz = next_heap_size(p, new_sz, 0); + + /* + * Should we grow although we don't actually need to? + */ + + if (new_sz == HEAP_SIZE(p) && FLAGS(p) & F_HEAP_GROW) { + new_sz = next_heap_size(p, HEAP_SIZE(p), 1); + } + FLAGS(p) &= ~(F_HEAP_GROW|F_NEED_FULLSWEEP); + n_htop = n_heap = (Eterm *) ERTS_HEAP_ALLOC(ERTS_ALC_T_HEAP, + sizeof(Eterm)*new_sz); + + /* + * Get rid of heap fragments. + */ + + if (MBUF(p) != NULL) { + n_htop = collect_heap_frags(p, n_heap, n_htop, objv, nobj); + } + + /* + * Copy all top-level terms directly referenced by the rootset to + * the new new_heap. + */ + + n = setup_rootset(p, objv, nobj, &rootset); + n_htop = fullsweep_nstack(p, n_htop); + roots = rootset.roots; + while (n--) { + Eterm* g_ptr = roots->v; + Eterm g_sz = roots->sz; + + roots++; + while (g_sz--) { + Eterm* ptr; + Eterm val; + Eterm gval = *g_ptr; + + switch (primary_tag(gval)) { + + case TAG_PRIMARY_BOXED: { + ptr = boxed_val(gval); + val = *ptr; + if (IS_MOVED(val)) { + ASSERT(is_boxed(val)); + *g_ptr++ = val; + } else if (in_area(ptr, src, src_size) || in_area(ptr, oh, oh_size)) { + MOVE_BOXED(ptr,val,n_htop,g_ptr++); + } else { + g_ptr++; + } + continue; + } + + case TAG_PRIMARY_LIST: { + ptr = list_val(gval); + val = *ptr; + if (is_non_value(val)) { + *g_ptr++ = ptr[1]; + } else if (in_area(ptr, src, src_size) || in_area(ptr, oh, oh_size)) { + MOVE_CONS(ptr,val,n_htop,g_ptr++); + } else { + g_ptr++; + } + continue; + } + + default: { + g_ptr++; + continue; + } + } + } + } + + cleanup_rootset(&rootset); + + /* + * Now all references on the stack point to the new heap. However, + * most references on the new heap point to the old heap so the next stage + * is to scan through the new heap evacuating data from the old heap + * until all is copied. + */ + + if (oh_size == 0) { + n_htop = sweep_one_area(n_heap, n_htop, src, src_size); + } else { + Eterm* n_hp = n_heap; + + while (n_hp != n_htop) { + Eterm* ptr; + Eterm val; + Eterm gval = *n_hp; + + switch (primary_tag(gval)) { + case TAG_PRIMARY_BOXED: { + ptr = boxed_val(gval); + val = *ptr; + if (IS_MOVED(val)) { + ASSERT(is_boxed(val)); + *n_hp++ = val; + } else if (in_area(ptr, src, src_size) || in_area(ptr, oh, oh_size)) { + MOVE_BOXED(ptr,val,n_htop,n_hp++); + } else { + n_hp++; + } + break; + } + case TAG_PRIMARY_LIST: { + ptr = list_val(gval); + val = *ptr; + if (is_non_value(val)) { + *n_hp++ = ptr[1]; + } else if (in_area(ptr, src, src_size) || in_area(ptr, oh, oh_size)) { + MOVE_CONS(ptr,val,n_htop,n_hp++); + } else { + n_hp++; + } + break; + } + case TAG_PRIMARY_HEADER: { + if (!header_is_thing(gval)) + n_hp++; + else { + if (header_is_bin_matchstate(gval)) { + ErlBinMatchState *ms = (ErlBinMatchState*) n_hp; + ErlBinMatchBuffer *mb = &(ms->mb); + Eterm* origptr; + origptr = &(mb->orig); + ptr = boxed_val(*origptr); + val = *ptr; + if (IS_MOVED(val)) { + *origptr = val; + mb->base = binary_bytes(*origptr); + } else if (in_area(ptr, src, src_size) || + in_area(ptr, oh, oh_size)) { + MOVE_BOXED(ptr,val,n_htop,origptr); + mb->base = binary_bytes(*origptr); + ptr = boxed_val(*origptr); + val = *ptr; + } + } + n_hp += (thing_arityval(gval)+1); + } + break; + } + default: + n_hp++; + break; + } + } + } + + if (MSO(p).mso) { + sweep_proc_bins(p, 1); + } + if (MSO(p).funs) { + sweep_proc_funs(p, 1); + } + if (MSO(p).externals) { + sweep_proc_externals(p, 1); + } + + if (OLD_HEAP(p) != NULL) { + ERTS_HEAP_FREE(ERTS_ALC_T_OLD_HEAP, + OLD_HEAP(p), + (OLD_HEND(p) - OLD_HEAP(p)) * sizeof(Eterm)); + OLD_HEAP(p) = OLD_HTOP(p) = OLD_HEND(p) = NULL; + } + + /* Move the stack to the end of the heap */ + n = HEAP_END(p) - p->stop; + sys_memcpy(n_heap + new_sz - n, p->stop, n * sizeof(Eterm)); + p->stop = n_heap + new_sz - n; + + ERTS_HEAP_FREE(ERTS_ALC_T_HEAP, + (void *) HEAP_START(p), + (HEAP_END(p) - HEAP_START(p)) * sizeof(Eterm)); + HEAP_START(p) = n_heap; + HEAP_TOP(p) = n_htop; + HEAP_SIZE(p) = new_sz; + HEAP_END(p) = n_heap + new_sz; + GEN_GCS(p) = 0; + + HIGH_WATER(p) = HEAP_TOP(p); + + ErtsGcQuickSanityCheck(p); + /* + * Copy newly received message onto the end of the new heap. + */ + for (msgp = p->msg.first; msgp; msgp = msgp->next) { + if (msgp->data.attached) { + erts_move_msg_attached_data_to_heap(&p->htop, &p->off_heap, msgp); + ErtsGcQuickSanityCheck(p); + } + } + + *recl += adjust_after_fullsweep(p, size_before, need, objv, nobj); + +#ifdef HARDDEBUG + disallow_heap_frag_ref_in_heap(p); +#endif + remove_message_buffers(p); + + ErtsGcQuickSanityCheck(p); + return 1; /* We are done. */ +} + +static Uint +adjust_after_fullsweep(Process *p, int size_before, int need, Eterm *objv, int nobj) +{ + int wanted, sz, size_after, need_after; + int stack_size = STACK_SZ_ON_HEAP(p); + Uint reclaimed_now; + + size_after = (HEAP_TOP(p) - HEAP_START(p)); + reclaimed_now = (size_before - size_after); + + /* + * Resize the heap if needed. + */ + + need_after = size_after + need + stack_size; + if (HEAP_SIZE(p) < need_after) { + /* Too small - grow to match requested need */ + sz = next_heap_size(p, need_after, 0); + grow_new_heap(p, sz, objv, nobj); + } else if (3 * HEAP_SIZE(p) < 4 * need_after){ + /* Need more than 75% of current, postpone to next GC.*/ + FLAGS(p) |= F_HEAP_GROW; + } else if (4 * need_after < HEAP_SIZE(p) && HEAP_SIZE(p) > H_MIN_SIZE){ + /* We need less than 25% of the current heap, shrink.*/ + /* XXX - This is how it was done in the old GC: + wanted = 4 * need_after; + I think this is better as fullsweep is used mainly on + small memory systems, but I could be wrong... */ + wanted = 2 * need_after; + if (wanted < p->min_heap_size) { + sz = p->min_heap_size; + } else { + sz = next_heap_size(p, wanted, 0); + } + if (sz < HEAP_SIZE(p)) { + shrink_new_heap(p, sz, objv, nobj); + } + } + + return reclaimed_now; +} + +/* + * Return the size of all message buffers that are NOT linked in the + * mbuf list. + */ +static Uint +combined_message_size(Process* p) +{ + Uint sz = 0; + ErlMessage *msgp; + + for (msgp = p->msg.first; msgp; msgp = msgp->next) { + if (msgp->data.attached) { + sz += erts_msg_attached_data_size(msgp); + } + } + return sz; +} + +/* + * Remove all message buffers. + */ +static void +remove_message_buffers(Process* p) +{ + ErlHeapFragment* bp = MBUF(p); + + MBUF(p) = NULL; + MBUF_SIZE(p) = 0; + while (bp != NULL) { + ErlHeapFragment* next_bp = bp->next; + free_message_buffer(bp); + bp = next_bp; + } +} + +/* + * Go through one root set array, move everything that it is one of the + * heap fragments to our new heap. + */ +static Eterm* +collect_root_array(Process* p, Eterm* n_htop, Eterm* objv, int nobj) +{ + ErlHeapFragment* qb; + Eterm gval; + Eterm* ptr; + Eterm val; + + ASSERT(p->htop != NULL); + while (nobj--) { + gval = *objv; + + switch (primary_tag(gval)) { + + case TAG_PRIMARY_BOXED: { + ptr = boxed_val(gval); + val = *ptr; + if (IS_MOVED(val)) { + ASSERT(is_boxed(val)); + *objv++ = val; + } else { + for (qb = MBUF(p); qb != NULL; qb = qb->next) { + if (in_area(ptr, qb->mem, qb->size*sizeof(Eterm))) { + MOVE_BOXED(ptr,val,n_htop,objv); + break; + } + } + objv++; + } + break; + } + + case TAG_PRIMARY_LIST: { + ptr = list_val(gval); + val = *ptr; + if (is_non_value(val)) { + *objv++ = ptr[1]; + } else { + for (qb = MBUF(p); qb != NULL; qb = qb->next) { + if (in_area(ptr, qb->mem, qb->size*sizeof(Eterm))) { + MOVE_CONS(ptr,val,n_htop,objv); + break; + } + } + objv++; + } + break; + } + + default: { + objv++; + break; + } + } + } + return n_htop; +} + +#ifdef HARDDEBUG + +/* + * Routines to verify that we don't have pointer into heap fragments from + * that are not allowed to have them. + * + * For performance reasons, we use _unchecked_list_val(), _unchecked_boxed_val(), + * and so on to avoid a function call. + */ + +static void +disallow_heap_frag_ref(Process* p, Eterm* n_htop, Eterm* objv, int nobj) +{ + ErlHeapFragment* mbuf; + ErlHeapFragment* qb; + Eterm gval; + Eterm* ptr; + Eterm val; + + ASSERT(p->htop != NULL); + mbuf = MBUF(p); + + while (nobj--) { + gval = *objv; + + switch (primary_tag(gval)) { + + case TAG_PRIMARY_BOXED: { + ptr = _unchecked_boxed_val(gval); + val = *ptr; + if (IS_MOVED(val)) { + ASSERT(is_boxed(val)); + objv++; + } else { + for (qb = mbuf; qb != NULL; qb = qb->next) { + if (in_area(ptr, qb->mem, qb->size*sizeof(Eterm))) { + abort(); + } + } + objv++; + } + break; + } + + case TAG_PRIMARY_LIST: { + ptr = _unchecked_list_val(gval); + val = *ptr; + if (is_non_value(val)) { + objv++; + } else { + for (qb = mbuf; qb != NULL; qb = qb->next) { + if (in_area(ptr, qb->mem, qb->size*sizeof(Eterm))) { + abort(); + } + } + objv++; + } + break; + } + + default: { + objv++; + break; + } + } + } +} + +static void +disallow_heap_frag_ref_in_heap(Process* p) +{ + Eterm* hp; + Eterm* htop; + Eterm* heap; + Uint heap_size; + + if (p->mbuf == 0) { + return; + } + + htop = p->htop; + heap = p->heap; + heap_size = (htop - heap)*sizeof(Eterm); + + hp = heap; + while (hp < htop) { + ErlHeapFragment* qb; + Eterm* ptr; + Eterm val; + + val = *hp++; + switch (primary_tag(val)) { + case TAG_PRIMARY_BOXED: + ptr = _unchecked_boxed_val(val); + if (!in_area(ptr, heap, heap_size)) { + for (qb = MBUF(p); qb != NULL; qb = qb->next) { + if (in_area(ptr, qb->mem, qb->size*sizeof(Eterm))) { + abort(); + } + } + } + break; + case TAG_PRIMARY_LIST: + ptr = _unchecked_list_val(val); + if (!in_area(ptr, heap, heap_size)) { + for (qb = MBUF(p); qb != NULL; qb = qb->next) { + if (in_area(ptr, qb->mem, qb->size*sizeof(Eterm))) { + abort(); + } + } + } + break; + case TAG_PRIMARY_HEADER: + if (header_is_thing(val)) { + hp += _unchecked_thing_arityval(val); + } + break; + } + } +} + +static void +disallow_heap_frag_ref_in_old_heap(Process* p) +{ + Eterm* hp; + Eterm* htop; + Eterm* old_heap; + Uint old_heap_size; + Eterm* new_heap; + Uint new_heap_size; + + htop = p->old_htop; + old_heap = p->old_heap; + old_heap_size = (htop - old_heap)*sizeof(Eterm); + new_heap = p->heap; + new_heap_size = (p->htop - new_heap)*sizeof(Eterm); + + ASSERT(!p->last_old_htop + || (old_heap <= p->last_old_htop && p->last_old_htop <= htop)); + hp = p->last_old_htop ? p->last_old_htop : old_heap; + while (hp < htop) { + ErlHeapFragment* qb; + Eterm* ptr; + Eterm val; + + val = *hp++; + switch (primary_tag(val)) { + case TAG_PRIMARY_BOXED: + ptr = (Eterm *) val; + if (!in_area(ptr, old_heap, old_heap_size)) { + if (in_area(ptr, new_heap, new_heap_size)) { + abort(); + } + for (qb = MBUF(p); qb != NULL; qb = qb->next) { + if (in_area(ptr, qb->mem, qb->size*sizeof(Eterm))) { + abort(); + } + } + } + break; + case TAG_PRIMARY_LIST: + ptr = (Eterm *) val; + if (!in_area(ptr, old_heap, old_heap_size)) { + if (in_area(ptr, new_heap, new_heap_size)) { + abort(); + } + for (qb = MBUF(p); qb != NULL; qb = qb->next) { + if (in_area(ptr, qb->mem, qb->size*sizeof(Eterm))) { + abort(); + } + } + } + break; + case TAG_PRIMARY_HEADER: + if (header_is_thing(val)) { + hp += _unchecked_thing_arityval(val); + if (!in_area(hp, old_heap, old_heap_size+1)) { + abort(); + } + } + break; + } + } +} +#endif + +static Eterm* +sweep_rootset(Rootset* rootset, Eterm* htop, char* src, Uint src_size) +{ + Roots* roots = rootset->roots; + Uint n = rootset->num_roots; + Eterm* ptr; + Eterm gval; + Eterm val; + + while (n--) { + Eterm* g_ptr = roots->v; + Uint g_sz = roots->sz; + + roots++; + while (g_sz--) { + gval = *g_ptr; + + switch (primary_tag(gval)) { + case TAG_PRIMARY_BOXED: { + ptr = boxed_val(gval); + val = *ptr; + if (IS_MOVED(val)) { + ASSERT(is_boxed(val)); + *g_ptr++ = val; + } else if (in_area(ptr, src, src_size)) { + MOVE_BOXED(ptr,val,htop,g_ptr++); + } else { + g_ptr++; + } + break; + } + case TAG_PRIMARY_LIST: { + ptr = list_val(gval); + val = *ptr; + if (is_non_value(val)) { /* Moved */ + *g_ptr++ = ptr[1]; + } else if (in_area(ptr, src, src_size)) { + MOVE_CONS(ptr,val,htop,g_ptr++); + } else { + g_ptr++; + } + break; + } + + default: + g_ptr++; + break; + } + } + } + return htop; +} + + +static Eterm* +sweep_one_area(Eterm* n_hp, Eterm* n_htop, char* src, Uint src_size) +{ + while (n_hp != n_htop) { + Eterm* ptr; + Eterm val; + Eterm gval = *n_hp; + + switch (primary_tag(gval)) { + case TAG_PRIMARY_BOXED: { + ptr = boxed_val(gval); + val = *ptr; + if (IS_MOVED(val)) { + ASSERT(is_boxed(val)); + *n_hp++ = val; + } else if (in_area(ptr, src, src_size)) { + MOVE_BOXED(ptr,val,n_htop,n_hp++); + } else { + n_hp++; + } + break; + } + case TAG_PRIMARY_LIST: { + ptr = list_val(gval); + val = *ptr; + if (is_non_value(val)) { + *n_hp++ = ptr[1]; + } else if (in_area(ptr, src, src_size)) { + MOVE_CONS(ptr,val,n_htop,n_hp++); + } else { + n_hp++; + } + break; + } + case TAG_PRIMARY_HEADER: { + if (!header_is_thing(gval)) { + n_hp++; + } else { + if (header_is_bin_matchstate(gval)) { + ErlBinMatchState *ms = (ErlBinMatchState*) n_hp; + ErlBinMatchBuffer *mb = &(ms->mb); + Eterm* origptr; + origptr = &(mb->orig); + ptr = boxed_val(*origptr); + val = *ptr; + if (IS_MOVED(val)) { + *origptr = val; + mb->base = binary_bytes(*origptr); + } else if (in_area(ptr, src, src_size)) { + MOVE_BOXED(ptr,val,n_htop,origptr); + mb->base = binary_bytes(*origptr); + } + } + n_hp += (thing_arityval(gval)+1); + } + break; + } + default: + n_hp++; + break; + } + } + return n_htop; +} + +static Eterm* +sweep_one_heap(Eterm* heap_ptr, Eterm* heap_end, Eterm* htop, char* src, Uint src_size) +{ + while (heap_ptr < heap_end) { + Eterm* ptr; + Eterm val; + Eterm gval = *heap_ptr; + + switch (primary_tag(gval)) { + case TAG_PRIMARY_BOXED: { + ptr = boxed_val(gval); + val = *ptr; + if (IS_MOVED(val)) { + ASSERT(is_boxed(val)); + *heap_ptr++ = val; + } else if (in_area(ptr, src, src_size)) { + MOVE_BOXED(ptr,val,htop,heap_ptr++); + } else { + heap_ptr++; + } + break; + } + case TAG_PRIMARY_LIST: { + ptr = list_val(gval); + val = *ptr; + if (is_non_value(val)) { + *heap_ptr++ = ptr[1]; + } else if (in_area(ptr, src, src_size)) { + MOVE_CONS(ptr,val,htop,heap_ptr++); + } else { + heap_ptr++; + } + break; + } + case TAG_PRIMARY_HEADER: { + if (!header_is_thing(gval)) { + heap_ptr++; + } else { + heap_ptr += (thing_arityval(gval)+1); + } + break; + } + default: + heap_ptr++; + break; + } + } + return htop; +} + +/* + * Collect heap fragments and check that they point in the correct direction. + */ + +static Eterm* +collect_heap_frags(Process* p, Eterm* n_hstart, Eterm* n_htop, + Eterm* objv, int nobj) +{ + ErlHeapFragment* qb; + char* frag_begin; + Uint frag_size; + ErlMessage* mp; + + /* + * We don't allow references to a heap fragments from the stack, heap, + * or process dictionary. + */ +#ifdef HARDDEBUG + disallow_heap_frag_ref(p, n_htop, p->stop, STACK_START(p) - p->stop); + if (p->dictionary != NULL) { + disallow_heap_frag_ref(p, n_htop, p->dictionary->data, p->dictionary->used); + } + disallow_heap_frag_ref_in_heap(p); +#endif + + /* + * Go through the subset of the root set that is allowed to + * reference data in heap fragments and move data from heap fragments + * to our new heap. + */ + + if (nobj != 0) { + n_htop = collect_root_array(p, n_htop, objv, nobj); + } + if (is_not_immed(p->fvalue)) { + n_htop = collect_root_array(p, n_htop, &p->fvalue, 1); + } + if (is_not_immed(p->ftrace)) { + n_htop = collect_root_array(p, n_htop, &p->ftrace, 1); + } + if (is_not_immed(p->seq_trace_token)) { + n_htop = collect_root_array(p, n_htop, &p->seq_trace_token, 1); + } + if (is_not_immed(p->group_leader)) { + n_htop = collect_root_array(p, n_htop, &p->group_leader, 1); + } + + /* + * Go through the message queue, move everything that is in one of the + * heap fragments to our new heap. + */ + + for (mp = p->msg.first; mp != NULL; mp = mp->next) { + /* + * In most cases, mp->data.attached points to a heap fragment which is + * self-contained and we will copy it to the heap at the + * end of the GC to avoid scanning it. + * + * In a few cases, however, such as in process_info(Pid, messages) + * and trace_delivered/1, a new message points to a term that has + * been allocated by HAlloc() and mp->data.attached is NULL. Therefore + * we need this loop. + */ + if (mp->data.attached == NULL) { + n_htop = collect_root_array(p, n_htop, mp->m, 2); + } + } + + /* + * Now all references in the root set point to the new heap. However, + * many references on the new heap point to heap fragments. + */ + + qb = MBUF(p); + while (qb != NULL) { + frag_begin = (char *) qb->mem; + frag_size = qb->size * sizeof(Eterm); + if (frag_size != 0) { + n_htop = sweep_one_area(n_hstart, n_htop, frag_begin, frag_size); + } + qb = qb->next; + } + return n_htop; +} + +static Uint +setup_rootset(Process *p, Eterm *objv, int nobj, Rootset *rootset) +{ + Uint avail; + Roots* roots; + ErlMessage* mp; + Uint n; + + n = 0; + roots = rootset->roots = rootset->def; + rootset->size = ALENGTH(rootset->def); + + roots[n].v = p->stop; + roots[n].sz = STACK_START(p) - p->stop; + ++n; + + if (p->dictionary != NULL) { + roots[n].v = p->dictionary->data; + roots[n].sz = p->dictionary->used; + ++n; + } + if (nobj > 0) { + roots[n].v = objv; + roots[n].sz = nobj; + ++n; + } + + ASSERT((is_nil(p->seq_trace_token) || + is_tuple(p->seq_trace_token) || + is_atom(p->seq_trace_token))); + if (is_not_immed(p->seq_trace_token)) { + roots[n].v = &p->seq_trace_token; + roots[n].sz = 1; + n++; + } + + ASSERT(is_nil(p->tracer_proc) || + is_internal_pid(p->tracer_proc) || + is_internal_port(p->tracer_proc)); + + ASSERT(is_pid(p->group_leader)); + if (is_not_immed(p->group_leader)) { + roots[n].v = &p->group_leader; + roots[n].sz = 1; + n++; + } + + /* + * The process may be garbage-collected while it is terminating. + * (fvalue contains the EXIT reason and ftrace the saved stack trace.) + */ + if (is_not_immed(p->fvalue)) { + roots[n].v = &p->fvalue; + roots[n].sz = 1; + n++; + } + if (is_not_immed(p->ftrace)) { + roots[n].v = &p->ftrace; + roots[n].sz = 1; + n++; + } + ASSERT(n <= rootset->size); + + mp = p->msg.first; + avail = rootset->size - n; + while (mp != NULL) { + if (avail == 0) { + Uint new_size = 2*rootset->size; + if (roots == rootset->def) { + roots = erts_alloc(ERTS_ALC_T_ROOTSET, + new_size*sizeof(Roots)); + sys_memcpy(roots, rootset->def, sizeof(rootset->def)); + } else { + roots = erts_realloc(ERTS_ALC_T_ROOTSET, + (void *) roots, + new_size*sizeof(Roots)); + } + rootset->size = new_size; + avail = new_size - n; + } + if (mp->data.attached == NULL) { + roots[n].v = mp->m; + roots[n].sz = 2; + n++; + avail--; + } + mp = mp->next; + } + rootset->roots = roots; + rootset->num_roots = n; + return n; +} + +static +void cleanup_rootset(Rootset* rootset) +{ + if (rootset->roots != rootset->def) { + erts_free(ERTS_ALC_T_ROOTSET, rootset->roots); + } +} + +static void +grow_new_heap(Process *p, Uint new_sz, Eterm* objv, int nobj) +{ + Eterm* new_heap; + int heap_size = HEAP_TOP(p) - HEAP_START(p); + int stack_size = p->hend - p->stop; + Sint offs; + + ASSERT(HEAP_SIZE(p) < new_sz); + new_heap = (Eterm *) ERTS_HEAP_REALLOC(ERTS_ALC_T_HEAP, + (void *) HEAP_START(p), + sizeof(Eterm)*(HEAP_SIZE(p)), + sizeof(Eterm)*new_sz); + + if ((offs = new_heap - HEAP_START(p)) == 0) { /* No move. */ + HEAP_END(p) = new_heap + new_sz; + sys_memmove(p->hend - stack_size, p->stop, stack_size * sizeof(Eterm)); + p->stop = p->hend - stack_size; + } else { + char* area = (char *) HEAP_START(p); + Uint area_size = (char *) HEAP_TOP(p) - area; + Eterm* prev_stop = p->stop; + + offset_heap(new_heap, heap_size, offs, area, area_size); + + HIGH_WATER(p) = new_heap + (HIGH_WATER(p) - HEAP_START(p)); + + HEAP_END(p) = new_heap + new_sz; + prev_stop = new_heap + (p->stop - p->heap); + p->stop = p->hend - stack_size; + sys_memmove(p->stop, prev_stop, stack_size * sizeof(Eterm)); + + offset_rootset(p, offs, area, area_size, objv, nobj); + HEAP_TOP(p) = new_heap + heap_size; + HEAP_START(p) = new_heap; + } + HEAP_SIZE(p) = new_sz; +} + +static void +shrink_new_heap(Process *p, Uint new_sz, Eterm *objv, int nobj) +{ + Eterm* new_heap; + int heap_size = HEAP_TOP(p) - HEAP_START(p); + Sint offs; + + int stack_size = p->hend - p->stop; + + ASSERT(new_sz < p->heap_sz); + sys_memmove(p->heap + new_sz - stack_size, p->stop, stack_size * + sizeof(Eterm)); + new_heap = (Eterm *) ERTS_HEAP_REALLOC(ERTS_ALC_T_HEAP, + (void*)p->heap, + sizeof(Eterm)*(HEAP_SIZE(p)), + sizeof(Eterm)*new_sz); + p->hend = new_heap + new_sz; + p->stop = p->hend - stack_size; + + if ((offs = new_heap - HEAP_START(p)) != 0) { + char* area = (char *) HEAP_START(p); + Uint area_size = (char *) HEAP_TOP(p) - area; + + /* + * Normally, we don't expect a shrunk heap to move, but you never + * know on some strange embedded systems... Or when using purify. + */ + + offset_heap(new_heap, heap_size, offs, area, area_size); + + HIGH_WATER(p) = new_heap + (HIGH_WATER(p) - HEAP_START(p)); + offset_rootset(p, offs, area, area_size, objv, nobj); + HEAP_TOP(p) = new_heap + heap_size; + HEAP_START(p) = new_heap; + } + HEAP_SIZE(p) = new_sz; +} + +static Uint +next_vheap_size(Uint vheap, Uint vheap_sz) { + if (vheap < H_MIN_SIZE) { + return H_MIN_SIZE; + } + + /* grow */ + if (vheap > vheap_sz) { + return erts_next_heap_size(2*vheap, 0); + } + /* shrink */ + if ( vheap < vheap_sz/2) { + return (Uint)vheap_sz*3/4; + } + + return vheap_sz; +} + + +static void +sweep_proc_externals(Process *p, int fullsweep) +{ + ExternalThing** prev; + ExternalThing* ptr; + char* oh = 0; + Uint oh_size = 0; + + if (fullsweep == 0) { + oh = (char *) OLD_HEAP(p); + oh_size = (char *) OLD_HEND(p) - oh; + } + + prev = &MSO(p).externals; + ptr = MSO(p).externals; + + while (ptr) { + Eterm* ppt = (Eterm *) ptr; + + if (IS_MOVED(*ppt)) { /* Object is alive */ + ExternalThing* ro = external_thing_ptr(*ppt); + + *prev = ro; /* Patch to moved pos */ + prev = &ro->next; + ptr = ro->next; + } else if (in_area(ppt, oh, oh_size)) { + /* + * Object resides on old heap, and we just did a + * generational collection - keep object in list. + */ + prev = &ptr->next; + ptr = ptr->next; + } else { /* Object has not been moved - deref it */ + erts_deref_node_entry(ptr->node); + *prev = ptr = ptr->next; + } + } + ASSERT(*prev == NULL); +} + +static void +sweep_proc_funs(Process *p, int fullsweep) +{ + ErlFunThing** prev; + ErlFunThing* ptr; + char* oh = 0; + Uint oh_size = 0; + + if (fullsweep == 0) { + oh = (char *) OLD_HEAP(p); + oh_size = (char *) OLD_HEND(p) - oh; + } + + prev = &MSO(p).funs; + ptr = MSO(p).funs; + + while (ptr) { + Eterm* ppt = (Eterm *) ptr; + + if (IS_MOVED(*ppt)) { /* Object is alive */ + ErlFunThing* ro = (ErlFunThing *) fun_val(*ppt); + + *prev = ro; /* Patch to moved pos */ + prev = &ro->next; + ptr = ro->next; + } else if (in_area(ppt, oh, oh_size)) { + /* + * Object resides on old heap, and we just did a + * generational collection - keep object in list. + */ + prev = &ptr->next; + ptr = ptr->next; + } else { /* Object has not been moved - deref it */ + ErlFunEntry* fe = ptr->fe; + + *prev = ptr = ptr->next; + if (erts_refc_dectest(&fe->refc, 0) == 0) { + erts_erase_fun_entry(fe); + } + } + } + ASSERT(*prev == NULL); +} + +struct shrink_cand_data { + ProcBin* new_candidates; + ProcBin* new_candidates_end; + ProcBin* old_candidates; + Uint no_of_candidates; + Uint no_of_active; +}; + +static ERTS_INLINE void +link_live_proc_bin(struct shrink_cand_data *shrink, + ProcBin ***prevppp, + ProcBin **pbpp, + int new_heap) +{ + ProcBin *pbp = *pbpp; + + *pbpp = pbp->next; + + if (pbp->flags & (PB_ACTIVE_WRITER|PB_IS_WRITABLE)) { + ASSERT(((pbp->flags & (PB_ACTIVE_WRITER|PB_IS_WRITABLE)) + == (PB_ACTIVE_WRITER|PB_IS_WRITABLE)) + || ((pbp->flags & (PB_ACTIVE_WRITER|PB_IS_WRITABLE)) + == PB_IS_WRITABLE)); + + + if (pbp->flags & PB_ACTIVE_WRITER) { + pbp->flags &= ~PB_ACTIVE_WRITER; + shrink->no_of_active++; + } + else { /* inactive */ + Uint unused = pbp->val->orig_size - pbp->size; + /* Our allocators are 8 byte aligned, i.e., shrinking with + less than 8 bytes will have no real effect */ + if (unused >= 8) { /* A shrink candidate; save in candidate list */ + if (new_heap) { + if (!shrink->new_candidates) + shrink->new_candidates_end = pbp; + pbp->next = shrink->new_candidates; + shrink->new_candidates = pbp; + } + else { + pbp->next = shrink->old_candidates; + shrink->old_candidates = pbp; + } + shrink->no_of_candidates++; + return; + } + } + } + + /* Not a shrink candidate; keep in original mso list */ + **prevppp = pbp; + *prevppp = &pbp->next; + +} + + +static void +sweep_proc_bins(Process *p, int fullsweep) +{ + struct shrink_cand_data shrink = {0}; + ProcBin** prev; + ProcBin* ptr; + Binary* bptr; + char* oh = NULL; + Uint oh_size = 0; + Uint bin_vheap = 0; + + if (fullsweep == 0) { + oh = (char *) OLD_HEAP(p); + oh_size = (char *) OLD_HEND(p) - oh; + } + + BIN_OLD_VHEAP(p) = 0; + + prev = &MSO(p).mso; + ptr = MSO(p).mso; + + /* + * Note: In R7 we no longer force a fullsweep when we find binaries + * on the old heap. The reason is that with the introduction of the + * bit syntax we can expect binaries to be used a lot more. Note that + * in earlier releases a brand new binary (or any other term) could + * be put on the old heap during a gen-gc fullsweep, but this is + * no longer the case in R7. + */ + while (ptr) { + Eterm* ppt = (Eterm *) ptr; + + if (IS_MOVED(*ppt)) { /* Object is alive */ + bin_vheap += ptr->size / sizeof(Eterm); + ptr = (ProcBin*) binary_val(*ppt); + link_live_proc_bin(&shrink, + &prev, + &ptr, + !in_area(ptr, oh, oh_size)); + } else if (in_area(ppt, oh, oh_size)) { + /* + * Object resides on old heap, and we just did a + * generational collection - keep object in list. + */ + BIN_OLD_VHEAP(p) += ptr->size / sizeof(Eterm); /* for binary gc (words)*/ + link_live_proc_bin(&shrink, &prev, &ptr, 0); + } else { /* Object has not been moved - deref it */ + + *prev = ptr->next; + bptr = ptr->val; + if (erts_refc_dectest(&bptr->refc, 0) == 0) + erts_bin_free(bptr); + ptr = *prev; + } + } + + if (BIN_OLD_VHEAP(p) >= BIN_OLD_VHEAP_SZ(p)) { + FLAGS(p) |= F_NEED_FULLSWEEP; + } + + BIN_VHEAP_SZ(p) = next_vheap_size(bin_vheap, BIN_VHEAP_SZ(p)); + BIN_OLD_VHEAP_SZ(p) = next_vheap_size(BIN_OLD_VHEAP(p), BIN_OLD_VHEAP_SZ(p)); + MSO(p).overhead = bin_vheap; + + /* + * If we got any shrink candidates, check them out. + */ + + if (shrink.no_of_candidates) { + ProcBin *candlist[] = {shrink.new_candidates, shrink.old_candidates}; + Uint leave_unused = 0; + int i; + + if (shrink.no_of_active == 0) { + if (shrink.no_of_candidates <= ERTS_INACT_WR_PB_LEAVE_MUCH_LIMIT) + leave_unused = ERTS_INACT_WR_PB_LEAVE_MUCH_PERCENTAGE; + else if (shrink.no_of_candidates <= ERTS_INACT_WR_PB_LEAVE_LIMIT) + leave_unused = ERTS_INACT_WR_PB_LEAVE_PERCENTAGE; + } + + for (i = 0; i < sizeof(candlist)/sizeof(candlist[0]); i++) { + + for (ptr = candlist[i]; ptr; ptr = ptr->next) { + Uint new_size = ptr->size; + + if (leave_unused) { + new_size += (new_size * 100) / leave_unused; + /* Our allocators are 8 byte aligned, i.e., shrinking with + less than 8 bytes will have no real effect */ + if (new_size + 8 >= ptr->val->orig_size) + continue; + } + + ptr->val = erts_bin_realloc(ptr->val, new_size); + ptr->val->orig_size = new_size; + ptr->bytes = (byte *) ptr->val->orig_bytes; + } + } + + + /* + * We now potentially have the mso list divided into three lists: + * - shrink candidates on new heap (inactive writable with unused data) + * - shrink candidates on old heap (inactive writable with unused data) + * - other binaries (read only + active writable ...) + * + * Put them back together: new candidates -> other -> old candidates + * This order will ensure that the list only refers from new + * generation to old and never from old to new *which is important*. + */ + if (shrink.new_candidates) { + if (prev == &MSO(p).mso) /* empty other binaries list */ + prev = &shrink.new_candidates_end->next; + else + shrink.new_candidates_end->next = MSO(p).mso; + MSO(p).mso = shrink.new_candidates; + } + } + + *prev = shrink.old_candidates; +} + +/* + * Offset pointers into the heap (not stack). + */ + +static void +offset_heap(Eterm* hp, Uint sz, Sint offs, char* area, Uint area_size) +{ + while (sz--) { + Eterm val = *hp; + switch (primary_tag(val)) { + case TAG_PRIMARY_LIST: + case TAG_PRIMARY_BOXED: + if (in_area(ptr_val(val), area, area_size)) { + *hp = offset_ptr(val, offs); + } + hp++; + break; + case TAG_PRIMARY_HEADER: { + Uint tari; + + if (header_is_transparent(val)) { + hp++; + continue; + } + tari = thing_arityval(val); + switch (thing_subtag(val)) { + case REFC_BINARY_SUBTAG: + { + ProcBin* pb = (ProcBin*) hp; + Eterm** uptr = (Eterm **) (void *) &pb->next; + + if (*uptr && in_area((Eterm *)pb->next, area, area_size)) { + *uptr += offs; /* Patch the mso chain */ + } + sz -= tari; + hp += tari + 1; + } + break; + case BIN_MATCHSTATE_SUBTAG: + { + ErlBinMatchState *ms = (ErlBinMatchState*) hp; + ErlBinMatchBuffer *mb = &(ms->mb); + if (in_area(ptr_val(mb->orig), area, area_size)) { + mb->orig = offset_ptr(mb->orig, offs); + mb->base = binary_bytes(mb->orig); + } + sz -= tari; + hp += tari + 1; + } + break; + case FUN_SUBTAG: + { + ErlFunThing* funp = (ErlFunThing *) hp; + Eterm** uptr = (Eterm **) (void *) &funp->next; + + if (*uptr && in_area((Eterm *)funp->next, area, area_size)) { + *uptr += offs; + } + sz -= tari; + hp += tari + 1; + } + break; + case EXTERNAL_PID_SUBTAG: + case EXTERNAL_PORT_SUBTAG: + case EXTERNAL_REF_SUBTAG: + { + ExternalThing* etp = (ExternalThing *) hp; + Eterm** uptr = (Eterm **) (void *) &etp->next; + + if (*uptr && in_area((Eterm *)etp->next, area, area_size)) { + *uptr += offs; + } + sz -= tari; + hp += tari + 1; + } + break; + default: + sz -= tari; + hp += tari + 1; + } + break; + } + default: + hp++; + continue; + } + } +} + +/* + * Offset pointers to heap from stack. + */ + +static void +offset_heap_ptr(Eterm* hp, Uint sz, Sint offs, char* area, Uint area_size) +{ + while (sz--) { + Eterm val = *hp; + switch (primary_tag(val)) { + case TAG_PRIMARY_LIST: + case TAG_PRIMARY_BOXED: + if (in_area(ptr_val(val), area, area_size)) { + *hp = offset_ptr(val, offs); + } + hp++; + break; + default: + hp++; + break; + } + } +} + +static void +offset_off_heap(Process* p, Sint offs, char* area, Uint area_size) +{ + if (MSO(p).mso && in_area((Eterm *)MSO(p).mso, area, area_size)) { + Eterm** uptr = (Eterm**) (void *) &MSO(p).mso; + *uptr += offs; + } + + if (MSO(p).funs && in_area((Eterm *)MSO(p).funs, area, area_size)) { + Eterm** uptr = (Eterm**) (void *) &MSO(p).funs; + *uptr += offs; + } + + if (MSO(p).externals && in_area((Eterm *)MSO(p).externals, area, area_size)) { + Eterm** uptr = (Eterm**) (void *) &MSO(p).externals; + *uptr += offs; + } +} + +/* + * Offset pointers in message queue. + */ +static void +offset_mqueue(Process *p, Sint offs, char* area, Uint area_size) +{ + ErlMessage* mp = p->msg.first; + + while (mp != NULL) { + Eterm mesg = ERL_MESSAGE_TERM(mp); + if (is_value(mesg)) { + switch (primary_tag(mesg)) { + case TAG_PRIMARY_LIST: + case TAG_PRIMARY_BOXED: + if (in_area(ptr_val(mesg), area, area_size)) { + ERL_MESSAGE_TERM(mp) = offset_ptr(mesg, offs); + } + break; + } + } + mesg = ERL_MESSAGE_TOKEN(mp); + if (is_boxed(mesg) && in_area(ptr_val(mesg), area, area_size)) { + ERL_MESSAGE_TOKEN(mp) = offset_ptr(mesg, offs); + } + ASSERT((is_nil(ERL_MESSAGE_TOKEN(mp)) || + is_tuple(ERL_MESSAGE_TOKEN(mp)) || + is_atom(ERL_MESSAGE_TOKEN(mp)))); + mp = mp->next; + } +} + +static void ERTS_INLINE +offset_one_rootset(Process *p, Sint offs, char* area, Uint area_size, + Eterm* objv, int nobj) +{ + if (p->dictionary) { + offset_heap(p->dictionary->data, + p->dictionary->used, + offs, area, area_size); + } + offset_heap_ptr(&p->fvalue, 1, offs, area, area_size); + offset_heap_ptr(&p->ftrace, 1, offs, area, area_size); + offset_heap_ptr(&p->seq_trace_token, 1, offs, area, area_size); + offset_heap_ptr(&p->group_leader, 1, offs, area, area_size); + offset_mqueue(p, offs, area, area_size); + offset_heap_ptr(p->stop, (STACK_START(p) - p->stop), offs, area, area_size); + offset_nstack(p, offs, area, area_size); + if (nobj > 0) { + offset_heap_ptr(objv, nobj, offs, area, area_size); + } + offset_off_heap(p, offs, area, area_size); +} + +static void +offset_rootset(Process *p, Sint offs, char* area, Uint area_size, + Eterm* objv, int nobj) +{ + offset_one_rootset(p, offs, area, area_size, objv, nobj); +} + +#if defined(DEBUG) || defined(ERTS_OFFHEAP_DEBUG) + +static int +within2(Eterm *ptr, Process *p, Eterm *real_htop) +{ + ErlHeapFragment* bp = MBUF(p); + ErlMessage* mp = p->msg.first; + Eterm *htop = real_htop ? real_htop : HEAP_TOP(p); + + if (OLD_HEAP(p) && (OLD_HEAP(p) <= ptr && ptr < OLD_HEND(p))) { + return 1; + } + if (HEAP_START(p) <= ptr && ptr < htop) { + return 1; + } + while (bp != NULL) { + if (bp->mem <= ptr && ptr < bp->mem + bp->size) { + return 1; + } + bp = bp->next; + } + while (mp) { + if (mp->data.attached) { + ErlHeapFragment *hfp; + if (is_value(ERL_MESSAGE_TERM(mp))) + hfp = mp->data.heap_frag; + else if (is_not_nil(ERL_MESSAGE_TOKEN(mp))) + hfp = erts_dist_ext_trailer(mp->data.dist_ext); + else + hfp = NULL; + if (hfp && hfp->mem <= ptr && ptr < hfp->mem + hfp->size) + return 1; + } + mp = mp->next; + } + return 0; +} + +int +within(Eterm *ptr, Process *p) +{ + return within2(ptr, p, NULL); +} + +#endif + +#ifdef ERTS_OFFHEAP_DEBUG + +#define ERTS_CHK_OFFHEAP_ASSERT(EXP) \ +do { \ + if (!(EXP)) \ + erl_exit(ERTS_ABORT_EXIT, \ + "%s:%d: Assertion failed: %s\n", \ + __FILE__, __LINE__, #EXP); \ +} while (0) + +#ifdef ERTS_OFFHEAP_DEBUG_CHK_CIRCULAR_EXTERNAL_LIST +# define ERTS_EXTERNAL_VISITED_BIT ((Eterm) 1 << 31) +#endif + + +void +erts_check_off_heap2(Process *p, Eterm *htop) +{ + Eterm *oheap = (Eterm *) OLD_HEAP(p); + Eterm *ohtop = (Eterm *) OLD_HTOP(p); + int old; + ProcBin *pb; + ErlFunThing *eft; + ExternalThing *et; + + old = 0; + for (pb = MSO(p).mso; pb; pb = pb->next) { + Eterm *ptr = (Eterm *) pb; + long refc = erts_refc_read(&pb->val->refc, 1); + ERTS_CHK_OFFHEAP_ASSERT(refc >= 1); + if (old) { + ERTS_CHK_OFFHEAP_ASSERT(oheap <= ptr && ptr < ohtop); + } + else if (oheap <= ptr && ptr < ohtop) + old = 1; + else { + ERTS_CHK_OFFHEAP_ASSERT(within2(ptr, p, htop)); + } + } + + old = 0; + for (eft = MSO(p).funs; eft; eft = eft->next) { + Eterm *ptr = (Eterm *) eft; + long refc = erts_refc_read(&eft->fe->refc, 1); + ERTS_CHK_OFFHEAP_ASSERT(refc >= 1); + if (old) + ERTS_CHK_OFFHEAP_ASSERT(oheap <= ptr && ptr < ohtop); + else if (oheap <= ptr && ptr < ohtop) + old = 1; + else + ERTS_CHK_OFFHEAP_ASSERT(within2(ptr, p, htop)); + } + + old = 0; + for (et = MSO(p).externals; et; et = et->next) { + Eterm *ptr = (Eterm *) et; + long refc = erts_refc_read(&et->node->refc, 1); + ERTS_CHK_OFFHEAP_ASSERT(refc >= 1); +#ifdef ERTS_OFFHEAP_DEBUG_CHK_CIRCULAR_EXTERNAL_LIST + ERTS_CHK_OFFHEAP_ASSERT(!(et->header & ERTS_EXTERNAL_VISITED_BIT)); +#endif + if (old) + ERTS_CHK_OFFHEAP_ASSERT(oheap <= ptr && ptr < ohtop); + else if (oheap <= ptr && ptr < ohtop) + old = 1; + else + ERTS_CHK_OFFHEAP_ASSERT(within2(ptr, p, htop)); +#ifdef ERTS_OFFHEAP_DEBUG_CHK_CIRCULAR_EXTERNAL_LIST + et->header |= ERTS_EXTERNAL_VISITED_BIT; +#endif + } + +#ifdef ERTS_OFFHEAP_DEBUG_CHK_CIRCULAR_EXTERNAL_LIST + for (et = MSO(p).externals; et; et = et->next) + et->header &= ~ERTS_EXTERNAL_VISITED_BIT; +#endif + +} + +void +erts_check_off_heap(Process *p) +{ + erts_check_off_heap2(p, NULL); +} + +#endif diff --git a/erts/emulator/beam/erl_gc.h b/erts/emulator/beam/erl_gc.h new file mode 100644 index 0000000000..af55b6363f --- /dev/null +++ b/erts/emulator/beam/erl_gc.h @@ -0,0 +1,72 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2007-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifndef __ERL_GC_H__ +#define __ERL_GC_H__ + +/* GC declarations shared by beam/erl_gc.c and hipe/hipe_gc.c */ + +#ifdef DEBUG +# define HARDDEBUG 1 +#endif + +#define IS_MOVED(x) (!is_header((x))) + +#define MOVE_CONS(PTR,CAR,HTOP,ORIG) \ +do { \ + Eterm gval; \ + \ + HTOP[0] = CAR; /* copy car */ \ + HTOP[1] = PTR[1]; /* copy cdr */ \ + gval = make_list(HTOP); /* new location */ \ + *ORIG = gval; /* redirect original reference */ \ + PTR[0] = THE_NON_VALUE; /* store forwarding indicator */ \ + PTR[1] = gval; /* store forwarding address */ \ + HTOP += 2; /* update tospace htop */ \ +} while(0) + +#define MOVE_BOXED(PTR,HDR,HTOP,ORIG) \ +do { \ + Eterm gval; \ + Sint nelts; \ + \ + ASSERT(is_header(HDR)); \ + gval = make_boxed(HTOP); \ + *ORIG = gval; \ + *HTOP++ = HDR; \ + *PTR++ = gval; \ + nelts = header_arity(HDR); \ + switch ((HDR) & _HEADER_SUBTAG_MASK) { \ + case SUB_BINARY_SUBTAG: nelts++; break; \ + case FUN_SUBTAG: nelts+=((ErlFunThing*)(PTR-1))->num_free+1; break; \ + } \ + while (nelts--) \ + *HTOP++ = *PTR++; \ +} while(0) + +#define in_area(ptr,start,nbytes) \ + ((unsigned long)((char*)(ptr) - (char*)(start)) < (nbytes)) + +extern Uint erts_test_long_gc_sleep; + +#if defined(DEBUG) || defined(ERTS_OFFHEAP_DEBUG) +int within(Eterm *ptr, Process *p); +#endif + +#endif /* __ERL_GC_H__ */ diff --git a/erts/emulator/beam/erl_goodfit_alloc.c b/erts/emulator/beam/erl_goodfit_alloc.c new file mode 100644 index 0000000000..ea2ba4d55c --- /dev/null +++ b/erts/emulator/beam/erl_goodfit_alloc.c @@ -0,0 +1,662 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2003-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + + +/* + * Description: A "good fit" allocator. Segregated free-lists with a + * maximum search depth are used in order to find a good + * fit fast. Each free-list contains blocks of sizes in a + * specific range. First the free-list + * covering the desired size is searched if it is not empty. + * This search is stopped when the maximum search depth has + * been reached. If no free block was found in the free-list + * covering the desired size, the next non-empty free-list + * covering larger sizes is searched. The maximum search + * depth is by default 3. The insert and delete operations + * are O(1) and the search operation is O(n) where n is the + * maximum search depth, i.e. by default the all operations + * are O(1). + * + * This module is a callback-module for erl_alloc_util.c + * + * Author: Rickard Green + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif +#include "global.h" +#define GET_ERL_GF_ALLOC_IMPL +#include "erl_goodfit_alloc.h" + +#define MIN_MBC_SZ (16*1024) +#define MIN_MBC_FIRST_FREE_SZ (4*1024) + +#define MAX_SUB_MASK_IX \ + ((((Uint)1) << (NO_OF_BKT_IX_BITS - SUB_MASK_IX_SHIFT)) - 1) +#define MAX_SUB_BKT_IX ((((Uint)1) << SUB_MASK_IX_SHIFT) - 1) +#define MAX_BKT_IX (NO_OF_BKTS - 1) + +#define MIN_BLK_SZ UNIT_CEILING(sizeof(GFFreeBlock_t) + sizeof(Uint)) + +#define IX2SBIX(IX) ((IX) & (~(~((Uint)0) << SUB_MASK_IX_SHIFT))) +#define IX2SMIX(IX) ((IX) >> SUB_MASK_IX_SHIFT) +#define MAKE_BKT_IX(SMIX, SBIX) \ + ((((Uint)(SMIX)) << SUB_MASK_IX_SHIFT) | ((Uint)(SBIX))) + +#define SET_BKT_MASK_IX(BM, IX) \ +do { \ + int sub_mask_ix__ = IX2SMIX((IX)); \ + (BM).main |= (((Uint) 1) << sub_mask_ix__); \ + (BM).sub[sub_mask_ix__] |= (((Uint)1) << IX2SBIX((IX))); \ +} while (0) + +#define UNSET_BKT_MASK_IX(BM, IX) \ +do { \ + int sub_mask_ix__ = IX2SMIX((IX)); \ + (BM).sub[sub_mask_ix__] &= ~(((Uint)1) << IX2SBIX((IX))); \ + if (!(BM).sub[sub_mask_ix__]) \ + (BM).main &= ~(((Uint)1) << sub_mask_ix__); \ +} while (0) + +/* Buckets ... */ + +#define BKT_INTRVL_A (1*sizeof(Unit_t)) +#define BKT_INTRVL_B (16*sizeof(Unit_t)) +#define BKT_INTRVL_C (96*sizeof(Unit_t)) + +#define BKT_MIN_SIZE_A MIN_BLK_SZ +#define BKT_MIN_SIZE_B (BKT_MAX_SIZE_A + 1) +#define BKT_MIN_SIZE_C (BKT_MAX_SIZE_B + 1) +#define BKT_MIN_SIZE_D (BKT_MAX_SIZE_C + 1) + +#define BKT_MAX_SIZE_A ((NO_OF_BKTS/4)*BKT_INTRVL_A+BKT_MIN_SIZE_A-1) +#define BKT_MAX_SIZE_B ((NO_OF_BKTS/4)*BKT_INTRVL_B+BKT_MIN_SIZE_B-1) +#define BKT_MAX_SIZE_C ((NO_OF_BKTS/4)*BKT_INTRVL_C+BKT_MIN_SIZE_C-1) + + +#define BKT_MAX_IX_A ((NO_OF_BKTS*1)/4 - 1) +#define BKT_MAX_IX_B ((NO_OF_BKTS*2)/4 - 1) +#define BKT_MAX_IX_C ((NO_OF_BKTS*3)/4 - 1) +#define BKT_MAX_IX_D ((NO_OF_BKTS*4)/4 - 1) + +#define BKT_MIN_IX_A (0) +#define BKT_MIN_IX_B (BKT_MAX_IX_A + 1) +#define BKT_MIN_IX_C (BKT_MAX_IX_B + 1) +#define BKT_MIN_IX_D (BKT_MAX_IX_C + 1) + + +#define BKT_IX_(BAP, SZ) \ + ((SZ) <= BKT_MAX_SIZE_A \ + ? (((SZ) - BKT_MIN_SIZE_A)/BKT_INTRVL_A + BKT_MIN_IX_A) \ + : ((SZ) <= BKT_MAX_SIZE_B \ + ? (((SZ) - BKT_MIN_SIZE_B)/BKT_INTRVL_B + BKT_MIN_IX_B) \ + : ((SZ) <= BKT_MAX_SIZE_C \ + ? (((SZ) - BKT_MIN_SIZE_C)/BKT_INTRVL_C + BKT_MIN_IX_C) \ + : ((SZ) <= (BAP)->bkt_max_size_d \ + ? (((SZ) - BKT_MIN_SIZE_D)/(BAP)->bkt_intrvl_d + BKT_MIN_IX_D)\ + : (NO_OF_BKTS - 1))))) + +#define BKT_MIN_SZ_(BAP, IX) \ + ((IX) <= BKT_MAX_IX_A \ + ? (((IX) - BKT_MIN_IX_A)*BKT_INTRVL_A + BKT_MIN_SIZE_A) \ + : ((IX) <= BKT_MAX_IX_B \ + ? (((IX) - BKT_MIN_IX_B)*BKT_INTRVL_B + BKT_MIN_SIZE_B) \ + : ((IX) <= BKT_MAX_IX_C \ + ? (((IX) - BKT_MIN_IX_C)*BKT_INTRVL_C + BKT_MIN_SIZE_C) \ + : (((IX) - BKT_MIN_IX_D)*(BAP)->bkt_intrvl_d + BKT_MIN_SIZE_D)))) + +#ifdef DEBUG + +static int +BKT_IX(GFAllctr_t *gfallctr, Uint size) +{ + int ix; + ASSERT(size >= MIN_BLK_SZ); + + ix = BKT_IX_(gfallctr, size); + + ASSERT(0 <= ix && ix <= BKT_MAX_IX_D); + + return ix; +} + +static Uint +BKT_MIN_SZ(GFAllctr_t *gfallctr, int ix) +{ + Uint size; + ASSERT(0 <= ix && ix <= BKT_MAX_IX_D); + + size = BKT_MIN_SZ_(gfallctr, ix); + +#ifdef ERTS_ALLOC_UTIL_HARD_DEBUG + ASSERT(ix == BKT_IX(gfallctr, size)); + ASSERT(size == MIN_BLK_SZ || ix - 1 == BKT_IX(gfallctr, size - 1)); +#endif + + return size; +} + +#else + +#define BKT_IX BKT_IX_ +#define BKT_MIN_SZ BKT_MIN_SZ_ + +#endif + + +/* Prototypes of callback functions */ +static Block_t * get_free_block (Allctr_t *, Uint, + Block_t *, Uint); +static void link_free_block (Allctr_t *, Block_t *); +static void unlink_free_block (Allctr_t *, Block_t *); +static void update_last_aux_mbc (Allctr_t *, Carrier_t *); +static Eterm info_options (Allctr_t *, char *, int *, + void *, Uint **, Uint *); +static void init_atoms (void); + +#ifdef ERTS_ALLOC_UTIL_HARD_DEBUG +static void check_block (Allctr_t *, Block_t *, int); +static void check_mbc (Allctr_t *, Carrier_t *); +#endif + +static int atoms_initialized = 0; + +void +erts_gfalc_init(void) +{ + atoms_initialized = 0; +} + + +Allctr_t * +erts_gfalc_start(GFAllctr_t *gfallctr, + GFAllctrInit_t *gfinit, + AllctrInit_t *init) +{ + GFAllctr_t nulled_state = {{0}}; + /* {{0}} is used instead of {0}, in order to avoid (an incorrect) gcc + warning. gcc warns if {0} is used as initializer of a struct when + the first member is a struct (not if, for example, the third member + is a struct). */ + Allctr_t *allctr = (Allctr_t *) gfallctr; + + sys_memcpy((void *) gfallctr, (void *) &nulled_state, sizeof(GFAllctr_t)); + + allctr->mbc_header_size = sizeof(Carrier_t); + allctr->min_mbc_size = MIN_MBC_SZ; + allctr->min_mbc_first_free_size = MIN_MBC_FIRST_FREE_SZ; + allctr->min_block_size = sizeof(GFFreeBlock_t); + + + allctr->vsn_str = ERTS_ALC_GF_ALLOC_VSN_STR; + + /* Callback functions */ + + allctr->get_free_block = get_free_block; + allctr->link_free_block = link_free_block; + allctr->unlink_free_block = unlink_free_block; + allctr->info_options = info_options; + + allctr->get_next_mbc_size = NULL; + allctr->creating_mbc = update_last_aux_mbc; + allctr->destroying_mbc = update_last_aux_mbc; + + allctr->init_atoms = init_atoms; + +#ifdef ERTS_ALLOC_UTIL_HARD_DEBUG + allctr->check_block = check_block; + allctr->check_mbc = check_mbc; +#endif + + allctr->atoms_initialized = 0; + + if (init->sbct > BKT_MIN_SIZE_D-1) + gfallctr->bkt_intrvl_d = + UNIT_CEILING(((3*(init->sbct - BKT_MIN_SIZE_D - 1) + /(NO_OF_BKTS/4 - 1)) + 1) + / 2); + if (gfallctr->bkt_intrvl_d < BKT_INTRVL_C) + gfallctr->bkt_intrvl_d = BKT_INTRVL_C; + gfallctr->bkt_max_size_d = ((NO_OF_BKTS/4)*gfallctr->bkt_intrvl_d + + BKT_MIN_SIZE_D + - 1); + + gfallctr->max_blk_search = (Uint) MAX(1, gfinit->mbsd); + + if (!erts_alcu_start(allctr, init)) + return NULL; + + if (allctr->min_block_size != MIN_BLK_SZ) + return NULL; + + return allctr; +} + +static int +find_bucket(BucketMask_t *bmask, int min_index) +{ + int min, mid, max; + int sub_mask_ix, sub_bkt_ix; + int ix = -1; + +#undef GET_MIN_BIT +#define GET_MIN_BIT(MinBit, BitMask, Min, Max) \ + min = (Min); \ + max = (Max); \ + while(max != min) { \ + mid = ((max - min) >> 1) + min; \ + if((BitMask) \ + & (~(~((Uint) 0) << (mid + 1))) \ + & (~((Uint) 0) << min)) \ + max = mid; \ + else \ + min = mid + 1; \ + } \ + (MinBit) = min + + + ASSERT(bmask->main < (((Uint) 1) << (MAX_SUB_MASK_IX+1))); + + sub_mask_ix = IX2SMIX(min_index); + + if ((bmask->main & (~((Uint) 0) << sub_mask_ix)) == 0) + return -1; + + /* There exists a non empty bucket; find it... */ + + if (bmask->main & (((Uint) 1) << sub_mask_ix)) { + sub_bkt_ix = IX2SBIX(min_index); + if ((bmask->sub[sub_mask_ix] & (~((Uint) 0) << sub_bkt_ix)) == 0) { + sub_mask_ix++; + sub_bkt_ix = 0; + if ((bmask->main & (~((Uint) 0)<< sub_mask_ix)) == 0) + return -1; + } + else + goto find_sub_bkt_ix; + } + else { + sub_mask_ix++; + sub_bkt_ix = 0; + } + + ASSERT(sub_mask_ix <= MAX_SUB_MASK_IX); + /* Has to be a bit > sub_mask_ix */ + ASSERT(bmask->main & (~((Uint) 0) << (sub_mask_ix))); + GET_MIN_BIT(sub_mask_ix, bmask->main, sub_mask_ix, MAX_SUB_MASK_IX); + + find_sub_bkt_ix: + ASSERT(sub_mask_ix <= MAX_SUB_MASK_IX); + ASSERT(sub_bkt_ix <= MAX_SUB_BKT_IX); + + if ((bmask->sub[sub_mask_ix] & (((Uint) 1) << sub_bkt_ix)) == 0) { + ASSERT(sub_mask_ix + 1 <= MAX_SUB_BKT_IX); + /* Has to be a bit > sub_bkt_ix */ + ASSERT(bmask->sub[sub_mask_ix] & (~((Uint) 0) << sub_bkt_ix)); + + GET_MIN_BIT(sub_bkt_ix, + bmask->sub[sub_mask_ix], + sub_bkt_ix+1, + MAX_SUB_BKT_IX); + + ASSERT(sub_bkt_ix <= MAX_SUB_BKT_IX); + } + + ix = MAKE_BKT_IX(sub_mask_ix, sub_bkt_ix); + + ASSERT(0 <= ix && ix < NO_OF_BKTS); + + return ix; + +#undef GET_MIN_BIT + +} + +static Block_t * +search_bucket(Allctr_t *allctr, int ix, Uint size) +{ + int i; + Uint min_sz; + Uint blk_sz; + Uint cand_sz = 0; + Uint max_blk_search; + GFFreeBlock_t *blk; + GFFreeBlock_t *cand = NULL; + int blk_on_lambc; + int cand_on_lambc = 0; + GFAllctr_t *gfallctr = (GFAllctr_t *) allctr; + + ASSERT(0 <= ix && ix <= NO_OF_BKTS - 1); + + if (!gfallctr->buckets[ix]) + return NULL; + + min_sz = BKT_MIN_SZ(gfallctr, ix); + if (min_sz < size) + min_sz = size; + + max_blk_search = gfallctr->max_blk_search; + for (blk = gfallctr->buckets[ix], i = 0; + blk && i < max_blk_search; + blk = blk->next, i++) { + + blk_sz = BLK_SZ(blk); + blk_on_lambc = (((char *) blk) < gfallctr->last_aux_mbc_end + && gfallctr->last_aux_mbc_start <= ((char *) blk)); + + if (blk_sz == min_sz && !blk_on_lambc) + return (Block_t *) blk; + + if (blk_sz >= min_sz + && (!cand + || (!blk_on_lambc && (cand_on_lambc || blk_sz < cand_sz)) + || (blk_on_lambc && cand_on_lambc && blk_sz < cand_sz))) { + cand_sz = blk_sz; + cand = blk; + cand_on_lambc = blk_on_lambc; + } + + } + return (Block_t *) cand; +} + +static Block_t * +get_free_block(Allctr_t *allctr, Uint size, + Block_t *cand_blk, Uint cand_size) +{ + GFAllctr_t *gfallctr = (GFAllctr_t *) allctr; + int unsafe_bi, min_bi; + Block_t *blk; + + ASSERT(!cand_blk || cand_size >= size); + + unsafe_bi = BKT_IX(gfallctr, size); + + min_bi = find_bucket(&gfallctr->bucket_mask, unsafe_bi); + if (min_bi < 0) + return NULL; + + if (min_bi == unsafe_bi) { + blk = search_bucket(allctr, min_bi, size); + if (blk) { + if (cand_blk && cand_size <= BLK_SZ(blk)) + return NULL; /* cand_blk was better */ + unlink_free_block(allctr, blk); + return blk; + } + if (min_bi < NO_OF_BKTS - 1) { + min_bi = find_bucket(&gfallctr->bucket_mask, min_bi + 1); + if (min_bi < 0) + return NULL; + } + else + return NULL; + } + else { + ASSERT(min_bi > unsafe_bi); + } + + /* We are guaranteed to find a block that fits in this bucket */ + blk = search_bucket(allctr, min_bi, size); + ASSERT(blk); + if (cand_blk && cand_size <= BLK_SZ(blk)) + return NULL; /* cand_blk was better */ + unlink_free_block(allctr, blk); + return blk; +} + + + +static void +link_free_block(Allctr_t *allctr, Block_t *block) +{ + GFAllctr_t *gfallctr = (GFAllctr_t *) allctr; + GFFreeBlock_t *blk = (GFFreeBlock_t *) block; + Uint sz = BLK_SZ(blk); + int i = BKT_IX(gfallctr, sz); + + ASSERT(sz >= MIN_BLK_SZ); + + SET_BKT_MASK_IX(gfallctr->bucket_mask, i); + + blk->prev = NULL; + blk->next = gfallctr->buckets[i]; + if (blk->next) { + ASSERT(!blk->next->prev); + blk->next->prev = blk; + } + gfallctr->buckets[i] = blk; +} + +static void +unlink_free_block(Allctr_t *allctr, Block_t *block) +{ + GFAllctr_t *gfallctr = (GFAllctr_t *) allctr; + GFFreeBlock_t *blk = (GFFreeBlock_t *) block; + Uint sz = BLK_SZ(blk); + int i = BKT_IX(gfallctr, sz); + + if (!blk->prev) { + ASSERT(gfallctr->buckets[i] == blk); + gfallctr->buckets[i] = blk->next; + } + else + blk->prev->next = blk->next; + if (blk->next) + blk->next->prev = blk->prev; + + if (!gfallctr->buckets[i]) + UNSET_BKT_MASK_IX(gfallctr->bucket_mask, i); +} + +static void +update_last_aux_mbc(Allctr_t *allctr, Carrier_t *mbc) +{ + GFAllctr_t *gfallctr = (GFAllctr_t *) allctr; + + if (gfallctr->last_aux_mbc_start != (char *) allctr->mbc_list.last) { + + if (allctr->mbc_list.last + && allctr->main_carrier != allctr->mbc_list.last) { + gfallctr->last_aux_mbc_start = (char *) allctr->mbc_list.last; + gfallctr->last_aux_mbc_end = (((char *) allctr->mbc_list.last) + + CARRIER_SZ(allctr->mbc_list.last)); + } + else { + gfallctr->last_aux_mbc_start = NULL; + gfallctr->last_aux_mbc_end = NULL; + } + + } +} + +static struct { + Eterm mbsd; + Eterm as; + Eterm gf; +#ifdef DEBUG + Eterm end_of_atoms; +#endif +} am; + +static void ERTS_INLINE atom_init(Eterm *atom, char *name) +{ + *atom = am_atom_put(name, strlen(name)); +} +#define AM_INIT(AM) atom_init(&am.AM, #AM) + +static void +init_atoms(void) +{ +#ifdef DEBUG + Eterm *atom; +#endif + + if (atoms_initialized) + return; + +#ifdef DEBUG + for (atom = (Eterm *) &am; atom <= &am.end_of_atoms; atom++) { + *atom = THE_NON_VALUE; + } +#endif + + AM_INIT(mbsd); + AM_INIT(as); + AM_INIT(gf); + +#ifdef DEBUG + for (atom = (Eterm *) &am; atom < &am.end_of_atoms; atom++) { + ASSERT(*atom != THE_NON_VALUE); + } +#endif + + atoms_initialized = 1; +} + +#define bld_uint erts_bld_uint +#define bld_cons erts_bld_cons +#define bld_tuple erts_bld_tuple + +static ERTS_INLINE void +add_2tup(Uint **hpp, Uint *szp, Eterm *lp, Eterm el1, Eterm el2) +{ + *lp = bld_cons(hpp, szp, bld_tuple(hpp, szp, 2, el1, el2), *lp); +} + +static Eterm +info_options(Allctr_t *allctr, + char *prefix, + int *print_to_p, + void *print_to_arg, + Uint **hpp, + Uint *szp) +{ + GFAllctr_t *gfallctr = (GFAllctr_t *) allctr; + Eterm res = THE_NON_VALUE; + + if (print_to_p) { + erts_print(*print_to_p, + print_to_arg, + "%smbsd: %lu\n" + "%sas: gf\n", + prefix, gfallctr->max_blk_search, + prefix); + } + + if (hpp || szp) { + + if (!atoms_initialized) + erl_exit(1, "%s:%d: Internal error: Atoms not initialized", + __FILE__, __LINE__);; + + res = NIL; + add_2tup(hpp, szp, &res, am.as, am.gf); + add_2tup(hpp, szp, &res, + am.mbsd, + bld_uint(hpp, szp, gfallctr->max_blk_search)); + } + + return res; +} + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *\ + * NOTE: erts_gfalc_test() is only supposed to be used for testing. * + * * + * Keep alloc_SUITE_data/allocator_test.h updated if changes are made * + * to erts_gfalc_test() * +\* */ + +unsigned long +erts_gfalc_test(unsigned long op, unsigned long a1, unsigned long a2) +{ + switch (op) { + case 0x100: return (unsigned long) BKT_IX((GFAllctr_t *) a1, (Uint) a2); + case 0x101: return (unsigned long) BKT_MIN_SZ((GFAllctr_t *) a1, (int) a2); + case 0x102: return (unsigned long) NO_OF_BKTS; + case 0x103: return (unsigned long) + find_bucket(&((GFAllctr_t *) a1)->bucket_mask, (int) a2); + default: ASSERT(0); return ~((unsigned long) 0); + } +} + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *\ + * Debug functions * +\* */ + +#ifdef ERTS_ALLOC_UTIL_HARD_DEBUG +void +check_block(Allctr_t *allctr, Block_t * blk, int free_block) +{ + GFAllctr_t *gfallctr = (GFAllctr_t *) allctr; + int i; + int bi; + int found; + GFFreeBlock_t *fblk; + + if(free_block) { + Uint blk_sz = BLK_SZ(blk); + bi = BKT_IX(gfallctr, blk_sz); + + ASSERT(gfallctr->bucket_mask.main & (((Uint) 1) << IX2SMIX(bi))); + ASSERT(gfallctr->bucket_mask.sub[IX2SMIX(bi)] + & (((Uint) 1) << IX2SBIX(bi))); + + found = 0; + for (fblk = gfallctr->buckets[bi]; fblk; fblk = fblk->next) + if (blk == (Block_t *) fblk) + found++; + ASSERT(found == 1); + } + else + bi = -1; + + found = 0; + for (i = 0; i < NO_OF_BKTS; i++) { + if (i == bi) + continue; /* Already checked */ + for (fblk = gfallctr->buckets[i]; fblk; fblk = fblk->next) + if (blk == (Block_t *) fblk) + found++; + } + + ASSERT(found == 0); + +} + +void +check_mbc(Allctr_t *allctr, Carrier_t *mbc) +{ + GFAllctr_t *gfallctr = (GFAllctr_t *) allctr; + int bi; + + for(bi = 0; bi < NO_OF_BKTS; bi++) { + if ((gfallctr->bucket_mask.main & (((Uint) 1) << IX2SMIX(bi))) + && (gfallctr->bucket_mask.sub[IX2SMIX(bi)] + & (((Uint) 1) << IX2SBIX(bi)))) { + ASSERT(gfallctr->buckets[bi] != NULL); + } + else { + ASSERT(gfallctr->buckets[bi] == NULL); + } + } +} + +#endif diff --git a/erts/emulator/beam/erl_goodfit_alloc.h b/erts/emulator/beam/erl_goodfit_alloc.h new file mode 100644 index 0000000000..3d1b8c01f6 --- /dev/null +++ b/erts/emulator/beam/erl_goodfit_alloc.h @@ -0,0 +1,88 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2003-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + + +#ifndef ERL_GOODFIT_ALLOC__ +#define ERL_GOODFIT_ALLOC__ + +#include "erl_alloc_util.h" + +#define ERTS_ALC_GF_ALLOC_VSN_STR "2.1" + +typedef struct GFAllctr_t_ GFAllctr_t; + +typedef struct { + Uint mbsd; +} GFAllctrInit_t; + +#define ERTS_DEFAULT_GF_ALLCTR_INIT { \ + 3, /* (amount) mbsd: max (mbc) block search depth */\ +} + +void erts_gfalc_init(void); +Allctr_t *erts_gfalc_start(GFAllctr_t *, GFAllctrInit_t *, AllctrInit_t *); + +#endif /* #ifndef ERL_GOODFIT_ALLOC__ */ + + + +#if defined(GET_ERL_GF_ALLOC_IMPL) && !defined(ERL_GF_ALLOC_IMPL__) +#define ERL_GF_ALLOC_IMPL__ + +#define GET_ERL_ALLOC_UTIL_IMPL +#include "erl_alloc_util.h" + +#define NO_OF_BKT_IX_BITS (8) +#ifdef ARCH_64 +# define SUB_MASK_IX_SHIFT (6) +#else +# define SUB_MASK_IX_SHIFT (5) +#endif +#define NO_OF_BKTS (((Uint) 1) << NO_OF_BKT_IX_BITS) +#define NO_OF_SUB_MASKS (NO_OF_BKTS/(((Uint) 1) << SUB_MASK_IX_SHIFT)) + +typedef struct { + Uint main; + Uint sub[NO_OF_SUB_MASKS]; +} BucketMask_t; + +typedef struct GFFreeBlock_t_ GFFreeBlock_t; +struct GFFreeBlock_t_ { + Block_t block_head; + GFFreeBlock_t *prev; + GFFreeBlock_t *next; +}; + +struct GFAllctr_t_ { + Allctr_t allctr; /* Has to be first! */ + + char * last_aux_mbc_start; + char * last_aux_mbc_end; + Uint bkt_max_size_d; + Uint bkt_intrvl_d; + BucketMask_t bucket_mask; + GFFreeBlock_t * buckets[NO_OF_BKTS]; + Uint max_blk_search; + +}; + +unsigned long erts_gfalc_test(unsigned long, unsigned long, unsigned long); + +#endif /* #if defined(GET_ERL_GF_ALLOC_IMPL) + && !defined(ERL_GF_ALLOC_IMPL__) */ diff --git a/erts/emulator/beam/erl_init.c b/erts/emulator/beam/erl_init.c new file mode 100644 index 0000000000..8afd349b85 --- /dev/null +++ b/erts/emulator/beam/erl_init.c @@ -0,0 +1,1461 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1997-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include +#include "erl_vm.h" +#include "global.h" +#include "erl_process.h" +#include "error.h" +#include "erl_version.h" +#include "erl_db.h" +#include "beam_bp.h" +#include "erl_bits.h" +#include "erl_binary.h" +#include "dist.h" +#include "erl_mseg.h" +#include "erl_nmgc.h" +#include "erl_threads.h" +#include "erl_bif_timer.h" +#include "erl_instrument.h" +#include "erl_printf_term.h" +#include "erl_misc_utils.h" +#include "packet_parser.h" + +#ifdef HIPE +#include "hipe_mode_switch.h" /* for hipe_mode_switch_init() */ +#include "hipe_signal.h" /* for hipe_signal_init() */ +#endif + +#ifdef HAVE_SYS_RESOURCE_H +# include +#endif + +/* + * Note about VxWorks: All variables must be initialized by executable code, + * not by an initializer. Otherwise a new instance of the emulator will + * inherit previous values. + */ + +extern void erl_crash_dump_v(char *, int, char *, va_list); +#ifdef __WIN32__ +extern void ConNormalExit(void); +extern void ConWaitForExit(void); +#endif + +#define ERTS_MIN_COMPAT_REL 7 + +#ifdef ERTS_SMP +erts_smp_atomic_t erts_writing_erl_crash_dump; +#else +volatile int erts_writing_erl_crash_dump = 0; +#endif +int erts_initialized = 0; + +#if defined(USE_THREADS) && !defined(ERTS_SMP) +static erts_tid_t main_thread; +#endif + +erts_cpu_info_t *erts_cpuinfo; + +int erts_use_sender_punish; + +/* + * Configurable parameters. + */ + +Uint display_items; /* no of items to display in traces etc */ +Uint display_loads; /* print info about loaded modules */ +int H_MIN_SIZE; /* The minimum heap grain */ + +Uint32 erts_debug_flags; /* Debug flags. */ +#ifdef ERTS_OPCODE_COUNTER_SUPPORT +int count_instructions; +#endif +int erts_backtrace_depth; /* How many functions to show in a backtrace + * in error codes. + */ + +int erts_async_max_threads; /* number of threads for async support */ +int erts_async_thread_suggested_stack_size; +erts_smp_atomic_t erts_max_gen_gcs; + +Eterm erts_error_logger_warnings; /* What to map warning logs to, am_error, + am_info or am_warning, am_error is + the default for BC */ + +int erts_compat_rel; + +static int use_multi_run_queue; +static int no_schedulers; +static int no_schedulers_online; + +#ifdef DEBUG +Uint32 verbose; /* See erl_debug.h for information about verbose */ +#endif + +int erts_disable_tolerant_timeofday; /* Time correction can be disabled it is + * not and/or it is too slow. + */ + +int erts_modified_timing_level; + +int erts_no_crash_dump = 0; /* Use -d to suppress crash dump. */ + +/* + * Other global variables. + */ + +ErtsModifiedTimings erts_modified_timings[] = { + /* 0 */ {make_small(0), CONTEXT_REDS, INPUT_REDUCTIONS}, + /* 1 */ {make_small(0), 2*CONTEXT_REDS, 2*INPUT_REDUCTIONS}, + /* 2 */ {make_small(0), CONTEXT_REDS/2, INPUT_REDUCTIONS/2}, + /* 3 */ {make_small(0), 3*CONTEXT_REDS, 3*INPUT_REDUCTIONS}, + /* 4 */ {make_small(0), CONTEXT_REDS/3, 3*INPUT_REDUCTIONS}, + /* 5 */ {make_small(0), 4*CONTEXT_REDS, INPUT_REDUCTIONS/2}, + /* 6 */ {make_small(1), CONTEXT_REDS/4, 2*INPUT_REDUCTIONS}, + /* 7 */ {make_small(1), 5*CONTEXT_REDS, INPUT_REDUCTIONS/3}, + /* 8 */ {make_small(10), CONTEXT_REDS/5, 3*INPUT_REDUCTIONS}, + /* 9 */ {make_small(10), 6*CONTEXT_REDS, INPUT_REDUCTIONS/4} +}; + +#define ERTS_MODIFIED_TIMING_LEVELS \ + (sizeof(erts_modified_timings)/sizeof(ErtsModifiedTimings)) + +Export *erts_delay_trap = NULL; + +int erts_use_r9_pids_ports; + +#ifdef HYBRID +Eterm *global_heap; +Eterm *global_hend; +Eterm *global_htop; +Eterm *global_saved_htop; +Eterm *global_old_heap; +Eterm *global_old_hend; +ErlOffHeap erts_global_offheap; +Uint global_heap_sz = SH_DEFAULT_SIZE; + +#ifndef INCREMENTAL +Eterm *global_high_water; +Eterm *global_old_htop; +#endif + +Uint16 global_gen_gcs; +Uint16 global_max_gen_gcs; +Uint global_gc_flags; + +Uint global_heap_min_sz = SH_DEFAULT_SIZE; +#endif + +int ignore_break; +int replace_intr; + +static ERTS_INLINE int +has_prefix(const char *prefix, const char *string) +{ + int i; + for (i = 0; prefix[i]; i++) + if (prefix[i] != string[i]) + return 0; + return 1; +} + +static char* +progname(char *fullname) +{ + int i; + + i = strlen(fullname); + while (i >= 0) { + if ((fullname[i] != '/') && (fullname[i] != '\\')) + i--; + else + break; + } + return fullname+i+1; +} + +static int +this_rel_num(void) +{ + static int this_rel = -1; + + if (this_rel < 1) { + int i; + char this_rel_str[] = ERLANG_OTP_RELEASE; + + i = 0; + while (this_rel_str[i] && !isdigit((int) this_rel_str[i])) + i++; + this_rel = atoi(&this_rel_str[i]); + if (this_rel < 1) + erl_exit(-1, "Unexpected ERLANG_OTP_RELEASE format\n"); + } + return this_rel; +} + +/* + * Common error printout function, all error messages + * that don't go to the error logger go through here. + */ + +void erl_error(char *fmt, va_list args) +{ + erts_vfprintf(stderr, fmt, args); +} + +static void early_init(int *argc, char **argv); + +void +erts_short_init(void) +{ + early_init(NULL, NULL); + erl_init(); + erts_initialized = 1; +} + +void +erl_init(void) +{ + init_benchmarking(); + +#ifdef ERTS_SMP + erts_system_block_init(); +#endif + + erts_init_monitors(); + erts_init_gc(); + init_time(); + erts_init_process(); + erts_init_scheduling(use_multi_run_queue, + no_schedulers, + no_schedulers_online); + + H_MIN_SIZE = erts_next_heap_size(H_MIN_SIZE, 0); + + erts_init_trace(); + erts_init_binary(); + erts_init_bits(); + erts_init_fun_table(); + init_atom_table(); + init_export_table(); + init_module_table(); + init_register_table(); + init_message(); + erts_bif_info_init(); + erts_ddll_init(); + init_emulator(); + erts_bp_init(); + init_db(); /* Must be after init_emulator */ + erts_bif_timer_init(); + erts_init_node_tables(); + init_dist(); + erl_drv_thr_init(); + init_io(); + init_copy(); + init_load(); + erts_init_bif(); + erts_init_bif_chksum(); + erts_init_bif_re(); + erts_init_unicode(); /* after RE to get access to PCRE unicode */ + erts_delay_trap = erts_export_put(am_erlang, am_delay_trap, 2); + erts_late_init_process(); +#if HAVE_ERTS_MSEG + erts_mseg_late_init(); /* Must be after timer (init_time()) and thread + initializations */ +#endif +#ifdef HIPE + hipe_mode_switch_init(); /* Must be after init_load/beam_catches/init */ +#endif +#ifdef _OSE_ + erl_sys_init_final(); +#endif + packet_parser_init(); +} + +static void +init_shared_memory(int argc, char **argv) +{ +#ifdef HYBRID + int arg_size = 0; + + global_heap_sz = erts_next_heap_size(global_heap_sz,0); + + /* Make sure arguments will fit on the heap, no one else will check! */ + while (argc--) + arg_size += 2 + strlen(argv[argc]); + if (global_heap_sz < arg_size) + global_heap_sz = erts_next_heap_size(arg_size,1); + +#ifndef INCREMENTAL + global_heap = (Eterm *) ERTS_HEAP_ALLOC(ERTS_ALC_T_HEAP, + sizeof(Eterm) * global_heap_sz); + global_hend = global_heap + global_heap_sz; + global_htop = global_heap; + global_high_water = global_heap; + global_old_hend = global_old_htop = global_old_heap = NULL; +#endif + + global_gen_gcs = 0; + global_max_gen_gcs = erts_smp_atomic_read(&erts_max_gen_gcs); + global_gc_flags = erts_default_process_flags; + + erts_global_offheap.mso = NULL; +#ifndef HYBRID /* FIND ME! */ + erts_global_offheap.funs = NULL; +#endif + erts_global_offheap.overhead = 0; +#endif + +#ifdef INCREMENTAL + erts_init_incgc(); +#endif +} + + +/* + * Create the very first process. + */ + +void +erts_first_process(Eterm modname, void* code, unsigned size, int argc, char** argv) +{ + int i; + Eterm args; + Eterm pid; + Eterm* hp; + Process parent; + Process* p; + ErlSpawnOpts so; + + if (erts_find_function(modname, am_start, 1) == NULL) { + char sbuf[256]; + Atom* ap; + + ap = atom_tab(atom_val(modname)); + memcpy(sbuf, ap->name, ap->len); + sbuf[ap->len] = '\0'; + erl_exit(5, "No function %s:start/1\n", sbuf); + } + + /* + * We need a dummy parent process to be able to call erl_create_process(). + */ + erts_init_empty_process(&parent); + hp = HAlloc(&parent, argc*2 + 4); + args = NIL; + for (i = argc-1; i >= 0; i--) { + int len = sys_strlen(argv[i]); + args = CONS(hp, new_binary(&parent, (byte*)argv[i], len), args); + hp += 2; + } + args = CONS(hp, new_binary(&parent, code, size), args); + hp += 2; + args = CONS(hp, args, NIL); + + so.flags = 0; + pid = erl_create_process(&parent, modname, am_start, args, &so); + p = process_tab[internal_pid_index(pid)]; + p->group_leader = pid; + + erts_cleanup_empty_process(&parent); +} + +/* + * XXX Old way of starting. Hopefully soon obsolete. + */ + +static void +erl_first_process_otp(char* modname, void* code, unsigned size, int argc, char** argv) +{ + int i; + Eterm start_mod; + Eterm args; + Eterm* hp; + Process parent; + ErlSpawnOpts so; + Eterm env; + + start_mod = am_atom_put(modname, sys_strlen(modname)); + if (erts_find_function(start_mod, am_start, 2) == NULL) { + erl_exit(5, "No function %s:start/2\n", modname); + } + + /* + * We need a dummy parent process to be able to call erl_create_process(). + */ + + erts_init_empty_process(&parent); + erts_smp_proc_lock(&parent, ERTS_PROC_LOCK_MAIN); + hp = HAlloc(&parent, argc*2 + 4); + args = NIL; + for (i = argc-1; i >= 0; i--) { + int len = sys_strlen(argv[i]); + args = CONS(hp, new_binary(&parent, (byte*)argv[i], len), args); + hp += 2; + } + env = new_binary(&parent, code, size); + args = CONS(hp, args, NIL); + hp += 2; + args = CONS(hp, env, args); + + so.flags = 0; + (void) erl_create_process(&parent, start_mod, am_start, args, &so); + erts_smp_proc_unlock(&parent, ERTS_PROC_LOCK_MAIN); + erts_cleanup_empty_process(&parent); +} + +Eterm +erts_preloaded(Process* p) +{ + Eterm previous; + int j; + int need; + Eterm mod; + Eterm* hp; + char* name; + const Preload *preload = sys_preloaded(); + + j = 0; + while (preload[j].name != NULL) { + j++; + } + previous = NIL; + need = 2*j; + hp = HAlloc(p, need); + j = 0; + while ((name = preload[j].name) != NULL) { + mod = am_atom_put(name, sys_strlen(name)); + previous = CONS(hp, mod, previous); + hp += 2; + j++; + } + return previous; +} + + +/* static variables that must not change (use same values at restart) */ +static char* program; +static char* init = "init"; +static char* boot = "boot"; +static int boot_argc; +static char** boot_argv; + +static char * +get_arg(char* rest, char* next, int* ip) +{ + if (*rest == '\0') { + if (next == NULL) { + erts_fprintf(stderr, "too few arguments\n"); + erts_usage(); + } + (*ip)++; + return next; + } + return rest; +} + +static void +load_preloaded(void) +{ + int i; + int res; + Preload* preload_p; + Eterm module_name; + byte* code; + char* name; + int length; + + if ((preload_p = sys_preloaded()) == NULL) { + return; + } + i = 0; + while ((name = preload_p[i].name) != NULL) { + length = preload_p[i].size; + module_name = am_atom_put(name, sys_strlen(name)); + if ((code = sys_preload_begin(&preload_p[i])) == 0) + erl_exit(1, "Failed to find preloaded code for module %s\n", + name); + res = erts_load_module(NULL, 0, NIL, &module_name, code, length); + sys_preload_end(&preload_p[i]); + if (res < 0) + erl_exit(1,"Failed loading preloaded module %s\n", name); + i++; + } +} + +/* be helpful (or maybe downright rude:-) */ +void erts_usage(void) +{ + erts_fprintf(stderr, "Usage: %s [flags] [ -- [init_args] ]\n", progname(program)); + erts_fprintf(stderr, "The flags are:\n\n"); + + /* erts_fprintf(stderr, "-# number set the number of items to be used in traces etc\n"); */ + + erts_fprintf(stderr, "-a size suggested stack size in kilo words for threads\n"); + erts_fprintf(stderr, " in the async-thread pool, valid range is [%d-%d]\n", + ERTS_ASYNC_THREAD_MIN_STACK_SIZE, + ERTS_ASYNC_THREAD_MAX_STACK_SIZE); + erts_fprintf(stderr, "-A number set number of threads in async thread pool,\n"); + erts_fprintf(stderr, " valid range is [0-%d]\n", + ERTS_MAX_NO_OF_ASYNC_THREADS); + + erts_fprintf(stderr, "-B[c|d|i] c to have Ctrl-c interrupt the Erlang shell,\n"); + erts_fprintf(stderr, " d (or no extra option) to disable the break\n"); + erts_fprintf(stderr, " handler, i to ignore break signals\n"); + + /* erts_fprintf(stderr, "-b func set the boot function (default boot)\n"); */ + + erts_fprintf(stderr, "-c disable continuous date/time correction with\n"); + erts_fprintf(stderr, " respect to uptime\n"); + + erts_fprintf(stderr, "-d don't write a crash dump for internally detected errors\n"); + erts_fprintf(stderr, " (halt(String) will still produce a crash dump)\n"); + + erts_fprintf(stderr, "-h number set minimum heap size in words (default %d)\n", + H_DEFAULT_SIZE); + + /* erts_fprintf(stderr, "-i module set the boot module (default init)\n"); */ + + erts_fprintf(stderr, "-K boolean enable or disable kernel poll\n"); + + erts_fprintf(stderr, "-l turn on auto load tracing\n"); + + erts_fprintf(stderr, "-M memory allocator switches,\n"); + erts_fprintf(stderr, " see the erts_alloc(3) documentation for more info.\n"); + + erts_fprintf(stderr, "-P number set maximum number of processes on this node,\n"); + erts_fprintf(stderr, " valid range is [%d-%d]\n", + ERTS_MIN_PROCESSES, ERTS_MAX_PROCESSES); + erts_fprintf(stderr, "-R number set compatibility release number,\n"); + erts_fprintf(stderr, " valid range [%d-%d]\n", + ERTS_MIN_COMPAT_REL, this_rel_num()); + + erts_fprintf(stderr, "-r force ets memory block to be moved on realloc\n"); + erts_fprintf(stderr, "-sbt type set scheduler bind type, valid types are:\n"); + erts_fprintf(stderr, " u|ns|ts|ps|s|nnts|nnps|tnnps|db\n"); + erts_fprintf(stderr, "-sct cput set cpu topology,\n"); + erts_fprintf(stderr, " see the erl(1) documentation for more info.\n"); + erts_fprintf(stderr, "-sss size suggested stack size in kilo words for scheduler threads,\n"); + erts_fprintf(stderr, " valid range is [%d-%d]\n", + ERTS_SCHED_THREAD_MIN_STACK_SIZE, + ERTS_SCHED_THREAD_MAX_STACK_SIZE); + erts_fprintf(stderr, "-S n1:n2 set number of schedulers (n1), and number of\n"); + erts_fprintf(stderr, " schedulers online (n2), valid range for both\n"); + erts_fprintf(stderr, " numbers are [1-%d]\n", + ERTS_MAX_NO_OF_SCHEDULERS); + erts_fprintf(stderr, "-T number set modified timing level,\n"); + erts_fprintf(stderr, " valid range is [0-%d]\n", + ERTS_MODIFIED_TIMING_LEVELS-1); + erts_fprintf(stderr, "-V print Erlang version\n"); + + erts_fprintf(stderr, "-v turn on chatty mode (GCs will be reported etc)\n"); + + erts_fprintf(stderr, "-W set error logger warnings mapping,\n"); + erts_fprintf(stderr, " see error_logger documentation for details\n"); + + erts_fprintf(stderr, "\n"); + erts_fprintf(stderr, "Note that if the emulator is started with erlexec (typically\n"); + erts_fprintf(stderr, "from the erl script), these flags should be specified with +.\n"); + erts_fprintf(stderr, "\n\n"); + erl_exit(-1, ""); +} + +static void +early_init(int *argc, char **argv) /* + * Only put things here which are + * really important initialize + * early! + */ +{ + ErtsAllocInitOpts alloc_opts = ERTS_ALLOC_INIT_DEF_OPTS_INITER; + int ncpu; + int ncpuonln; + int ncpuavail; + int schdlrs; + int schdlrs_onln; + use_multi_run_queue = 1; + erts_printf_eterm_func = erts_printf_term; + erts_disable_tolerant_timeofday = 0; + display_items = 200; + display_loads = 0; + erts_backtrace_depth = DEFAULT_BACKTRACE_SIZE; + erts_async_max_threads = 0; + erts_async_thread_suggested_stack_size = ERTS_ASYNC_THREAD_MIN_STACK_SIZE; + H_MIN_SIZE = H_DEFAULT_SIZE; + + erts_initialized = 0; + + erts_use_sender_punish = 1; + + erts_cpuinfo = erts_cpu_info_create(); + +#ifdef ERTS_SMP + ncpu = erts_get_cpu_configured(erts_cpuinfo); + ncpuonln = erts_get_cpu_online(erts_cpuinfo); + ncpuavail = erts_get_cpu_available(erts_cpuinfo); +#else + ncpu = 1; + ncpuonln = 1; + ncpuavail = 1; +#endif + + ignore_break = 0; + replace_intr = 0; + program = argv[0]; + + erts_modified_timing_level = -1; + + erts_compat_rel = this_rel_num(); + + erts_use_r9_pids_ports = 0; + + erts_sys_pre_init(); + +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_init(); +#endif +#ifdef ERTS_SMP + erts_smp_atomic_init(&erts_writing_erl_crash_dump, 0L); +#else + erts_writing_erl_crash_dump = 0; +#endif + + erts_smp_atomic_init(&erts_max_gen_gcs, (long)((Uint16) -1)); + + erts_pre_init_process(); +#if defined(USE_THREADS) && !defined(ERTS_SMP) + main_thread = erts_thr_self(); +#endif + + /* + * We need to know the number of schedulers to use before we + * can initialize the allocators. + */ + no_schedulers = (Uint) (ncpu > 0 ? ncpu : 1); + no_schedulers_online = (ncpuavail > 0 + ? ncpuavail + : (ncpuonln > 0 ? ncpuonln : no_schedulers)); + + schdlrs = no_schedulers; + schdlrs_onln = no_schedulers_online; + + if (argc && argv) { + int i = 1; + while (i < *argc) { + if (strcmp(argv[i], "--") == 0) { /* end of emulator options */ + i++; + break; + } + if (argv[i][0] == '-') { + switch (argv[i][1]) { + case 'S' : { + int tot, onln; + char *arg = get_arg(argv[i]+2, argv[i+1], &i); + switch (sscanf(arg, "%d:%d", &tot, &onln)) { + case 0: + switch (sscanf(arg, ":%d", &onln)) { + case 1: + tot = no_schedulers; + goto chk_S; + default: + goto bad_S; + } + case 1: + onln = tot < schdlrs_onln ? tot : schdlrs_onln; + case 2: + chk_S: + if (tot > 0) + schdlrs = tot; + else + schdlrs = no_schedulers + tot; + if (onln > 0) + schdlrs_onln = onln; + else + schdlrs_onln = no_schedulers_online + onln; + if (schdlrs < 1 || ERTS_MAX_NO_OF_SCHEDULERS < schdlrs) { + erts_fprintf(stderr, + "bad amount of schedulers %d\n", + tot); + erts_usage(); + } + if (schdlrs_onln < 1 || schdlrs < schdlrs_onln) { + erts_fprintf(stderr, + "bad amount of schedulers online %d " + "(total amount of schedulers %d)\n", + schdlrs_onln, schdlrs); + erts_usage(); + } + break; + default: + bad_S: + erts_fprintf(stderr, + "bad amount of schedulers %s\n", + arg); + erts_usage(); + break; + } + + VERBOSE(DEBUG_SYSTEM, + ("using %d:%d scheduler(s)\n", tot, onln)); + break; + } + default: + break; + } + } + i++; + } + } + +#ifdef ERTS_SMP + no_schedulers = schdlrs; + no_schedulers_online = schdlrs_onln; + + erts_no_schedulers = (Uint) no_schedulers; +#endif + + erts_alloc_init(argc, argv, &alloc_opts); /* Handles (and removes) + -M flags. */ + + erts_early_init_scheduling(); /* Require allocators */ + erts_init_utils(); /* Require allocators */ + +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_late_init(); +#endif + +#if defined(HIPE) + hipe_signal_init(); /* must be done very early */ +#endif + erl_sys_init(); + + erl_sys_args(argc, argv); + + erts_ets_realloc_always_moves = 0; + +} + +#ifndef ERTS_SMP +static void set_main_stack_size(void) +{ + if (erts_sched_thread_suggested_stack_size > 0) { +# if HAVE_DECL_GETRLIMIT && HAVE_DECL_SETRLIMIT && HAVE_DECL_RLIMIT_STACK + struct rlimit rl; + int bytes = erts_sched_thread_suggested_stack_size * sizeof(Uint) * 1024; + if (getrlimit(RLIMIT_STACK, &rl) != 0 || + (rl.rlim_cur = bytes, setrlimit(RLIMIT_STACK, &rl) != 0)) { + erts_fprintf(stderr, "failed to set stack size for scheduler " + "thread to %d bytes\n", bytes); + erts_usage(); + } +# else + erts_fprintf(stderr, "no OS support for dynamic stack size limit\n"); + erts_usage(); +# endif + } +} +#endif + +void +erl_start(int argc, char **argv) +{ + int i = 1; + char* arg=NULL; + char* Parg = NULL; + int have_break_handler = 1; + char envbuf[21]; /* enough for any 64-bit integer */ + size_t envbufsz; + int async_max_threads = erts_async_max_threads; + + early_init(&argc, argv); + + envbufsz = sizeof(envbuf); + if (erts_sys_getenv(ERL_MAX_ETS_TABLES_ENV, envbuf, &envbufsz) == 0) + user_requested_db_max_tabs = atoi(envbuf); + else + user_requested_db_max_tabs = 0; + + envbufsz = sizeof(envbuf); + if (erts_sys_getenv("ERL_FULLSWEEP_AFTER", envbuf, &envbufsz) == 0) { + Uint16 max_gen_gcs = atoi(envbuf); + erts_smp_atomic_set(&erts_max_gen_gcs, (long) max_gen_gcs); + } + + envbufsz = sizeof(envbuf); + if (erts_sys_getenv("ERL_THREAD_POOL_SIZE", envbuf, &envbufsz) == 0) { + async_max_threads = atoi(envbuf); + } + + +#ifdef DEBUG + verbose = DEBUG_DEFAULT; +#endif + + erts_error_logger_warnings = am_error; + + while (i < argc) { + if (argv[i][0] != '-') { + erts_usage(); + } + if (strcmp(argv[i], "--") == 0) { /* end of emulator options */ + i++; + break; + } + switch (argv[i][1]) { + + /* + * NOTE: -M flags are handled (and removed from argv) by + * erts_alloc_init(). + * + * The -d, -m, -S, -t, and -T flags was removed in + * Erlang 5.3/OTP R9C. + * + * -S, and -T has been reused in Erlang 5.5/OTP R11B. + * + * -d has been reused in a patch R12B-4. + */ + + case '#' : + arg = get_arg(argv[i]+2, argv[i+1], &i); + if ((display_items = atoi(arg)) == 0) { + erts_fprintf(stderr, "bad display items%s\n", arg); + erts_usage(); + } + VERBOSE(DEBUG_SYSTEM, + ("using display items %d\n",display_items)); + break; + + case 'l': + display_loads++; + break; + + case 'v': +#ifdef DEBUG + if (argv[i][2] == '\0') { + verbose |= DEBUG_SYSTEM; + } else { + char *ch; + for (ch = argv[i]+2; *ch != '\0'; ch++) { + switch (*ch) { + case 's': verbose |= DEBUG_SYSTEM; break; + case 'g': verbose |= DEBUG_PRIVATE_GC; break; + case 'h': verbose |= DEBUG_HYBRID_GC; break; + case 'M': verbose |= DEBUG_MEMORY; break; + case 'a': verbose |= DEBUG_ALLOCATION; break; + case 't': verbose |= DEBUG_THREADS; break; + case 'p': verbose |= DEBUG_PROCESSES; break; + case 'm': verbose |= DEBUG_MESSAGES; break; + default : erts_fprintf(stderr,"Unknown verbose option: %c\n",*ch); + } + } + } + erts_printf("Verbose level: "); + if (verbose & DEBUG_SYSTEM) erts_printf("SYSTEM "); + if (verbose & DEBUG_PRIVATE_GC) erts_printf("PRIVATE_GC "); + if (verbose & DEBUG_HYBRID_GC) erts_printf("HYBRID_GC "); + if (verbose & DEBUG_MEMORY) erts_printf("PARANOID_MEMORY "); + if (verbose & DEBUG_ALLOCATION) erts_printf("ALLOCATION "); + if (verbose & DEBUG_THREADS) erts_printf("THREADS "); + if (verbose & DEBUG_PROCESSES) erts_printf("PROCESSES "); + if (verbose & DEBUG_MESSAGES) erts_printf("MESSAGES "); + erts_printf("\n"); +#else + erts_fprintf(stderr, "warning: -v (only in debug compiled code)\n"); +#endif + break; + case 'V' : + { + char tmp[256]; + + tmp[0] = tmp[1] = '\0'; +#ifdef DEBUG + strcat(tmp, ",DEBUG"); +#endif +#ifdef ERTS_SMP + strcat(tmp, ",SMP"); +#endif +#ifdef USE_THREADS + strcat(tmp, ",ASYNC_THREADS"); +#endif +#ifdef HIPE + strcat(tmp, ",HIPE"); +#endif +#ifdef INCREMENTAL + strcat(tmp, ",INCREMENTAL_GC"); +#endif +#ifdef HYBRID + strcat(tmp, ",HYBRID"); +#endif + erts_fprintf(stderr, "Erlang "); + if (tmp[1]) { + erts_fprintf(stderr, "(%s) ", tmp+1); + } + erts_fprintf(stderr, "(" EMULATOR ") emulator version " + ERLANG_VERSION "\n"); + erl_exit(0, ""); + } + break; + + case 'H': /* undocumented */ + fprintf(stderr, "The undocumented +H option has been removed (R10B-6).\n\n"); + break; + + case 'h': + /* set default heap size */ + arg = get_arg(argv[i]+2, argv[i+1], &i); + if ((H_MIN_SIZE = atoi(arg)) <= 0) { + erts_fprintf(stderr, "bad heap size %s\n", arg); + erts_usage(); + } + VERBOSE(DEBUG_SYSTEM, + ("using minimum heap size %d\n",H_MIN_SIZE)); + break; + + case 'd': + /* + * Never produce crash dumps for internally detected + * errors; only produce a core dump. (Generation of + * crash dumps is destructive and makes it impossible + * to inspect the contents of process heaps in the + * core dump.) + */ + erts_no_crash_dump = 1; + break; + + case 'e': + /* set maximum number of ets tables */ + arg = get_arg(argv[i]+2, argv[i+1], &i); + if (( user_requested_db_max_tabs = atoi(arg) ) < 0) { + erts_fprintf(stderr, "bad maximum number of ets tables %s\n", arg); + erts_usage(); + } + VERBOSE(DEBUG_SYSTEM, + ("using maximum number of ets tables %d\n", + user_requested_db_max_tabs)); + break; + + case 'i': + /* define name of module for initial function */ + init = get_arg(argv[i]+2, argv[i+1], &i); + break; + + case 'b': + /* define name of initial function */ + boot = get_arg(argv[i]+2, argv[i+1], &i); + break; + + case 'B': + if (argv[i][2] == 'i') /* +Bi */ + ignore_break = 1; + else if (argv[i][2] == 'c') /* +Bc */ + replace_intr = 1; + else if (argv[i][2] == 'd') /* +Bd */ + have_break_handler = 0; + else if (argv[i+1][0] == 'i') { /* +B i */ + get_arg(argv[i]+2, argv[i+1], &i); + ignore_break = 1; + } + else if (argv[i+1][0] == 'c') { /* +B c */ + get_arg(argv[i]+2, argv[i+1], &i); + replace_intr = 1; + } + else if (argv[i+1][0] == 'd') { /* +B d */ + get_arg(argv[i]+2, argv[i+1], &i); + have_break_handler = 0; + } + else /* +B */ + have_break_handler = 0; + break; + + case 'K': + /* If kernel poll support is present, + erl_sys_args() will remove the K parameter + and value */ + get_arg(argv[i]+2, argv[i+1], &i); + erts_fprintf(stderr, + "kernel-poll not supported; \"K\" parameter ignored\n", + arg); + break; + + case 'P': + /* set maximum number of processes */ + Parg = get_arg(argv[i]+2, argv[i+1], &i); + erts_max_processes = atoi(Parg); + /* Check of result is delayed until later. This is because +R + may be given after +P. */ + break; + + case 'S' : /* Was handled in early_init() just read past it */ + (void) get_arg(argv[i]+2, argv[i+1], &i); + break; + + case 's' : { + char *estr; + int res; + char *sub_param = argv[i]+2; + if (has_prefix("bt", sub_param)) { + arg = get_arg(sub_param+2, argv[i+1], &i); + res = erts_init_scheduler_bind_type(arg); + if (res != ERTS_INIT_SCHED_BIND_TYPE_SUCCESS) { + switch (res) { + case ERTS_INIT_SCHED_BIND_TYPE_NOT_SUPPORTED: + estr = "not supported"; + break; + case ERTS_INIT_SCHED_BIND_TYPE_ERROR_NO_CPU_TOPOLOGY: + estr = "no cpu topology available"; + break; + case ERTS_INIT_SCHED_BIND_TYPE_ERROR_NO_BAD_TYPE: + estr = "invalid type"; + break; + default: + estr = "undefined error"; + break; + } + erts_fprintf(stderr, + "setting scheduler bind type '%s' failed: %s\n", + arg, + estr); + erts_usage(); + } + } + else if (has_prefix("ct", sub_param)) { + arg = get_arg(sub_param+2, argv[i+1], &i); + res = erts_init_cpu_topology(arg); + if (res != ERTS_INIT_CPU_TOPOLOGY_OK) { + switch (res) { + case ERTS_INIT_CPU_TOPOLOGY_INVALID_ID: + estr = "invalid identifier"; + break; + case ERTS_INIT_CPU_TOPOLOGY_INVALID_ID_RANGE: + estr = "invalid identifier range"; + break; + case ERTS_INIT_CPU_TOPOLOGY_INVALID_HIERARCHY: + estr = "invalid hierarchy"; + break; + case ERTS_INIT_CPU_TOPOLOGY_INVALID_ID_TYPE: + estr = "invalid identifier type"; + break; + case ERTS_INIT_CPU_TOPOLOGY_INVALID_NODES: + estr = "invalid nodes declaration"; + break; + case ERTS_INIT_CPU_TOPOLOGY_MISSING_LID: + estr = "missing logical identifier"; + break; + case ERTS_INIT_CPU_TOPOLOGY_NOT_UNIQUE_LIDS: + estr = "not unique logical identifiers"; + break; + case ERTS_INIT_CPU_TOPOLOGY_NOT_UNIQUE_ENTITIES: + estr = "not unique entities"; + break; + case ERTS_INIT_CPU_TOPOLOGY_MISSING: + estr = "missing cpu topology"; + break; + default: + estr = "undefined error"; + break; + } + erts_fprintf(stderr, + "bad cpu topology '%s': %s\n", + arg, + estr); + erts_usage(); + } + } + else if (sys_strcmp("mrq", sub_param) == 0) + use_multi_run_queue = 1; + else if (sys_strcmp("srq", sub_param) == 0) + use_multi_run_queue = 0; + else if (sys_strcmp("nsp", sub_param) == 0) + erts_use_sender_punish = 0; + else if (has_prefix("ss", sub_param)) { + /* suggested stack size (Kilo Words) for scheduler threads */ + arg = get_arg(sub_param+2, argv[i+1], &i); + erts_sched_thread_suggested_stack_size = atoi(arg); + + if ((erts_sched_thread_suggested_stack_size + < ERTS_SCHED_THREAD_MIN_STACK_SIZE) + || (erts_sched_thread_suggested_stack_size > + ERTS_SCHED_THREAD_MAX_STACK_SIZE)) { + erts_fprintf(stderr, "bad stack size for scheduler threads %s\n", + arg); + erts_usage(); + } + VERBOSE(DEBUG_SYSTEM, + ("suggested scheduler thread stack size %d kilo words\n", + erts_sched_thread_suggested_stack_size)); + } + else { + erts_fprintf(stderr, "bad scheduling option %s\n", argv[i]); + erts_usage(); + } + break; + } + case 'T' : + arg = get_arg(argv[i]+2, argv[i+1], &i); + errno = 0; + erts_modified_timing_level = atoi(arg); + if ((erts_modified_timing_level == 0 && errno != 0) + || erts_modified_timing_level < 0 + || erts_modified_timing_level >= ERTS_MODIFIED_TIMING_LEVELS) { + erts_fprintf(stderr, "bad modified timing level %s\n", arg); + erts_usage(); + } + else { + VERBOSE(DEBUG_SYSTEM, + ("using modified timing level %d\n", + erts_modified_timing_level)); + } + + break; + + case 'R': { + /* set compatibility release */ + + arg = get_arg(argv[i]+2, argv[i+1], &i); + erts_compat_rel = atoi(arg); + + if (erts_compat_rel < ERTS_MIN_COMPAT_REL + || erts_compat_rel > this_rel_num()) { + erts_fprintf(stderr, "bad compatibility release number %s\n", arg); + erts_usage(); + } + + ASSERT(ERTS_MIN_COMPAT_REL >= 7); + switch (erts_compat_rel) { + case 7: + case 8: + case 9: + erts_use_r9_pids_ports = 1; + default: + break; + } + + break; + } + + case 'A': + /* set number of threads in thread pool */ + arg = get_arg(argv[i]+2, argv[i+1], &i); + if (((async_max_threads = atoi(arg)) < 0) || + (async_max_threads > ERTS_MAX_NO_OF_ASYNC_THREADS)) { + erts_fprintf(stderr, "bad number of async threads %s\n", arg); + erts_usage(); + } + + VERBOSE(DEBUG_SYSTEM, ("using %d async-threads\n", + async_max_threads)); + break; + + case 'a': + /* suggested stack size (Kilo Words) for threads in thread pool */ + arg = get_arg(argv[i]+2, argv[i+1], &i); + erts_async_thread_suggested_stack_size = atoi(arg); + + if ((erts_async_thread_suggested_stack_size + < ERTS_ASYNC_THREAD_MIN_STACK_SIZE) + || (erts_async_thread_suggested_stack_size > + ERTS_ASYNC_THREAD_MAX_STACK_SIZE)) { + erts_fprintf(stderr, "bad stack size for async threads %s\n", + arg); + erts_usage(); + } + + VERBOSE(DEBUG_SYSTEM, + ("suggested async-thread stack size %d kilo words\n", + erts_async_thread_suggested_stack_size)); + break; + + case 'r': + erts_ets_realloc_always_moves = 1; + break; + case 'n': /* XXX obsolete */ + break; + case 'c': + if (argv[i][2] == 0) { /* -c: documented option */ + erts_disable_tolerant_timeofday = 1; + } +#ifdef ERTS_OPCODE_COUNTER_SUPPORT + else if (argv[i][2] == 'i') { /* -ci: undcoumented option*/ + count_instructions = 1; + } +#endif + break; + case 'W': + arg = get_arg(argv[i]+2, argv[i+1], &i); + switch (arg[0]) { + case 'i': + erts_error_logger_warnings = am_info; + break; + case 'w': + erts_error_logger_warnings = am_warning; + break; + case 'e': /* The default */ + erts_error_logger_warnings = am_error; + default: + erts_fprintf(stderr, "unrecognized warning_map option %s\n", arg); + erts_usage(); + } + break; + + default: + erts_fprintf(stderr, "%s unknown flag %s\n", argv[0], argv[i]); + erts_usage(); + } + i++; + } + +#ifdef USE_THREADS + erts_async_max_threads = async_max_threads; +#endif + + /* Delayed check of +P flag */ + if (erts_max_processes < ERTS_MIN_PROCESSES + || erts_max_processes > ERTS_MAX_PROCESSES + || (erts_use_r9_pids_ports + && erts_max_processes > ERTS_MAX_R9_PROCESSES)) { + erts_fprintf(stderr, "bad number of processes %s\n", Parg); + erts_usage(); + } + + /* Restart will not reinstall the break handler */ +#ifdef __WIN32__ + if (ignore_break) + erts_set_ignore_break(); + else if (replace_intr) + erts_replace_intr(); + else + init_break_handler(); +#else + if (ignore_break) + erts_set_ignore_break(); + else if (have_break_handler) + init_break_handler(); + if (replace_intr) + erts_replace_intr(); +#endif + + boot_argc = argc - i; /* Number of arguments to init */ + boot_argv = &argv[i]; + + erl_init(); + + init_shared_memory(boot_argc, boot_argv); + load_preloaded(); + + erts_initialized = 1; + + erl_first_process_otp("otp_ring0", NULL, 0, boot_argc, boot_argv); + +#ifdef ERTS_SMP + erts_start_schedulers(); + /* Let system specific code decide what to do with the main thread... */ + + erts_sys_main_thread(); /* May or may not return! */ +#else + set_main_stack_size(); + process_main(); +#endif +} + + +#ifdef USE_THREADS + +__decl_noreturn void erts_thr_fatal_error(int err, char *what) +{ + char *errstr = err ? strerror(err) : NULL; + erts_fprintf(stderr, + "Failed to %s: %s%s(%d)\n", + what, + errstr ? errstr : "", + errstr ? " " : "", + err); + abort(); +} + +#endif + +static void +system_cleanup(int exit_code) +{ + /* No cleanup wanted if ... + * 1. we are about to do an abnormal exit + * 2. we haven't finished initializing, or + * 3. another thread than the main thread is performing the exit + * (in threaded non smp case). + */ + + if (exit_code != 0 + || !erts_initialized +#if defined(USE_THREADS) && !defined(ERTS_SMP) + || !erts_equal_tids(main_thread, erts_thr_self()) +#endif + ) + return; + +#ifdef ERTS_SMP +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_check_exact(NULL, 0); +#endif + erts_smp_block_system(ERTS_BS_FLG_ALLOW_GC); /* We never release it... */ +#endif + +#ifdef HYBRID + if (ma_src_stack) erts_free(ERTS_ALC_T_OBJECT_STACK, + (void *)ma_src_stack); + if (ma_dst_stack) erts_free(ERTS_ALC_T_OBJECT_STACK, + (void *)ma_dst_stack); + if (ma_offset_stack) erts_free(ERTS_ALC_T_OBJECT_STACK, + (void *)ma_offset_stack); + ma_src_stack = NULL; + ma_dst_stack = NULL; + ma_offset_stack = NULL; + erts_cleanup_offheap(&erts_global_offheap); +#endif + +#if defined(HYBRID) && !defined(INCREMENTAL) + if (global_heap) { + ERTS_HEAP_FREE(ERTS_ALC_T_HEAP, + (void*) global_heap, + sizeof(Eterm) * global_heap_sz); + } + global_heap = NULL; +#endif + +#ifdef INCREMENTAL + erts_cleanup_incgc(); +#endif + +#if defined(USE_THREADS) && !defined(ERTS_SMP) + exit_async(); +#endif +#if HAVE_ERTS_MSEG + erts_mseg_exit(); +#endif + + /* + * A lot more cleaning could/should have been done... + */ + +} + +/* + * Common exit function, all exits from the system go through here. + * n <= 0 -> normal exit with status n; + * n = 127 -> Erlang crash dump produced, exit with status 1; + * other positive n -> Erlang crash dump and core dump produced. + */ + +__decl_noreturn void erl_exit0(char *file, int line, int n, char *fmt,...) +{ + unsigned int an; + va_list args; + + va_start(args, fmt); + + save_statistics(); + + system_cleanup(n); + + an = abs(n); + + if (erts_mtrace_enabled) + erts_mtrace_exit((Uint32) an); + + /* Produce an Erlang core dump if error */ + if (n > 0 && erts_initialized && + (erts_no_crash_dump == 0 || n == ERTS_DUMP_EXIT)) { + erl_crash_dump_v(file, line, fmt, args); + } + + /* need to reinitialize va_args thing */ + va_end(args); + va_start(args, fmt); + + if (fmt != NULL && *fmt != '\0') + erl_error(fmt, args); /* Print error message. */ + va_end(args); +#ifdef __WIN32__ + if(n > 0) ConWaitForExit(); + else ConNormalExit(); +#endif +#if !defined(__WIN32__) && !defined(VXWORKS) && !defined(_OSE_) + sys_tty_reset(); +#endif + + if (n == ERTS_INTR_EXIT) + exit(0); + else if (n == 127) + ERTS_EXIT_AFTER_DUMP(1); + else if (n > 0 || n == ERTS_ABORT_EXIT) + abort(); + exit(an); +} + +__decl_noreturn void erl_exit(int n, char *fmt,...) +{ + unsigned int an; + va_list args; + + va_start(args, fmt); + + save_statistics(); + + system_cleanup(n); + + an = abs(n); + + if (erts_mtrace_enabled) + erts_mtrace_exit((Uint32) an); + + /* Produce an Erlang core dump if error */ + if (n > 0 && erts_initialized && + (erts_no_crash_dump == 0 || n == ERTS_DUMP_EXIT)) { + erl_crash_dump_v((char*) NULL, 0, fmt, args); + } + + /* need to reinitialize va_args thing */ + va_end(args); + va_start(args, fmt); + + if (fmt != NULL && *fmt != '\0') + erl_error(fmt, args); /* Print error message. */ + va_end(args); +#ifdef __WIN32__ + if(n > 0) ConWaitForExit(); + else ConNormalExit(); +#endif +#if !defined(__WIN32__) && !defined(VXWORKS) && !defined(_OSE_) + sys_tty_reset(); +#endif + + if (n == ERTS_INTR_EXIT) + exit(0); + else if (n == ERTS_DUMP_EXIT) + ERTS_EXIT_AFTER_DUMP(1); + else if (n > 0 || n == ERTS_ABORT_EXIT) + abort(); + exit(an); +} + diff --git a/erts/emulator/beam/erl_instrument.c b/erts/emulator/beam/erl_instrument.c new file mode 100644 index 0000000000..3f022f92b8 --- /dev/null +++ b/erts/emulator/beam/erl_instrument.c @@ -0,0 +1,1221 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2003-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "global.h" +#include "big.h" +#include "erl_instrument.h" +#include "erl_threads.h" + +typedef union { long l; double d; } Align_t; + +typedef struct { + Uint size; +#ifdef VALGRIND + void* valgrind_leak_suppressor; +#endif + Align_t mem[1]; +} StatBlock_t; + +#define STAT_BLOCK_HEADER_SIZE (sizeof(StatBlock_t) - sizeof(Align_t)) + +typedef struct MapStatBlock_t_ MapStatBlock_t; +struct MapStatBlock_t_ { + Uint size; + ErtsAlcType_t type_no; + Eterm pid; + MapStatBlock_t *prev; + MapStatBlock_t *next; + Align_t mem[1]; +}; + +#define MAP_STAT_BLOCK_HEADER_SIZE (sizeof(MapStatBlock_t) - sizeof(Align_t)) + +typedef struct { + Uint size; + Uint max_size; + Uint max_size_ever; + + Uint blocks; + Uint max_blocks; + Uint max_blocks_ever; +} Stat_t; + +static erts_mtx_t instr_mutex; +static erts_mtx_t instr_x_mutex; + +int erts_instr_memory_map; +int erts_instr_stat; + +static ErtsAllocatorFunctions_t real_allctrs[ERTS_ALC_A_MAX+1]; + +struct stats_ { + Stat_t tot; + Stat_t a[ERTS_ALC_A_MAX+1]; + Stat_t *ap[ERTS_ALC_A_MAX+1]; + Stat_t c[ERTS_ALC_C_MAX+1]; + Stat_t n[ERTS_ALC_N_MAX+1]; +}; + +static struct stats_ *stats; + +static MapStatBlock_t *mem_anchor; + +static Eterm *am_tot; +static Eterm *am_n; +static Eterm *am_a; +static Eterm *am_c; + +static int atoms_initialized; + +static struct { + Eterm total; + Eterm allocators; + Eterm classes; + Eterm types; + Eterm sizes; + Eterm blocks; + Eterm instr_hdr; +#ifdef DEBUG + Eterm end_of_atoms; +#endif +} am; + +static void ERTS_INLINE atom_init(Eterm *atom, const char *name) +{ + *atom = am_atom_put((char *) name, strlen(name)); +} +#define AM_INIT(AM) atom_init(&am.AM, #AM) + +static void +init_atoms(void) +{ +#ifdef DEBUG + Eterm *atom; + for (atom = (Eterm *) &am; atom <= &am.end_of_atoms; atom++) { + *atom = THE_NON_VALUE; + } +#endif + + AM_INIT(total); + AM_INIT(allocators); + AM_INIT(classes); + AM_INIT(types); + AM_INIT(sizes); + AM_INIT(blocks); + AM_INIT(instr_hdr); + +#ifdef DEBUG + for (atom = (Eterm *) &am; atom < &am.end_of_atoms; atom++) { + ASSERT(*atom != THE_NON_VALUE); + } +#endif + + atoms_initialized = 1; +} + +#undef AM_INIT + +static void +init_am_tot(void) +{ + am_tot = (Eterm *) erts_alloc(ERTS_ALC_T_INSTR_INFO, + sizeof(Eterm)); + atom_init(am_tot, "total"); +} + + +static void +init_am_n(void) +{ + int i; + am_n = (Eterm *) erts_alloc(ERTS_ALC_T_INSTR_INFO, + (ERTS_ALC_N_MAX+1)*sizeof(Eterm)); + + for (i = ERTS_ALC_N_MIN; i <= ERTS_ALC_N_MAX; i++) { + atom_init(&am_n[i], ERTS_ALC_N2TD(i)); + } + +} + +static void +init_am_c(void) +{ + int i; + am_c = (Eterm *) erts_alloc(ERTS_ALC_T_INSTR_INFO, + (ERTS_ALC_C_MAX+1)*sizeof(Eterm)); + + for (i = ERTS_ALC_C_MIN; i <= ERTS_ALC_C_MAX; i++) { + atom_init(&am_c[i], ERTS_ALC_C2CD(i)); + } + +} + +static void +init_am_a(void) +{ + int i; + am_a = (Eterm *) erts_alloc(ERTS_ALC_T_INSTR_INFO, + (ERTS_ALC_A_MAX+1)*sizeof(Eterm)); + + for (i = ERTS_ALC_A_MIN; i <= ERTS_ALC_A_MAX; i++) { + atom_init(&am_a[i], ERTS_ALC_A2AD(i)); + } + +} + +static ERTS_INLINE void +stat_upd_alloc(ErtsAlcType_t n, Uint size) +{ + ErtsAlcType_t t = ERTS_ALC_N2T(n); + ErtsAlcType_t a = ERTS_ALC_T2A(t); + ErtsAlcType_t c = ERTS_ALC_T2C(t); + + stats->ap[a]->size += size; + if (stats->ap[a]->max_size < stats->ap[a]->size) + stats->ap[a]->max_size = stats->ap[a]->size; + + stats->c[c].size += size; + if (stats->c[c].max_size < stats->c[c].size) + stats->c[c].max_size = stats->c[c].size; + + stats->n[n].size += size; + if (stats->n[n].max_size < stats->n[n].size) + stats->n[n].max_size = stats->n[n].size; + + stats->tot.size += size; + if (stats->tot.max_size < stats->tot.size) + stats->tot.max_size = stats->tot.size; + + stats->ap[a]->blocks++; + if (stats->ap[a]->max_blocks < stats->ap[a]->blocks) + stats->ap[a]->max_blocks = stats->ap[a]->blocks; + + stats->c[c].blocks++; + if (stats->c[c].max_blocks < stats->c[c].blocks) + stats->c[c].max_blocks = stats->c[c].blocks; + + stats->n[n].blocks++; + if (stats->n[n].max_blocks < stats->n[n].blocks) + stats->n[n].max_blocks = stats->n[n].blocks; + + stats->tot.blocks++; + if (stats->tot.max_blocks < stats->tot.blocks) + stats->tot.max_blocks = stats->tot.blocks; + +} + + +static ERTS_INLINE void +stat_upd_free(ErtsAlcType_t n, Uint size) +{ + ErtsAlcType_t t = ERTS_ALC_N2T(n); + ErtsAlcType_t a = ERTS_ALC_T2A(t); + ErtsAlcType_t c = ERTS_ALC_T2C(t); + + ASSERT(stats->ap[a]->size >= size); + stats->ap[a]->size -= size; + + ASSERT(stats->c[c].size >= size); + stats->c[c].size -= size; + + ASSERT(stats->n[n].size >= size); + stats->n[n].size -= size; + + ASSERT(stats->tot.size >= size); + stats->tot.size -= size; + + ASSERT(stats->ap[a]->blocks > 0); + stats->ap[a]->blocks--; + + ASSERT(stats->c[c].blocks > 0); + stats->c[c].blocks--; + + ASSERT(stats->n[n].blocks > 0); + stats->n[n].blocks--; + + ASSERT(stats->tot.blocks > 0); + stats->tot.blocks--; + +} + + +static ERTS_INLINE void +stat_upd_realloc(ErtsAlcType_t n, Uint size, Uint old_size) +{ + if (old_size) + stat_upd_free(n, old_size); + stat_upd_alloc(n, size); +} + +/* + * stat instrumentation callback functions + */ + +static void * +stat_alloc(ErtsAlcType_t n, void *extra, Uint size) +{ + ErtsAllocatorFunctions_t *real_af = (ErtsAllocatorFunctions_t *) extra; + Uint ssize; + void *res; + + erts_mtx_lock(&instr_mutex); + + ssize = size + STAT_BLOCK_HEADER_SIZE; + res = (*real_af->alloc)(n, real_af->extra, ssize); + if (res) { + stat_upd_alloc(n, size); + ((StatBlock_t *) res)->size = size; +#ifdef VALGRIND + /* Suppress "possibly leaks" by storing an actual dummy pointer + to the _start_ of the allocated block.*/ + ((StatBlock_t *) res)->valgrind_leak_suppressor = res; +#endif + res = (void *) ((StatBlock_t *) res)->mem; + } + + erts_mtx_unlock(&instr_mutex); + + return res; +} + +static void * +stat_realloc(ErtsAlcType_t n, void *extra, void *ptr, Uint size) +{ + ErtsAllocatorFunctions_t *real_af = (ErtsAllocatorFunctions_t *) extra; + Uint old_size; + Uint ssize; + void *sptr; + void *res; + + erts_mtx_lock(&instr_mutex); + + if (ptr) { + sptr = (void *) (((char *) ptr) - STAT_BLOCK_HEADER_SIZE); + old_size = ((StatBlock_t *) sptr)->size; + } + else { + sptr = NULL; + old_size = 0; + } + + ssize = size + STAT_BLOCK_HEADER_SIZE; + res = (*real_af->realloc)(n, real_af->extra, sptr, ssize); + if (res) { + stat_upd_realloc(n, size, old_size); + ((StatBlock_t *) res)->size = size; +#ifdef VALGRIND + ((StatBlock_t *) res)->valgrind_leak_suppressor = res; +#endif + res = (void *) ((StatBlock_t *) res)->mem; + } + + erts_mtx_unlock(&instr_mutex); + + return res; +} + +static void +stat_free(ErtsAlcType_t n, void *extra, void *ptr) +{ + ErtsAllocatorFunctions_t *real_af = (ErtsAllocatorFunctions_t *) extra; + void *sptr; + + erts_mtx_lock(&instr_mutex); + + if (ptr) { + sptr = (void *) (((char *) ptr) - STAT_BLOCK_HEADER_SIZE); + stat_upd_free(n, ((StatBlock_t *) sptr)->size); + } + else { + sptr = NULL; + } + + (*real_af->free)(n, real_af->extra, sptr); + + erts_mtx_unlock(&instr_mutex); + +} + +/* + * map stat instrumentation callback functions + */ + +static void * +map_stat_alloc(ErtsAlcType_t n, void *extra, Uint size) +{ + ErtsAllocatorFunctions_t *real_af = (ErtsAllocatorFunctions_t *) extra; + Uint msize; + void *res; + + erts_mtx_lock(&instr_mutex); + + msize = size + MAP_STAT_BLOCK_HEADER_SIZE; + res = (*real_af->alloc)(n, real_af->extra, msize); + if (res) { + MapStatBlock_t *mb = (MapStatBlock_t *) res; + stat_upd_alloc(n, size); + + mb->size = size; + mb->type_no = n; + mb->pid = erts_get_current_pid(); + + mb->prev = NULL; + mb->next = mem_anchor; + if (mem_anchor) + mem_anchor->prev = mb; + mem_anchor = mb; + + res = (void *) mb->mem; + } + + erts_mtx_unlock(&instr_mutex); + + return res; +} + +static void * +map_stat_realloc(ErtsAlcType_t n, void *extra, void *ptr, Uint size) +{ + ErtsAllocatorFunctions_t *real_af = (ErtsAllocatorFunctions_t *) extra; + Uint old_size; + Uint msize; + void *mptr; + void *res; + + erts_mtx_lock(&instr_x_mutex); + erts_mtx_lock(&instr_mutex); + + if (ptr) { + mptr = (void *) (((char *) ptr) - MAP_STAT_BLOCK_HEADER_SIZE); + old_size = ((MapStatBlock_t *) mptr)->size; + } + else { + mptr = NULL; + old_size = 0; + } + + msize = size + MAP_STAT_BLOCK_HEADER_SIZE; + res = (*real_af->realloc)(n, real_af->extra, mptr, msize); + if (res) { + MapStatBlock_t *mb = (MapStatBlock_t *) res; + + mb->size = size; + mb->type_no = n; + mb->pid = erts_get_current_pid(); + + stat_upd_realloc(n, size, old_size); + + if (mptr != res) { + + if (mptr) { + if (mb->prev) + mb->prev->next = mb; + else { + ASSERT(mem_anchor == (MapStatBlock_t *) mptr); + mem_anchor = mb; + } + if (mb->next) + mb->next->prev = mb; + } + else { + mb->prev = NULL; + mb->next = mem_anchor; + if (mem_anchor) + mem_anchor->prev = mb; + mem_anchor = mb; + } + + } + + res = (void *) mb->mem; + } + + erts_mtx_unlock(&instr_mutex); + erts_mtx_unlock(&instr_x_mutex); + + return res; +} + +static void +map_stat_free(ErtsAlcType_t n, void *extra, void *ptr) +{ + ErtsAllocatorFunctions_t *real_af = (ErtsAllocatorFunctions_t *) extra; + void *mptr; + + erts_mtx_lock(&instr_x_mutex); + erts_mtx_lock(&instr_mutex); + + if (ptr) { + MapStatBlock_t *mb; + + mptr = (void *) (((char *) ptr) - MAP_STAT_BLOCK_HEADER_SIZE); + mb = (MapStatBlock_t *) mptr; + + stat_upd_free(n, mb->size); + + if (mb->prev) + mb->prev->next = mb->next; + else + mem_anchor = mb->next; + if (mb->next) + mb->next->prev = mb->prev; + } + else { + mptr = NULL; + } + + (*real_af->free)(n, real_af->extra, mptr); + + erts_mtx_unlock(&instr_mutex); + erts_mtx_unlock(&instr_x_mutex); + +} + +static void dump_memory_map_to_stream(FILE *fp) +{ + ErtsAlcType_t n; + MapStatBlock_t *bp; + int lock = !ERTS_IS_CRASH_DUMPING; + if (lock) + erts_mtx_lock(&instr_mutex); + + /* Write header */ + + fprintf(fp, + "{instr_hdr,\n" + " %lu,\n" + " %lu,\n" + " {", + (unsigned long) ERTS_INSTR_VSN, + (unsigned long) MAP_STAT_BLOCK_HEADER_SIZE); + +#if ERTS_ALC_N_MIN != 1 +#error ERTS_ALC_N_MIN is not 1 +#endif + + for (n = ERTS_ALC_N_MIN; n <= ERTS_ALC_N_MAX; n++) { + ErtsAlcType_t t = ERTS_ALC_N2T(n); + ErtsAlcType_t a = ERTS_ALC_T2A(t); + ErtsAlcType_t c = ERTS_ALC_T2C(t); + const char *astr; + + if (erts_allctrs_info[a].enabled) + astr = ERTS_ALC_A2AD(a); + else + astr = ERTS_ALC_A2AD(ERTS_ALC_A_SYSTEM); + + fprintf(fp, + "%s{%s,%s,%s}%s", + (n == ERTS_ALC_N_MIN) ? "" : " ", + ERTS_ALC_N2TD(n), + astr, + ERTS_ALC_C2CD(c), + (n == ERTS_ALC_N_MAX) ? "" : ",\n"); + } + + fprintf(fp, "}}.\n"); + + /* Write memory data */ + for (bp = mem_anchor; bp; bp = bp->next) { + if (is_internal_pid(bp->pid)) + fprintf(fp, + "{%lu, %lu, %lu, {%lu,%lu,%lu}}.\n", + (Uint) bp->type_no, + (Uint) bp->mem, + (Uint) bp->size, + (Uint) pid_channel_no(bp->pid), + (Uint) pid_number(bp->pid), + (Uint) pid_serial(bp->pid)); + else + fprintf(fp, + "{%lu, %lu, %lu, undefined}.\n", + (Uint) bp->type_no, + (Uint) bp->mem, + (Uint) bp->size); + } + + if (lock) + erts_mtx_unlock(&instr_mutex); +} + +int erts_instr_dump_memory_map_to_fd(int fd) +{ + char buf[BUFSIZ]; + FILE *f; + + if (!erts_instr_memory_map) + return 0; + + f = fdopen(fd, "w"); + if (f == NULL) + return 0; + + /* Avoid allocating memory; we may have run out of it at this point. */ + setbuf(f, buf); + + dump_memory_map_to_stream(f); + fflush(f); + return 1; +} + +int erts_instr_dump_memory_map(const char *name) +{ + FILE *f; + + if (!erts_instr_memory_map) + return 0; + + f = fopen(name, "w"); + if (f == NULL) + return 0; + + dump_memory_map_to_stream(f); + + fclose(f); + return 1; +} + +Eterm erts_instr_get_memory_map(Process *proc) +{ + MapStatBlock_t *org_mem_anchor; + Eterm hdr_tuple, md_list, res; + Eterm *hp; + Uint hsz; + MapStatBlock_t *bp; +#ifdef DEBUG + Eterm *end_hp; +#endif + + if (!erts_instr_memory_map) + return am_false; + + if (!atoms_initialized) + init_atoms(); + if (!am_n) + init_am_n(); + if (!am_c) + init_am_c(); + if (!am_a) + init_am_a(); + + erts_mtx_lock(&instr_x_mutex); + erts_mtx_lock(&instr_mutex); + + /* Header size */ + hsz = 5 + 1 + (ERTS_ALC_N_MAX+1-ERTS_ALC_N_MIN)*(1 + 4); + + /* Memory data list */ + for (bp = mem_anchor; bp; bp = bp->next) { + if (is_internal_pid(bp->pid)) { +#if (_PID_NUM_SIZE - 1 > MAX_SMALL) + if (internal_pid_number(bp->pid) > MAX_SMALL) + hsz += BIG_UINT_HEAP_SIZE; +#endif +#if (_PID_SER_SIZE - 1 > MAX_SMALL) + if (internal_pid_serial(bp->pid) > MAX_SMALL) + hsz += BIG_UINT_HEAP_SIZE; +#endif + hsz += 4; + } + + if ((Uint) bp->mem > MAX_SMALL) + hsz += BIG_UINT_HEAP_SIZE; + if (bp->size > MAX_SMALL) + hsz += BIG_UINT_HEAP_SIZE; + + hsz += 5 + 2; + } + + hsz += 3; /* Root tuple */ + + org_mem_anchor = mem_anchor; + mem_anchor = NULL; + + erts_mtx_unlock(&instr_mutex); + + hp = HAlloc(proc, hsz); /* May end up calling map_stat_alloc() */ + + erts_mtx_lock(&instr_mutex); + +#ifdef DEBUG + end_hp = hp + hsz; +#endif + + { /* Build header */ + ErtsAlcType_t n; + Eterm type_map; + Uint *hp2 = hp; +#ifdef DEBUG + Uint *hp2_end; +#endif + + hp += (ERTS_ALC_N_MAX + 1 - ERTS_ALC_N_MIN)*4; + +#ifdef DEBUG + hp2_end = hp; +#endif + + type_map = make_tuple(hp); + *(hp++) = make_arityval(ERTS_ALC_N_MAX + 1 - ERTS_ALC_N_MIN); + + for (n = ERTS_ALC_N_MIN; n <= ERTS_ALC_N_MAX; n++) { + ErtsAlcType_t t = ERTS_ALC_N2T(n); + ErtsAlcType_t a = ERTS_ALC_T2A(t); + ErtsAlcType_t c = ERTS_ALC_T2C(t); + + if (!erts_allctrs_info[a].enabled) + a = ERTS_ALC_A_SYSTEM; + + *(hp++) = TUPLE3(hp2, am_n[n], am_a[a], am_c[c]); + hp2 += 4; + } + + ASSERT(hp2 == hp2_end); + + hdr_tuple = TUPLE4(hp, + am.instr_hdr, + make_small(ERTS_INSTR_VSN), + make_small(MAP_STAT_BLOCK_HEADER_SIZE), + type_map); + + hp += 5; + } + + /* Build memory data list */ + + for (md_list = NIL, bp = org_mem_anchor; bp; bp = bp->next) { + Eterm tuple; + Eterm type; + Eterm ptr; + Eterm size; + Eterm pid; + + if (is_not_internal_pid(bp->pid)) + pid = am_undefined; + else { + Eterm c; + Eterm n; + Eterm s; + +#if (ERST_INTERNAL_CHANNEL_NO > MAX_SMALL) +#error Oversized internal channel number +#endif + c = make_small(ERST_INTERNAL_CHANNEL_NO); + +#if (_PID_NUM_SIZE - 1 > MAX_SMALL) + if (internal_pid_number(bp->pid) > MAX_SMALL) { + n = uint_to_big(internal_pid_number(bp->pid), hp); + hp += BIG_UINT_HEAP_SIZE; + } + else +#endif + n = make_small(internal_pid_number(bp->pid)); + +#if (_PID_SER_SIZE - 1 > MAX_SMALL) + if (internal_pid_serial(bp->pid) > MAX_SMALL) { + s = uint_to_big(internal_pid_serial(bp->pid), hp); + hp += BIG_UINT_HEAP_SIZE; + } + else +#endif + s = make_small(internal_pid_serial(bp->pid)); + pid = TUPLE3(hp, c, n, s); + hp += 4; + } + + +#if ERTS_ALC_N_MAX > MAX_SMALL +#error Oversized memory type number +#endif + type = make_small(bp->type_no); + + if ((Uint) bp->mem > MAX_SMALL) { + ptr = uint_to_big((Uint) bp->mem, hp); + hp += BIG_UINT_HEAP_SIZE; + } + else + ptr = make_small((Uint) bp->mem); + + if (bp->size > MAX_SMALL) { + size = uint_to_big(bp->size, hp); + hp += BIG_UINT_HEAP_SIZE; + } + else + size = make_small(bp->size); + + tuple = TUPLE4(hp, type, ptr, size, pid); + hp += 5; + + md_list = CONS(hp, tuple, md_list); + hp += 2; + } + + res = TUPLE2(hp, hdr_tuple, md_list); + + ASSERT(hp + 3 == end_hp); + + if (mem_anchor) { + for (bp = mem_anchor; bp->next; bp = bp->next); + + ASSERT(org_mem_anchor); + org_mem_anchor->prev = bp; + bp->next = org_mem_anchor; + } + else { + mem_anchor = org_mem_anchor; + } + + erts_mtx_unlock(&instr_mutex); + erts_mtx_unlock(&instr_x_mutex); + + return res; +} + +static ERTS_INLINE void +begin_new_max_period(Stat_t *stat, int min, int max) +{ + int i; + for (i = min; i <= max; i++) { + stat[i].max_size = stat[i].size; + stat[i].max_blocks = stat[i].blocks; + } +} + +static ERTS_INLINE void +update_max_ever_values(Stat_t *stat, int min, int max) +{ + int i; + for (i = min; i <= max; i++) { + if (stat[i].max_size_ever < stat[i].max_size) + stat[i].max_size_ever = stat[i].max_size; + if (stat[i].max_blocks_ever < stat[i].max_blocks) + stat[i].max_blocks_ever = stat[i].max_blocks; + } +} + +#define bld_string erts_bld_string +#define bld_tuple erts_bld_tuple +#define bld_tuplev erts_bld_tuplev +#define bld_list erts_bld_list +#define bld_2tup_list erts_bld_2tup_list +#define bld_uint erts_bld_uint + +Eterm +erts_instr_get_stat(Process *proc, Eterm what, int begin_max_period) +{ + int i, len, max, min, allctr; + Eterm *names, *values, res; + Uint arr_size, stat_size, hsz, *hszp, *hp, **hpp; + Stat_t *stat_src, *stat; + + if (!erts_instr_stat) + return am_false; + + if (!atoms_initialized) + init_atoms(); + + if (what == am.total) { + min = 0; + max = 0; + allctr = 0; + stat_size = sizeof(Stat_t); + stat_src = &stats->tot; + if (!am_tot) + init_am_tot(); + names = am_tot; + } + else if (what == am.allocators) { + min = ERTS_ALC_A_MIN; + max = ERTS_ALC_A_MAX; + allctr = 1; + stat_size = sizeof(Stat_t)*(ERTS_ALC_A_MAX+1); + stat_src = stats->a; + if (!am_a) + init_am_a(); + names = am_a; + } + else if (what == am.classes) { + min = ERTS_ALC_C_MIN; + max = ERTS_ALC_C_MAX; + allctr = 0; + stat_size = sizeof(Stat_t)*(ERTS_ALC_C_MAX+1); + stat_src = stats->c; + if (!am_c) + init_am_c(); + names = &am_c[ERTS_ALC_C_MIN]; + } + else if (what == am.types) { + min = ERTS_ALC_N_MIN; + max = ERTS_ALC_N_MAX; + allctr = 0; + stat_size = sizeof(Stat_t)*(ERTS_ALC_N_MAX+1); + stat_src = stats->n; + if (!am_n) + init_am_n(); + names = &am_n[ERTS_ALC_N_MIN]; + } + else { + return THE_NON_VALUE; + } + + stat = (Stat_t *) erts_alloc(ERTS_ALC_T_TMP, stat_size); + + arr_size = (max - min + 1)*sizeof(Eterm); + + if (allctr) + names = (Eterm *) erts_alloc(ERTS_ALC_T_TMP, arr_size); + + values = (Eterm *) erts_alloc(ERTS_ALC_T_TMP, arr_size); + + erts_mtx_lock(&instr_mutex); + + update_max_ever_values(stat_src, min, max); + + sys_memcpy((void *) stat, (void *) stat_src, stat_size); + + if (begin_max_period) + begin_new_max_period(stat_src, min, max); + + erts_mtx_unlock(&instr_mutex); + + hsz = 0; + hszp = &hsz; + hpp = NULL; + + restart_bld: + + len = 0; + for (i = min; i <= max; i++) { + if (!allctr || erts_allctrs_info[i].enabled) { + Eterm s[2]; + + if (allctr) + names[len] = am_a[i]; + + s[0] = bld_tuple(hpp, hszp, 4, + am.sizes, + bld_uint(hpp, hszp, stat[i].size), + bld_uint(hpp, hszp, stat[i].max_size), + bld_uint(hpp, hszp, stat[i].max_size_ever)); + + s[1] = bld_tuple(hpp, hszp, 4, + am.blocks, + bld_uint(hpp, hszp, stat[i].blocks), + bld_uint(hpp, hszp, stat[i].max_blocks), + bld_uint(hpp, hszp, stat[i].max_blocks_ever)); + + values[len] = bld_list(hpp, hszp, 2, s); + + len++; + } + } + + res = bld_2tup_list(hpp, hszp, len, names, values); + + if (!hpp) { + hp = HAlloc(proc, hsz); + hszp = NULL; + hpp = &hp; + goto restart_bld; + } + + erts_free(ERTS_ALC_T_TMP, (void *) stat); + erts_free(ERTS_ALC_T_TMP, (void *) values); + if (allctr) + erts_free(ERTS_ALC_T_TMP, (void *) names); + + return res; +} + +static void +dump_stat_to_stream(FILE *fp, int begin_max_period) +{ + ErtsAlcType_t i, a_max, a_min; + + erts_mtx_lock(&instr_mutex); + + fprintf(fp, + "{instr_vsn,%lu}.\n", + (unsigned long) ERTS_INSTR_VSN); + + update_max_ever_values(&stats->tot, 0, 0); + + fprintf(fp, + "{total,[{total,[{sizes,%lu,%lu,%lu},{blocks,%lu,%lu,%lu}]}]}.\n", + stats->tot.size, + stats->tot.max_size, + stats->tot.max_size_ever, + stats->tot.blocks, + stats->tot.max_blocks, + stats->tot.max_blocks_ever); + + a_max = 0; + a_min = ~0; + for (i = ERTS_ALC_A_MIN; i <= ERTS_ALC_A_MAX; i++) { + if (erts_allctrs_info[i].enabled) { + if (a_min > i) + a_min = i; + if (a_max < i) + a_max = i; + } + } + + ASSERT(ERTS_ALC_A_MIN <= a_min && a_min <= ERTS_ALC_A_MAX); + ASSERT(ERTS_ALC_A_MIN <= a_max && a_max <= ERTS_ALC_A_MAX); + ASSERT(a_min <= a_max); + + update_max_ever_values(stats->a, a_min, a_max); + + for (i = ERTS_ALC_A_MIN; i <= ERTS_ALC_A_MAX; i++) { + if (erts_allctrs_info[i].enabled) { + fprintf(fp, + "%s{%s,[{sizes,%lu,%lu,%lu},{blocks,%lu,%lu,%lu}]}%s", + i == a_min ? "{allocators,\n [" : " ", + ERTS_ALC_A2AD(i), + stats->a[i].size, + stats->a[i].max_size, + stats->a[i].max_size_ever, + stats->a[i].blocks, + stats->a[i].max_blocks, + stats->a[i].max_blocks_ever, + i == a_max ? "]}.\n" : ",\n"); + } + } + + update_max_ever_values(stats->c, ERTS_ALC_C_MIN, ERTS_ALC_C_MAX); + + for (i = ERTS_ALC_C_MIN; i <= ERTS_ALC_C_MAX; i++) { + fprintf(fp, + "%s{%s,[{sizes,%lu,%lu,%lu},{blocks,%lu,%lu,%lu}]}%s", + i == ERTS_ALC_C_MIN ? "{classes,\n [" : " ", + ERTS_ALC_C2CD(i), + stats->c[i].size, + stats->c[i].max_size, + stats->c[i].max_size_ever, + stats->c[i].blocks, + stats->c[i].max_blocks, + stats->c[i].max_blocks_ever, + i == ERTS_ALC_C_MAX ? "]}.\n" : ",\n" ); + } + + update_max_ever_values(stats->n, ERTS_ALC_N_MIN, ERTS_ALC_N_MAX); + + for (i = ERTS_ALC_N_MIN; i <= ERTS_ALC_N_MAX; i++) { + fprintf(fp, + "%s{%s,[{sizes,%lu,%lu,%lu},{blocks,%lu,%lu,%lu}]}%s", + i == ERTS_ALC_N_MIN ? "{types,\n [" : " ", + ERTS_ALC_N2TD(i), + stats->n[i].size, + stats->n[i].max_size, + stats->n[i].max_size_ever, + stats->n[i].blocks, + stats->n[i].max_blocks, + stats->n[i].max_blocks_ever, + i == ERTS_ALC_N_MAX ? "]}.\n" : ",\n" ); + } + + if (begin_max_period) { + begin_new_max_period(&stats->tot, 0, 0); + begin_new_max_period(stats->a, a_min, a_max); + begin_new_max_period(stats->c, ERTS_ALC_C_MIN, ERTS_ALC_C_MAX); + begin_new_max_period(stats->n, ERTS_ALC_N_MIN, ERTS_ALC_N_MAX); + } + + erts_mtx_unlock(&instr_mutex); + +} + +int erts_instr_dump_stat_to_fd(int fd, int begin_max_period) +{ + char buf[BUFSIZ]; + FILE *fp; + + if (!erts_instr_stat) + return 0; + + fp = fdopen(fd, "w"); + if (fp == NULL) + return 0; + + /* Avoid allocating memory; we may have run out of it at this point. */ + setbuf(fp, buf); + + dump_stat_to_stream(fp, begin_max_period); + fflush(fp); + return 1; +} + +int erts_instr_dump_stat(const char *name, int begin_max_period) +{ + FILE *file; + + if (!erts_instr_stat) + return 0; + + file = fopen(name, "w"); + if (file == NULL) + return 0; + + dump_stat_to_stream(file, begin_max_period); + + fclose(file); + return 1; +} + + +Uint +erts_instr_get_total(void) +{ + return erts_instr_stat ? stats->tot.size : 0; +} + +Uint +erts_instr_get_max_total(void) +{ + if (erts_instr_stat) { + update_max_ever_values(&stats->tot, 0, 0); + return stats->tot.max_size_ever; + } + return 0; +} + +Eterm +erts_instr_get_type_info(Process *proc) +{ + Eterm res, *tpls; + Uint hsz, *hszp, *hp, **hpp; + ErtsAlcType_t n; + + if (!am_n) + init_am_n(); + if (!am_a) + init_am_a(); + if (!am_c) + init_am_c(); + + tpls = (Eterm *) erts_alloc(ERTS_ALC_T_TMP, + (ERTS_ALC_N_MAX-ERTS_ALC_N_MIN+1) + * sizeof(Eterm)); + hsz = 0; + hszp = &hsz; + hpp = NULL; + + restart_bld: + +#if ERTS_ALC_N_MIN != 1 +#error ERTS_ALC_N_MIN is not 1 +#endif + + for (n = ERTS_ALC_N_MIN; n <= ERTS_ALC_N_MAX; n++) { + ErtsAlcType_t t = ERTS_ALC_N2T(n); + ErtsAlcType_t a = ERTS_ALC_T2A(t); + ErtsAlcType_t c = ERTS_ALC_T2C(t); + + if (!erts_allctrs_info[a].enabled) + a = ERTS_ALC_A_SYSTEM; + + tpls[n - ERTS_ALC_N_MIN] + = bld_tuple(hpp, hszp, 3, am_n[n], am_a[a], am_c[c]); + } + + res = bld_tuplev(hpp, hszp, ERTS_ALC_N_MAX-ERTS_ALC_N_MIN+1, tpls); + + if (!hpp) { + hp = HAlloc(proc, hsz); + hszp = NULL; + hpp = &hp; + goto restart_bld; + } + + erts_free(ERTS_ALC_T_TMP, tpls); + + return res; +} + +Uint +erts_instr_init(int stat, int map_stat) +{ + int i; + + am_tot = NULL; + am_n = NULL; + am_c = NULL; + am_a = NULL; + + erts_instr_memory_map = 0; + erts_instr_stat = 0; + atoms_initialized = 0; + + if (!stat && !map_stat) + return 0; + + stats = erts_alloc(ERTS_ALC_T_INSTR_INFO, sizeof(struct stats_)); + + erts_mtx_init(&instr_mutex, "instr"); + + mem_anchor = NULL; + + /* Install instrumentation functions */ + ASSERT(sizeof(erts_allctrs) == sizeof(real_allctrs)); + + sys_memcpy((void *)real_allctrs,(void *)erts_allctrs,sizeof(erts_allctrs)); + + sys_memzero((void *) &stats->tot, sizeof(Stat_t)); + sys_memzero((void *) stats->a, sizeof(Stat_t)*(ERTS_ALC_A_MAX+1)); + sys_memzero((void *) stats->c, sizeof(Stat_t)*(ERTS_ALC_C_MAX+1)); + sys_memzero((void *) stats->n, sizeof(Stat_t)*(ERTS_ALC_N_MAX+1)); + + for (i = ERTS_ALC_A_MIN; i <= ERTS_ALC_A_MAX; i++) { + if (erts_allctrs_info[i].enabled) + stats->ap[i] = &stats->a[i]; + else + stats->ap[i] = &stats->a[ERTS_ALC_A_SYSTEM]; + } + + if (map_stat) { + + erts_mtx_init(&instr_x_mutex, "instr_x"); + + erts_instr_memory_map = 1; + erts_instr_stat = 1; + for (i = ERTS_ALC_A_MIN; i <= ERTS_ALC_A_MAX; i++) { + erts_allctrs[i].alloc = map_stat_alloc; + erts_allctrs[i].realloc = map_stat_realloc; + erts_allctrs[i].free = map_stat_free; + erts_allctrs[i].extra = (void *) &real_allctrs[i]; + } + return MAP_STAT_BLOCK_HEADER_SIZE; + } + else { + erts_instr_stat = 1; + for (i = ERTS_ALC_A_MIN; i <= ERTS_ALC_A_MAX; i++) { + erts_allctrs[i].alloc = stat_alloc; + erts_allctrs[i].realloc = stat_realloc; + erts_allctrs[i].free = stat_free; + erts_allctrs[i].extra = (void *) &real_allctrs[i]; + } + return STAT_BLOCK_HEADER_SIZE; + } + +} + diff --git a/erts/emulator/beam/erl_instrument.h b/erts/emulator/beam/erl_instrument.h new file mode 100644 index 0000000000..37b9b67139 --- /dev/null +++ b/erts/emulator/beam/erl_instrument.h @@ -0,0 +1,41 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2003-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifndef ERL_INSTRUMENT_H__ +#define ERL_INSTRUMENT_H__ + +#include "erl_mtrace.h" + +#define ERTS_INSTR_VSN 2 + +extern int erts_instr_memory_map; +extern int erts_instr_stat; + +Uint erts_instr_init(int stat, int map_stat); +int erts_instr_dump_memory_map_to_fd(int fd); +int erts_instr_dump_memory_map(const char *name); +Eterm erts_instr_get_memory_map(Process *process); +int erts_instr_dump_stat_to_fd(int fd, int begin_max_period); +int erts_instr_dump_stat(const char *name, int begin_max_period); +Eterm erts_instr_get_stat(Process *proc, Eterm what, int begin_max_period); +Eterm erts_instr_get_type_info(Process *proc); +Uint erts_instr_get_total(void); +Uint erts_instr_get_max_total(void); + +#endif diff --git a/erts/emulator/beam/erl_lock_check.c b/erts/emulator/beam/erl_lock_check.c new file mode 100644 index 0000000000..25f1d420d1 --- /dev/null +++ b/erts/emulator/beam/erl_lock_check.c @@ -0,0 +1,1307 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2005-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* + * Description: A lock checker that checks that each thread acquires + * locks according to a predefined global lock order. The + * global lock order is used to prevent deadlocks. If the + * lock order is violated, an error message is printed + * and the emulator aborts. The lock checker is only + * intended to be enabled when debugging. + * + * Author: Rickard Green + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +/* Needed for VxWorks va_arg */ +#include "sys.h" + +#ifdef ERTS_ENABLE_LOCK_CHECK + +#include "erl_lock_check.h" +#include "erl_term.h" +#include "erl_threads.h" + +typedef struct { + char *name; + char *internal_order; +} erts_lc_lock_order_t; + +/* + * Global lock order for locks in the emulator. + * + * Locks early (low indexes) in the 'erts_lock_order' array should be + * locked before locks late (high indexes) in the array. Each lock has + * a name which is set on initialization. If multiple locks with the + * same name are used, either an immediate Erlang term (e.g. internal + * pid) or the address of the lock is used for internal lock order. + * The immediate Erlang term used for internal lock order is also set + * on initialization. Locks with small immediate Erlang terms should + * be locked before locks with large immediate Erlang terms, and + * locks with small addresses should be locked before locks with + * large addresses. The immediate terms and adresses (boxed pointers) + * are compared as unsigned integers not as Erlang terms. + * + * Once a spinlock or rw(spin)lock has been locked, the thread is not + * allowed to lock mutexes, rwmutexes or process locks until all + * spinlocks and rwlocks have been unlocked. This restriction is not + * reflected by the lock order below, but the lock checker will still + * check for violations of this restriction. + */ +static erts_lc_lock_order_t erts_lock_order[] = { + /* + * "Lock name" "Internal lock order + * description (NULL + * if only one lock use + * the lock name)" + */ +#ifdef ERTS_SMP + { "driver_lock", "driver_name" }, + { "port_lock", "port_id" }, +#endif + { "port_data_lock", "address" }, +#ifdef ERTS_SMP + { "bif_timers", NULL }, + { "reg_tab", NULL }, + { "migration_info_update", NULL }, + { "proc_main", "pid" }, + { "nodes_monitors", NULL }, + { "driver_list", NULL }, + { "proc_link", "pid" }, + { "proc_msgq", "pid" }, + { "dist_entry", "address" }, + { "dist_entry_links", "address" }, + { "proc_status", "pid" }, + { "proc_tab", NULL }, + { "ports_snapshot", NULL }, + { "db_tab", "address" }, + { "db_tab_fix", "address" }, + { "meta_name_tab", "address" }, + { "meta_main_tab_slot", "address" }, + { "meta_main_tab_main", NULL }, + { "db_hash_slot", "address" }, + { "node_table", NULL }, + { "dist_table", NULL }, + { "sys_tracers", NULL }, + { "trace_pattern", NULL }, + { "module_tab", NULL }, + { "export_tab", NULL }, + { "fun_tab", NULL }, + { "environ", NULL }, +#endif + { "asyncq", "address" }, +#ifndef ERTS_SMP + { "async_ready", NULL }, +#endif + { "efile_drv", "address" }, +#if defined(ENABLE_CHILD_WAITER_THREAD) || defined(ERTS_SMP) + { "child_status", NULL }, +#endif +#ifdef __WIN32__ + { "sys_driver_data_lock", NULL }, +#endif + { "drv_ev_state_grow", NULL, }, + { "drv_ev_state", "address" }, + { "safe_hash", "address" }, + { "pollset_rm_list", NULL }, + { "removed_fd_pre_alloc_lock", NULL }, + { "state_prealloc", NULL }, + { "schdlr_sspnd", NULL }, + { "cpu_bind", NULL }, + { "run_queue", "address" }, + { "pollset", "address" }, +#ifdef __WIN32__ + { "pollwaiter", "address" }, + { "break_waiter_lock", NULL }, +#endif /* __WIN32__ */ + { "alcu_init_atoms", NULL }, + { "mseg_init_atoms", NULL }, + { "drv_tsd", NULL }, +#ifdef ERTS_SMP + { "sys_msg_q", NULL }, + { "atom_tab", NULL }, + { "make_ref", NULL }, + { "misc_op_list_pre_alloc_lock", "address" }, + { "message_pre_alloc_lock", "address" }, + { "ptimer_pre_alloc_lock", "address", }, + { "btm_pre_alloc_lock", NULL, }, + { "dist_entry_out_queue", "address" }, +#endif + { "mtrace_op", NULL }, + { "instr_x", NULL }, + { "instr", NULL }, + { "fix_alloc", "index" }, + { "alcu_allocator", "index" }, + { "mseg", NULL }, +#ifdef ERTS_SMP + { "port_task_pre_alloc_lock", "address" }, + { "port_taskq_pre_alloc_lock", "address" }, + { "proclist_pre_alloc_lock", "address" }, + { "port_tasks_lock", NULL }, + { "get_free_port", NULL }, + { "port_state", "address" }, + { "xports_list_pre_alloc_lock", "address" }, + { "inet_buffer_stack_lock", NULL }, + { "gc_info", NULL }, + { "io_wake", NULL }, + { "timer_wheel", NULL }, + { "system_block", NULL }, + { "timeofday", NULL }, + { "breakpoints", NULL }, + { "pollsets_lock", NULL }, + { "async_id", NULL }, + { "pix_lock", "address" }, + { "run_queues_lists", NULL }, + { "sched_stat", NULL }, +#endif + { "alloc_thr_ix_lock", NULL }, +#ifdef ERTS_SMP + { "proc_lck_wtr_alloc", NULL }, +#endif +#ifdef __WIN32__ +#ifdef DEBUG + { "save_ops_lock", NULL }, +#endif +#endif + { "mtrace_buf", NULL } +}; + +#define ERTS_LOCK_ORDER_SIZE \ + (sizeof(erts_lock_order)/sizeof(erts_lc_lock_order_t)) + +#define LOCK_IS_TYPE_ORDER_VIOLATION(LCK_FLG, LCKD_FLG) \ + (((LCKD_FLG) & (ERTS_LC_FLG_LT_SPINLOCK|ERTS_LC_FLG_LT_RWSPINLOCK)) \ + && ((LCK_FLG) \ + & ERTS_LC_FLG_LT_ALL \ + & ~(ERTS_LC_FLG_LT_SPINLOCK|ERTS_LC_FLG_LT_RWSPINLOCK))) + +static char * +lock_type(Uint16 flags) +{ + switch (flags & ERTS_LC_FLG_LT_ALL) { + case ERTS_LC_FLG_LT_SPINLOCK: return "[spinlock]"; + case ERTS_LC_FLG_LT_RWSPINLOCK: return "[rw(spin)lock]"; + case ERTS_LC_FLG_LT_MUTEX: return "[mutex]"; + case ERTS_LC_FLG_LT_RWMUTEX: return "[rwmutex]"; + case ERTS_LC_FLG_LT_PROCLOCK: return "[proclock]"; + default: return ""; + } +} + +static char * +rw_op_str(Uint16 flags) +{ + switch (flags & ERTS_LC_FLG_LO_READ_WRITE) { + case ERTS_LC_FLG_LO_READ_WRITE: + return " (rw)"; + case ERTS_LC_FLG_LO_READ: + return " (r)"; + case ERTS_LC_FLG_LO_WRITE: + erts_fprintf(stderr, "\nInternal error\n"); + abort(); + default: + break; + } + return ""; +} + +typedef struct erts_lc_locked_lock_t_ erts_lc_locked_lock_t; +struct erts_lc_locked_lock_t_ { + erts_lc_locked_lock_t *next; + erts_lc_locked_lock_t *prev; + Eterm extra; + Sint16 id; + Uint16 flags; +}; + +typedef struct { + erts_lc_locked_lock_t *first; + erts_lc_locked_lock_t *last; +} erts_lc_locked_lock_list_t; + +typedef struct erts_lc_locked_locks_t_ erts_lc_locked_locks_t; +struct erts_lc_locked_locks_t_ { + char *thread_name; + erts_tid_t tid; + erts_lc_locked_locks_t *next; + erts_lc_locked_locks_t *prev; + erts_lc_locked_lock_list_t locked; + erts_lc_locked_lock_list_t required; +}; + +typedef union erts_lc_free_block_t_ erts_lc_free_block_t; +union erts_lc_free_block_t_ { + erts_lc_free_block_t *next; + erts_lc_locked_lock_t lock; +}; + +static ethr_tsd_key locks_key; + +static erts_lc_locked_locks_t *erts_locked_locks; + +static erts_lc_free_block_t *free_blocks; + +#ifdef ERTS_LC_STATIC_ALLOC +#define ERTS_LC_FB_CHUNK_SIZE 10000 +#else +#define ERTS_LC_FB_CHUNK_SIZE 10 +#endif + +#ifdef ETHR_HAVE_NATIVE_LOCKS +static ethr_spinlock_t free_blocks_lock; +#define ERTS_LC_LOCK ethr_spin_lock +#define ERTS_LC_UNLOCK ethr_spin_unlock +#else +static ethr_mutex free_blocks_lock; +#define ERTS_LC_LOCK ethr_mutex_lock +#define ERTS_LC_UNLOCK ethr_mutex_unlock +#endif + +static ERTS_INLINE void +lc_lock(void) +{ + if (ERTS_LC_LOCK(&free_blocks_lock) != 0) + abort(); +} + +static ERTS_INLINE void +lc_unlock(void) +{ + if (ERTS_LC_UNLOCK(&free_blocks_lock) != 0) + abort(); +} + +static ERTS_INLINE void lc_free(void *p) +{ + erts_lc_free_block_t *fb = (erts_lc_free_block_t *) p; +#ifdef DEBUG + memset((void *) p, 0xdf, sizeof(erts_lc_free_block_t)); +#endif + lc_lock(); + fb->next = free_blocks; + free_blocks = fb; + lc_unlock(); +} + +#ifdef ERTS_LC_STATIC_ALLOC + +static void *lc_core_alloc(void) +{ + lc_unlock(); + erts_fprintf(stderr, "Lock checker out of memory!\n"); + abort(); +} + +#else + +static void *lc_core_alloc(void) +{ + int i; + erts_lc_free_block_t *fbs; + lc_unlock(); + fbs = (erts_lc_free_block_t *) malloc(sizeof(erts_lc_free_block_t) + * ERTS_LC_FB_CHUNK_SIZE); + if (!fbs) { + erts_fprintf(stderr, "Lock checker failed to allocate memory!\n"); + abort(); + } + for (i = 1; i < ERTS_LC_FB_CHUNK_SIZE - 1; i++) { +#ifdef DEBUG + memset((void *) &fbs[i], 0xdf, sizeof(erts_lc_free_block_t)); +#endif + fbs[i].next = &fbs[i+1]; + } +#ifdef DEBUG + memset((void *) &fbs[ERTS_LC_FB_CHUNK_SIZE-1], + 0xdf, sizeof(erts_lc_free_block_t)); +#endif + lc_lock(); + fbs[ERTS_LC_FB_CHUNK_SIZE-1].next = free_blocks; + free_blocks = &fbs[1]; + return (void *) &fbs[0]; +} + +#endif + +static ERTS_INLINE void *lc_alloc(void) +{ + void *res; + lc_lock(); + if (!free_blocks) + res = lc_core_alloc(); + else { + res = (void *) free_blocks; + free_blocks = free_blocks->next; + } + lc_unlock(); + return res; +} + + +static erts_lc_locked_locks_t * +create_locked_locks(char *thread_name) +{ + erts_lc_locked_locks_t *l_lcks = malloc(sizeof(erts_lc_locked_locks_t)); + if (!l_lcks) + abort(); + + l_lcks->thread_name = strdup(thread_name ? thread_name : "unknown"); + if (!l_lcks->thread_name) + abort(); + + l_lcks->tid = erts_thr_self(); + l_lcks->required.first = NULL; + l_lcks->required.last = NULL; + l_lcks->locked.first = NULL; + l_lcks->locked.last = NULL; + l_lcks->prev = NULL; + lc_lock(); + l_lcks->next = erts_locked_locks; + if (erts_locked_locks) + erts_locked_locks->prev = l_lcks; + erts_locked_locks = l_lcks; + lc_unlock(); + erts_tsd_set(locks_key, (void *) l_lcks); + return l_lcks; +} + +static void +destroy_locked_locks(erts_lc_locked_locks_t *l_lcks) +{ + ASSERT(l_lcks->thread_name); + free((void *) l_lcks->thread_name); + ASSERT(l_lcks->required.first == NULL); + ASSERT(l_lcks->required.last == NULL); + ASSERT(l_lcks->locked.first == NULL); + ASSERT(l_lcks->locked.last == NULL); + + lc_lock(); + if (l_lcks->prev) + l_lcks->prev->next = l_lcks->next; + else { + ASSERT(erts_locked_locks == l_lcks); + erts_locked_locks = l_lcks->next; + } + + if (l_lcks->next) + l_lcks->next->prev = l_lcks->prev; + lc_unlock(); + + free((void *) l_lcks); + +} + +static ERTS_INLINE erts_lc_locked_locks_t * +get_my_locked_locks(void) +{ + return erts_tsd_get(locks_key); +} + +static ERTS_INLINE erts_lc_locked_locks_t * +make_my_locked_locks(void) +{ + erts_lc_locked_locks_t *l_lcks = get_my_locked_locks(); + if (l_lcks) + return l_lcks; + else + return create_locked_locks(NULL); +} + +static ERTS_INLINE erts_lc_locked_lock_t * +new_locked_lock(erts_lc_lock_t *lck, Uint16 op_flags) +{ + erts_lc_locked_lock_t *l_lck = (erts_lc_locked_lock_t *) lc_alloc(); + l_lck->next = NULL; + l_lck->prev = NULL; + l_lck->id = lck->id; + l_lck->extra = lck->extra; + l_lck->flags = lck->flags | op_flags; + return l_lck; +} + +static void +print_lock2(char *prefix, Sint16 id, Eterm extra, Uint16 flags, char *suffix) +{ + char *lname = (0 <= id && id < ERTS_LOCK_ORDER_SIZE + ? erts_lock_order[id].name + : "unknown"); + if (is_boxed(extra)) + erts_fprintf(stderr, + "%s'%s:%p%s'%s%s", + prefix, + lname, + boxed_val(extra), + lock_type(flags), + rw_op_str(flags), + suffix); + else + erts_fprintf(stderr, + "%s'%s:%T%s'%s%s", + prefix, + lname, + extra, + lock_type(flags), + rw_op_str(flags), + suffix); +} + +static void +print_lock(char *prefix, erts_lc_lock_t *lck, char *suffix) +{ + print_lock2(prefix, lck->id, lck->extra, lck->flags, suffix); +} + +static void +print_curr_locks(erts_lc_locked_locks_t *l_lcks) +{ + erts_lc_locked_lock_t *l_lck; + if (!l_lcks || !l_lcks->locked.first) + erts_fprintf(stderr, + "Currently no locks are locked by the %s thread.\n", + l_lcks->thread_name); + else { + erts_fprintf(stderr, + "Currently these locks are locked by the %s thread:\n", + l_lcks->thread_name); + for (l_lck = l_lcks->locked.first; l_lck; l_lck = l_lck->next) + print_lock2(" ", l_lck->id, l_lck->extra, l_lck->flags, "\n"); + } +} + +static void +print_lock_order(void) +{ + int i; + erts_fprintf(stderr, "Lock order:\n"); + for (i = 1; i < ERTS_LOCK_ORDER_SIZE; i++) { + if (erts_lock_order[i].internal_order) + erts_fprintf(stderr, + " %s:%s\n", + erts_lock_order[i].name, + erts_lock_order[i].internal_order); + else + erts_fprintf(stderr, " %s\n", erts_lock_order[i].name); + } +} + +static void +uninitialized_lock(void) +{ + erts_fprintf(stderr, "Performing operations on uninitialized lock!\n"); + print_curr_locks(get_my_locked_locks()); + abort(); +} + +static void +lock_twice(char *prefix, erts_lc_locked_locks_t *l_lcks, erts_lc_lock_t *lck, + Uint16 op_flags) +{ + erts_fprintf(stderr, "%s%s", prefix, rw_op_str(op_flags)); + print_lock(" ", lck, " lock which is already locked by thread!\n"); + print_curr_locks(l_lcks); + abort(); +} + +static void +unlock_op_mismatch(erts_lc_locked_locks_t *l_lcks, erts_lc_lock_t *lck, + Uint16 op_flags) +{ + erts_fprintf(stderr, "Unlocking%s ", rw_op_str(op_flags)); + print_lock("", lck, " lock which mismatch previous lock operation!\n"); + print_curr_locks(l_lcks); + abort(); +} + +static void +unlock_of_not_locked(erts_lc_locked_locks_t *l_lcks, erts_lc_lock_t *lck) +{ + print_lock("Unlocking ", lck, " lock which is not locked by thread!\n"); + print_curr_locks(l_lcks); + abort(); +} + +static void +lock_order_violation(erts_lc_locked_locks_t *l_lcks, erts_lc_lock_t *lck) +{ + print_lock("Lock order violation occured when locking ", lck, "!\n"); + print_curr_locks(l_lcks); + print_lock_order(); + abort(); +} + +static void +type_order_violation(char *op, erts_lc_locked_locks_t *l_lcks, + erts_lc_lock_t *lck) +{ + erts_fprintf(stderr, "Lock type order violation occured when "); + print_lock(op, lck, "!\n"); + ASSERT(l_lcks); + print_curr_locks(l_lcks); + abort(); +} + +static void +lock_mismatch(erts_lc_locked_locks_t *l_lcks, int exact, + int failed_have, erts_lc_lock_t *have, int have_len, + int failed_have_not, erts_lc_lock_t *have_not, int have_not_len) +{ + int i; + erts_fprintf(stderr, "Lock mismatch found!\n"); + if (failed_have >= 0) { + ASSERT(have && have_len > failed_have); + print_lock2("At least the ", + have[failed_have].id, have[failed_have].extra, 0, + " lock is not locked when it should have been\n"); + } + else if (failed_have_not >= 0) { + ASSERT(have_not && have_not_len > failed_have_not); + print_lock2("At least the ", + have_not[failed_have_not].id, + have_not[failed_have_not].extra, + 0, + " lock is locked when it should not have been\n"); + } + if (exact) { + if (!have || have_len <= 0) + erts_fprintf(stderr, + "Thread should not have any locks locked at all\n"); + else { + erts_fprintf(stderr, + "Thread should have these and only these locks " + "locked:\n"); + for (i = 0; i < have_len; i++) + print_lock2(" ", have[i].id, have[i].extra, 0, "\n"); + } + } + else { + if (have && have_len > 0) { + erts_fprintf(stderr, + "Thread should at least have these locks locked:\n"); + for (i = 0; i < have_len; i++) + print_lock2(" ", have[i].id, have[i].extra, 0, "\n"); + } + if (have_not && have_not_len > 0) { + erts_fprintf(stderr, + "Thread should at least not have these locks " + "locked:\n"); + for (i = 0; i < have_not_len; i++) + print_lock2(" ", have_not[i].id, have_not[i].extra, 0, "\n"); + } + } + print_curr_locks(l_lcks); + abort(); +} + +static void +unlock_of_required_lock(erts_lc_locked_locks_t *l_lcks, erts_lc_lock_t *lck) +{ + print_lock("Unlocking required ", lck, " lock!\n"); + print_curr_locks(l_lcks); + abort(); +} + +static void +unrequire_of_not_required_lock(erts_lc_locked_locks_t *l_lcks, erts_lc_lock_t *lck) +{ + print_lock("Unrequire on ", lck, " lock not required!\n"); + print_curr_locks(l_lcks); + abort(); +} + +static void +require_twice(erts_lc_locked_locks_t *l_lcks, erts_lc_lock_t *lck) +{ + print_lock("Require on ", lck, " lock already required!\n"); + print_curr_locks(l_lcks); + abort(); +} + +static void +required_not_locked(erts_lc_locked_locks_t *l_lcks, erts_lc_lock_t *lck) +{ + print_lock("Required ", lck, " lock not locked!\n"); + print_curr_locks(l_lcks); + abort(); +} + + +static void +thread_exit_handler(void) +{ + erts_lc_locked_locks_t *l_lcks = get_my_locked_locks(); + if (l_lcks) { + if (l_lcks->locked.first) { + erts_fprintf(stderr, + "Thread exiting while having locked locks!\n"); + print_curr_locks(l_lcks); + abort(); + } + destroy_locked_locks(l_lcks); + /* erts_tsd_set(locks_key, NULL); */ + } +} + +void +erts_lc_set_thread_name(char *thread_name) +{ + erts_lc_locked_locks_t *l_lcks = get_my_locked_locks(); + if (!l_lcks) + (void) create_locked_locks(thread_name); + else { + ASSERT(l_lcks->thread_name); + free((void *) l_lcks->thread_name); + l_lcks->thread_name = strdup(thread_name ? thread_name : "unknown"); + if (!l_lcks->thread_name) + abort(); + } +} + +int +erts_lc_assert_failed(char *file, int line, char *assertion) +{ + erts_fprintf(stderr, "%s:%d: Lock check assertion \"%s\" failed!\n", + file, line, assertion); + print_curr_locks(get_my_locked_locks()); + abort(); + return 0; +} + +void erts_lc_fail(char *fmt, ...) +{ + va_list args; + erts_fprintf(stderr, "Lock check failed: "); + va_start(args, fmt); + erts_vfprintf(stderr, fmt, args); + va_end(args); + erts_fprintf(stderr, "\n"); + print_curr_locks(get_my_locked_locks()); + abort(); +} + + +Sint16 +erts_lc_get_lock_order_id(char *name) +{ + int i; + + if (!name || name[0] == '\0') + erts_fprintf(stderr, "Missing lock name\n"); + else { + for (i = 0; i < ERTS_LOCK_ORDER_SIZE; i++) + if (strcmp(erts_lock_order[i].name, name) == 0) + return i; + erts_fprintf(stderr, + "Lock name '%s' missing in lock order " + "(update erl_lock_check.c)\n", + name); + } + abort(); + return (Sint16) -1; +} + + +static int +find_lock(erts_lc_locked_lock_t **l_lcks, erts_lc_lock_t *lck) +{ + erts_lc_locked_lock_t *l_lck = *l_lcks; + + if (l_lck) { + if (l_lck->id == lck->id && l_lck->extra == lck->extra) { + if ((l_lck->flags & lck->flags) == lck->flags) + return 1; + return 0; + } + else if (l_lck->id < lck->id + || (l_lck->id == lck->id + && l_lck->extra < lck->extra)) { + for (l_lck = l_lck->next; l_lck; l_lck = l_lck->next) { + if (l_lck->id > lck->id + || (l_lck->id == lck->id + && l_lck->extra >= lck->extra)) { + *l_lcks = l_lck; + if (l_lck->id == lck->id + && l_lck->extra == lck->extra + && ((l_lck->flags & lck->flags) == lck->flags)) + return 1; + return 0; + } + } + } + else { + for (l_lck = l_lck->prev; l_lck; l_lck = l_lck->prev) { + if (l_lck->id < lck->id + || (l_lck->id == lck->id + && l_lck->extra <= lck->extra)) { + *l_lcks = l_lck; + if (l_lck->id == lck->id + && l_lck->extra == lck->extra + && ((l_lck->flags & lck->flags) == lck->flags)) + return 1; + return 0; + } + } + } + } + return 0; +} + +static int +find_id(erts_lc_locked_lock_t **l_lcks, Sint16 id) +{ + erts_lc_locked_lock_t *l_lck = *l_lcks; + + if (l_lck) { + if (l_lck->id == id) + return 1; + else if (l_lck->id < id) { + for (l_lck = l_lck->next; l_lck; l_lck = l_lck->next) { + if (l_lck->id >= id) { + *l_lcks = l_lck; + if (l_lck->id == id) + return 1; + return 0; + } + } + } + else { + for (l_lck = l_lck->prev; l_lck; l_lck = l_lck->prev) { + if (l_lck->id <= id) { + *l_lcks = l_lck; + if (l_lck->id == id) + return 1; + return 0; + } + } + } + } + return 0; +} + +void +erts_lc_have_locks(int *resv, erts_lc_lock_t *locks, int len) +{ + erts_lc_locked_locks_t *l_lcks = get_my_locked_locks(); + int i; + + if (!l_lcks) { + for (i = 0; i < len; i++) + resv[i] = 0; + } + else { + erts_lc_locked_lock_t *l_lck = l_lcks->locked.first; + for (i = 0; i < len; i++) + resv[i] = find_lock(&l_lck, &locks[i]); + } +} + +void +erts_lc_have_lock_ids(int *resv, int *ids, int len) +{ + erts_lc_locked_locks_t *l_lcks = get_my_locked_locks(); + int i; + + if (!l_lcks) { + for (i = 0; i < len; i++) + resv[i] = 0; + } + else { + erts_lc_locked_lock_t *l_lck = l_lcks->locked.first; + for (i = 0; i < len; i++) + resv[i] = find_id(&l_lck, ids[i]); + } +} + +void +erts_lc_check(erts_lc_lock_t *have, int have_len, + erts_lc_lock_t *have_not, int have_not_len) +{ + int i; + erts_lc_locked_locks_t *l_lcks = get_my_locked_locks(); + erts_lc_locked_lock_t *l_lck; + + if (have && have_len > 0) { + if (!l_lcks) + lock_mismatch(NULL, 0, + -1, have, have_len, + -1, have_not, have_not_len); + l_lck = l_lcks->locked.first; + for (i = 0; i < have_len; i++) { + if (!find_lock(&l_lck, &have[i])) + lock_mismatch(l_lcks, 0, + i, have, have_len, + -1, have_not, have_not_len); + } + } + if (have_not && have_not_len > 0 && l_lcks) { + l_lck = l_lcks->locked.first; + for (i = 0; i < have_not_len; i++) { + if (find_lock(&l_lck, &have_not[i])) + lock_mismatch(l_lcks, 0, + -1, have, have_len, + i, have_not, have_not_len); + } + } +} + +void +erts_lc_check_exact(erts_lc_lock_t *have, int have_len) +{ + erts_lc_locked_locks_t *l_lcks = get_my_locked_locks(); + if (!l_lcks) { + if (have && have_len > 0) + lock_mismatch(NULL, 1, + -1, have, have_len, + -1, NULL, 0); + } + else { + int i; + erts_lc_locked_lock_t *l_lck = l_lcks->locked.first; + for (i = 0; i < have_len; i++) { + if (!find_lock(&l_lck, &have[i])) + lock_mismatch(l_lcks, 1, + i, have, have_len, + -1, NULL, 0); + } + for (i = 0, l_lck = l_lcks->locked.first; l_lck; l_lck = l_lck->next) + i++; + if (i != have_len) + lock_mismatch(l_lcks, 1, + -1, have, have_len, + -1, NULL, 0); + } +} + +int +erts_lc_trylock_force_busy_flg(erts_lc_lock_t *lck, Uint16 op_flags) +{ +#ifdef ERTS_LC_DO_NOT_FORCE_BUSY_TRYLOCK_ON_LOCK_ORDER_VIOLATION + return 0; +#else + /* + * Force busy trylock if locking doesn't follow lock order. + * This in order to make sure that caller can handle + * the situation without causing a lock order violation. + */ + erts_lc_locked_locks_t *l_lcks; + + if (lck->inited != ERTS_LC_INITITALIZED) + uninitialized_lock(); + + if (lck->id < 0) + return 0; + + l_lcks = get_my_locked_locks(); + + if (!l_lcks || !l_lcks->locked.first) { + ASSERT(!l_lcks || !l_lcks->locked.last); + return 0; + } + else { + erts_lc_locked_lock_t *tl_lck; + + ASSERT(l_lcks->locked.last); + +#if 0 /* Ok when trylocking I guess... */ + if (LOCK_IS_TYPE_ORDER_VIOLATION(lck->flags, l_lcks->locked.last->flags)) + type_order_violation("trylocking ", l_lcks, lck); +#endif + + if (l_lcks->locked.last->id < lck->id + || (l_lcks->locked.last->id == lck->id + && l_lcks->locked.last->extra < lck->extra)) + return 0; + + /* + * Lock order violation + */ + + + /* Check that we are not trying to lock this lock twice */ + for (tl_lck = l_lcks->locked.last; tl_lck; tl_lck = tl_lck->prev) { + if (tl_lck->id < lck->id + || (tl_lck->id == lck->id && tl_lck->extra <= lck->extra)) { + if (tl_lck->id == lck->id && tl_lck->extra == lck->extra) + lock_twice("Trylocking", l_lcks, lck, op_flags); + break; + } + } + +#ifndef ERTS_LC_ALLWAYS_FORCE_BUSY_TRYLOCK_ON_LOCK_ORDER_VIOLATION + /* We only force busy if a lock order violation would occur + and when on an even millisecond. */ + { + erts_thr_timeval_t time; + erts_thr_time_now(&time); + + if ((time.tv_nsec / 1000000) & 1) + return 0; + } +#endif + + return 1; + } +#endif +} + +void erts_lc_trylock_flg(int locked, erts_lc_lock_t *lck, Uint16 op_flags) +{ + erts_lc_locked_locks_t *l_lcks; + erts_lc_locked_lock_t *l_lck; + + if (lck->inited != ERTS_LC_INITITALIZED) + uninitialized_lock(); + + if (lck->id < 0) + return; + + l_lcks = make_my_locked_locks(); + l_lck = locked ? new_locked_lock(lck, op_flags) : NULL; + + if (!l_lcks->locked.last) { + ASSERT(!l_lcks->locked.first); + if (locked) + l_lcks->locked.first = l_lcks->locked.last = l_lck; + } + else { + erts_lc_locked_lock_t *tl_lck; +#if 0 /* Ok when trylocking I guess... */ + if (LOCK_IS_TYPE_ORDER_VIOLATION(lck->flags, l_lcks->locked.last->flags)) + type_order_violation("trylocking ", l_lcks, lck); +#endif + + for (tl_lck = l_lcks->locked.last; tl_lck; tl_lck = tl_lck->prev) { + if (tl_lck->id < lck->id + || (tl_lck->id == lck->id && tl_lck->extra <= lck->extra)) { + if (tl_lck->id == lck->id && tl_lck->extra == lck->extra) + lock_twice("Trylocking", l_lcks, lck, op_flags); + if (locked) { + l_lck->next = tl_lck->next; + l_lck->prev = tl_lck; + if (tl_lck->next) + tl_lck->next->prev = l_lck; + else + l_lcks->locked.last = l_lck; + tl_lck->next = l_lck; + } + return; + } + } + + if (locked) { + l_lck->next = l_lcks->locked.first; + l_lcks->locked.first->prev = l_lck; + l_lcks->locked.first = l_lck; + } + } + +} + +void erts_lc_require_lock_flg(erts_lc_lock_t *lck, Uint16 op_flags) +{ + erts_lc_locked_locks_t *l_lcks = make_my_locked_locks(); + erts_lc_locked_lock_t *l_lck = l_lcks->locked.first; + if (!find_lock(&l_lck, lck)) + required_not_locked(l_lcks, lck); + l_lck = new_locked_lock(lck, op_flags); + if (!l_lcks->required.last) { + ASSERT(!l_lcks->required.first); + l_lck->next = l_lck->prev = NULL; + l_lcks->required.first = l_lcks->required.last = l_lck; + } + else { + erts_lc_locked_lock_t *l_lck2; + ASSERT(l_lcks->required.first); + for (l_lck2 = l_lcks->required.last; + l_lck2; + l_lck2 = l_lck2->prev) { + if (l_lck2->id < lck->id + || (l_lck2->id == lck->id && l_lck2->extra < lck->extra)) + break; + else if (l_lck2->id == lck->id && l_lck2->extra == lck->extra) + require_twice(l_lcks, lck); + } + if (!l_lck2) { + l_lck->next = l_lcks->required.first; + l_lck->prev = NULL; + l_lcks->required.first->prev = l_lck; + l_lcks->required.first = l_lck; + } + else { + l_lck->next = l_lck2->next; + if (l_lck->next) { + ASSERT(l_lcks->required.last != l_lck2); + l_lck->next->prev = l_lck; + } + else { + ASSERT(l_lcks->required.last == l_lck2); + l_lcks->required.last = l_lck; + } + l_lck->prev = l_lck2; + l_lck2->next = l_lck; + } + } +} + +void erts_lc_unrequire_lock_flg(erts_lc_lock_t *lck, Uint16 op_flags) +{ + erts_lc_locked_locks_t *l_lcks = make_my_locked_locks(); + erts_lc_locked_lock_t *l_lck = l_lcks->locked.first; + if (!find_lock(&l_lck, lck)) + required_not_locked(l_lcks, lck); + l_lck = l_lcks->required.first; + if (!find_lock(&l_lck, lck)) + unrequire_of_not_required_lock(l_lcks, lck); + if (l_lck->prev) { + ASSERT(l_lcks->required.first != l_lck); + l_lck->prev->next = l_lck->next; + } + else { + ASSERT(l_lcks->required.first == l_lck); + l_lcks->required.first = l_lck->next; + } + if (l_lck->next) { + ASSERT(l_lcks->required.last != l_lck); + l_lck->next->prev = l_lck->prev; + } + else { + ASSERT(l_lcks->required.last == l_lck); + l_lcks->required.last = l_lck->prev; + } + lc_free((void *) l_lck); +} + +void erts_lc_lock_flg(erts_lc_lock_t *lck, Uint16 op_flags) +{ + erts_lc_locked_locks_t *l_lcks; + erts_lc_locked_lock_t *l_lck; + + if (lck->inited != ERTS_LC_INITITALIZED) + uninitialized_lock(); + + if (lck->id < 0) + return; + + l_lcks = make_my_locked_locks(); + l_lck = new_locked_lock(lck, op_flags); + + if (!l_lcks->locked.last) { + ASSERT(!l_lcks->locked.first); + l_lcks->locked.last = l_lcks->locked.first = l_lck; + } + else if (l_lcks->locked.last->id < lck->id + || (l_lcks->locked.last->id == lck->id + && l_lcks->locked.last->extra < lck->extra)) { + if (LOCK_IS_TYPE_ORDER_VIOLATION(lck->flags, l_lcks->locked.last->flags)) + type_order_violation("locking ", l_lcks, lck); + l_lck->prev = l_lcks->locked.last; + l_lcks->locked.last->next = l_lck; + l_lcks->locked.last = l_lck; + } + else if (l_lcks->locked.last->id == lck->id && l_lcks->locked.last->extra == lck->extra) + lock_twice("Locking", l_lcks, lck, op_flags); + else + lock_order_violation(l_lcks, lck); +} + +void erts_lc_unlock_flg(erts_lc_lock_t *lck, Uint16 op_flags) +{ + erts_lc_locked_locks_t *l_lcks; + erts_lc_locked_lock_t *l_lck; + + if (lck->inited != ERTS_LC_INITITALIZED) + uninitialized_lock(); + + if (lck->id < 0) + return; + + l_lcks = get_my_locked_locks(); + + if (l_lcks) { + l_lck = l_lcks->required.first; + if (find_lock(&l_lck, lck)) + unlock_of_required_lock(l_lcks, lck); + } + + for (l_lck = l_lcks ? l_lcks->locked.last : NULL; l_lck; l_lck = l_lck->prev) { + if (l_lck->id == lck->id && l_lck->extra == lck->extra) { + if ((l_lck->flags & ERTS_LC_FLG_LO_ALL) != op_flags) + unlock_op_mismatch(l_lcks, lck, op_flags); + if (l_lck->prev) + l_lck->prev->next = l_lck->next; + else + l_lcks->locked.first = l_lck->next; + if (l_lck->next) + l_lck->next->prev = l_lck->prev; + else + l_lcks->locked.last = l_lck->prev; + lc_free((void *) l_lck); + return; + } + } + + unlock_of_not_locked(l_lcks, lck); +} + +void erts_lc_might_unlock_flg(erts_lc_lock_t *lck, Uint16 op_flags) +{ + erts_lc_locked_locks_t *l_lcks; + erts_lc_locked_lock_t *l_lck; + + if (lck->inited != ERTS_LC_INITITALIZED) + uninitialized_lock(); + + if (lck->id < 0) + return; + + l_lcks = get_my_locked_locks(); + + if (l_lcks) { + l_lck = l_lcks->required.first; + if (find_lock(&l_lck, lck)) + unlock_of_required_lock(l_lcks, lck); + } + + l_lck = l_lcks->locked.first; + if (!find_lock(&l_lck, lck)) + unlock_of_not_locked(l_lcks, lck); +} + +int +erts_lc_trylock_force_busy(erts_lc_lock_t *lck) +{ + return erts_lc_trylock_force_busy_flg(lck, 0); +} + +void +erts_lc_trylock(int locked, erts_lc_lock_t *lck) +{ + erts_lc_trylock_flg(locked, lck, 0); +} + +void +erts_lc_lock(erts_lc_lock_t *lck) +{ + erts_lc_lock_flg(lck, 0); +} + +void +erts_lc_unlock(erts_lc_lock_t *lck) +{ + erts_lc_unlock_flg(lck, 0); +} + +void erts_lc_might_unlock(erts_lc_lock_t *lck) +{ + erts_lc_might_unlock_flg(lck, 0); +} + +void erts_lc_require_lock(erts_lc_lock_t *lck) +{ + erts_lc_require_lock_flg(lck, 0); +} + +void erts_lc_unrequire_lock(erts_lc_lock_t *lck) +{ + erts_lc_unrequire_lock_flg(lck, 0); +} + +void +erts_lc_init_lock(erts_lc_lock_t *lck, char *name, Uint16 flags) +{ + lck->id = erts_lc_get_lock_order_id(name); + lck->extra = make_boxed(&lck->extra); + lck->flags = flags; + lck->inited = ERTS_LC_INITITALIZED; +} + +void +erts_lc_init_lock_x(erts_lc_lock_t *lck, char *name, Uint16 flags, Eterm extra) +{ + lck->id = erts_lc_get_lock_order_id(name); + lck->extra = extra; + lck->flags = flags; + lck->inited = ERTS_LC_INITITALIZED; +} + +void +erts_lc_destroy_lock(erts_lc_lock_t *lck) +{ + if (lck->inited != ERTS_LC_INITITALIZED) + uninitialized_lock(); + + lck->inited = 0; + lck->id = -1; + lck->extra = THE_NON_VALUE; + lck->flags = 0; +} + +void +erts_lc_init(void) +{ +#ifdef ERTS_LC_STATIC_ALLOC + int i; + static erts_lc_free_block_t fbs[ERTS_LC_FB_CHUNK_SIZE]; + for (i = 0; i < ERTS_LC_FB_CHUNK_SIZE - 1; i++) { +#ifdef DEBUG + memset((void *) &fbs[i], 0xdf, sizeof(erts_lc_free_block_t)); +#endif + fbs[i].next = &fbs[i+1]; + } +#ifdef DEBUG + memset((void *) &fbs[ERTS_LC_FB_CHUNK_SIZE-1], + 0xdf, sizeof(erts_lc_free_block_t)); +#endif + fbs[ERTS_LC_FB_CHUNK_SIZE-1].next = NULL; + free_blocks = &fbs[0]; +#else /* #ifdef ERTS_LC_STATIC_ALLOC */ + free_blocks = NULL; +#endif /* #ifdef ERTS_LC_STATIC_ALLOC */ + +#ifdef ETHR_HAVE_NATIVE_LOCKS + if (ethr_spinlock_init(&free_blocks_lock) != 0) + abort(); +#else + if (ethr_mutex_init(&free_blocks_lock) != 0) + abort(); +#endif + + erts_tsd_key_create(&locks_key); +} + +void +erts_lc_late_init(void) +{ + erts_thr_install_exit_handler(thread_exit_handler); +} + + +/* + * erts_lc_pll(): print locked locks... + */ +void +erts_lc_pll(void) +{ + print_curr_locks(get_my_locked_locks()); +} + + +#endif /* #ifdef ERTS_ENABLE_LOCK_CHECK */ diff --git a/erts/emulator/beam/erl_lock_check.h b/erts/emulator/beam/erl_lock_check.h new file mode 100644 index 0000000000..d5e2ede9ac --- /dev/null +++ b/erts/emulator/beam/erl_lock_check.h @@ -0,0 +1,117 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2005-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* + * Description: A lock checker that checks that each thread acquires + * locks according to a predefined global lock order. The + * global lock order is used to prevent deadlocks. If the + * lock order is violated, an error message is printed + * and the emulator aborts. The lock checker is only + * intended to be enabled when debugging. + * + * Author: Rickard Green + */ + +#include "sys.h" + +#ifndef ERTS_LOCK_CHECK_H__ +#define ERTS_LOCK_CHECK_H__ + +#ifdef ERTS_ENABLE_LOCK_CHECK + +typedef struct { + int inited; + Sint16 id; + Uint16 flags; + Eterm extra; +} erts_lc_lock_t; + +#define ERTS_LC_INITITALIZED 0x7f7f7f7f + + +#define ERTS_LC_FLG_LT_SPINLOCK (((Uint16) 1) << 0) +#define ERTS_LC_FLG_LT_RWSPINLOCK (((Uint16) 1) << 1) +#define ERTS_LC_FLG_LT_MUTEX (((Uint16) 1) << 2) +#define ERTS_LC_FLG_LT_RWMUTEX (((Uint16) 1) << 3) +#define ERTS_LC_FLG_LT_PROCLOCK (((Uint16) 1) << 4) + +#define ERTS_LC_FLG_LO_READ (((Uint16) 1) << 5) +#define ERTS_LC_FLG_LO_WRITE (((Uint16) 1) << 6) + +#define ERTS_LC_FLG_LO_READ_WRITE (ERTS_LC_FLG_LO_READ \ + | ERTS_LC_FLG_LO_WRITE) + +#define ERTS_LC_FLG_LT_ALL (ERTS_LC_FLG_LT_SPINLOCK \ + | ERTS_LC_FLG_LT_RWSPINLOCK \ + | ERTS_LC_FLG_LT_MUTEX \ + | ERTS_LC_FLG_LT_RWMUTEX \ + | ERTS_LC_FLG_LT_PROCLOCK) + +#define ERTS_LC_FLG_LO_ALL (ERTS_LC_FLG_LO_READ \ + | ERTS_LC_FLG_LO_WRITE) + + +#define ERTS_LC_LOCK_INIT(ID, X, F) {ERTS_LC_INITITALIZED, (ID), (F), (X)} + +void erts_lc_init(void); +void erts_lc_late_init(void); +Sint16 erts_lc_get_lock_order_id(char *name); +void erts_lc_check(erts_lc_lock_t *have, int have_len, + erts_lc_lock_t *have_not, int have_not_len); +void erts_lc_check_exact(erts_lc_lock_t *have, int have_len); +void erts_lc_have_locks(int *resv, erts_lc_lock_t *lcks, int len); +void erts_lc_have_lock_ids(int *resv, int *ids, int len); +int erts_lc_trylock_force_busy_flg(erts_lc_lock_t *lck, Uint16 op_flags); +void erts_lc_trylock_flg(int locked, erts_lc_lock_t *lck, Uint16 op_flags); +void erts_lc_lock_flg(erts_lc_lock_t *lck, Uint16 op_flags); +void erts_lc_unlock_flg(erts_lc_lock_t *lck, Uint16 op_flags); +void erts_lc_might_unlock_flg(erts_lc_lock_t *lck, Uint16 op_flags); +int erts_lc_trylock_force_busy(erts_lc_lock_t *lck); +void erts_lc_trylock(int locked, erts_lc_lock_t *lck); +void erts_lc_lock(erts_lc_lock_t *lck); +void erts_lc_unlock(erts_lc_lock_t *lck); +void erts_lc_might_unlock(erts_lc_lock_t *lck); +void erts_lc_init_lock(erts_lc_lock_t *lck, char *name, Uint16 flags); +void erts_lc_init_lock_x(erts_lc_lock_t *lck, char *name, Uint16 flags, Eterm extra); +void erts_lc_destroy_lock(erts_lc_lock_t *lck); +void erts_lc_fail(char *fmt, ...); +int erts_lc_assert_failed(char *file, int line, char *assertion); +void erts_lc_set_thread_name(char *thread_name); +void erts_lc_pll(void); + +void erts_lc_require_lock_flg(erts_lc_lock_t *lck, Uint16 op_flags); +void erts_lc_unrequire_lock_flg(erts_lc_lock_t *lck, Uint16 op_flags); + +void erts_lc_require_lock(erts_lc_lock_t *lck); +void erts_lc_unrequire_lock(erts_lc_lock_t *lck); + + +#define ERTS_LC_ASSERT(A) \ + ((void) ((A) ? 1 : erts_lc_assert_failed(__FILE__, __LINE__, #A))) +#ifdef ERTS_SMP +#define ERTS_SMP_LC_ASSERT(A) ERTS_LC_ASSERT(A) +#else +#define ERTS_SMP_LC_ASSERT(A) ((void) 1) +#endif +#else /* #ifdef ERTS_ENABLE_LOCK_CHECK */ +#define ERTS_SMP_LC_ASSERT(A) ((void) 1) +#define ERTS_LC_ASSERT(A) ((void) 1) +#endif /* #ifdef ERTS_ENABLE_LOCK_CHECK */ + +#endif /* #ifndef ERTS_LOCK_CHECK_H__ */ diff --git a/erts/emulator/beam/erl_lock_count.c b/erts/emulator/beam/erl_lock_count.c new file mode 100644 index 0000000000..6211983f4b --- /dev/null +++ b/erts/emulator/beam/erl_lock_count.c @@ -0,0 +1,675 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2008-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* + * Description: Statistics for locks. + * + * Author: Björn-Egil Dahlberg + * Date: 2008-07-03 + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +/* Needed for VxWorks va_arg */ +#include "sys.h" + +#ifdef ERTS_ENABLE_LOCK_COUNT + +#include "erl_lock_count.h" +#include "ethread.h" +#include "erl_term.h" +#include "atom.h" +#include + +/* globals, dont access these without locks or blocks */ + +ethr_mutex lcnt_data_lock; +erts_lcnt_data_t *erts_lcnt_data; +Uint16 erts_lcnt_rt_options; +erts_lcnt_time_t timer_start; +const char *str_undefined = "undefined"; + +static ethr_tsd_key lcnt_thr_data_key; +static int lcnt_n_thr; +static erts_lcnt_thread_data_t *lcnt_thread_data[1024]; + +/* local functions */ + +static ERTS_INLINE void lcnt_lock(void) { + ethr_mutex_lock(&lcnt_data_lock); +} + +static ERTS_INLINE void lcnt_unlock(void) { + ethr_mutex_unlock(&lcnt_data_lock); +} + + +static char* lcnt_lock_type(Uint16 flag) { + switch(flag & ERTS_LCNT_LT_ALL) { + case ERTS_LCNT_LT_SPINLOCK: return "spinlock"; + case ERTS_LCNT_LT_RWSPINLOCK: return "rw_spinlock"; + case ERTS_LCNT_LT_MUTEX: return "mutex"; + case ERTS_LCNT_LT_RWMUTEX: return "rw_mutex"; + case ERTS_LCNT_LT_PROCLOCK: return "proclock"; + default: return ""; + } +} + +static void lcnt_clear_stats(erts_lcnt_lock_stats_t *stats) { + ethr_atomic_set(&stats->tries, 0); + ethr_atomic_set(&stats->colls, 0); + stats->timer.s = 0; + stats->timer.ns = 0; + stats->timer_n = 0; + stats->file = (char *)str_undefined; + stats->line = 0; +} + +static void lcnt_time(erts_lcnt_time_t *time) { +#ifdef HAVE_GETHRTIME + SysHrTime hr_time; + hr_time = sys_gethrtime(); + time->s = (unsigned long)(hr_time / 1000000000LL); + time->ns = (unsigned long)(hr_time - 1000000000LL*time->s); +#else + SysTimeval tv; + sys_gettimeofday(&tv); + time->s = tv.tv_sec; + time->ns = tv.tv_usec*1000LL; +#endif +} + +static void lcnt_time_diff(erts_lcnt_time_t *d, erts_lcnt_time_t *t1, erts_lcnt_time_t *t0) { + long ds; + long dns; + + ds = t1->s - t0->s; + dns = t1->ns - t0->ns; + + /* the difference should not be able to get bigger than 1 sec in ns*/ + + if (dns < 0) { + ds -= 1; + dns += 1000000000LL; + } + + d->s = ds; + d->ns = dns; +} + +/* difference d must be positive */ + +static void lcnt_time_add(erts_lcnt_time_t *t, erts_lcnt_time_t *d) { + unsigned long ngns = 0; + + t->s += d->s; + t->ns += d->ns; + + ngns = t->ns / 1000000000LL; + t->ns = t->ns % 1000000000LL; + + t->s += ngns; +} + +static erts_lcnt_thread_data_t *lcnt_thread_data_alloc(void) { + erts_lcnt_thread_data_t *eltd; + + eltd = (erts_lcnt_thread_data_t*)malloc(sizeof(erts_lcnt_thread_data_t)); + eltd->timer_set = 0; + eltd->lock_in_conflict = 0; + + eltd->id = lcnt_n_thr++; + /* set thread data to array */ + lcnt_thread_data[eltd->id] = eltd; + + return eltd; +} + +static erts_lcnt_thread_data_t *lcnt_get_thread_data(void) { + return (erts_lcnt_thread_data_t *)ethr_tsd_get(lcnt_thr_data_key); +} + + +/* debug */ + +#if 0 +static char* lock_opt(Uint16 flag) { + if ((flag & ERTS_LCNT_LO_WRITE) && (flag & ERTS_LCNT_LO_READ)) return "rw"; + if (flag & ERTS_LCNT_LO_READ ) return "r "; + if (flag & ERTS_LCNT_LO_WRITE) return " w"; + return "--"; +} + +static void print_lock_x(erts_lcnt_lock_t *lock, Uint16 flag, char *action, char *extra) { + long int colls, tries, w_state, r_state; + erts_lcnt_lock_stats_t *stats = NULL; + + float rate; + char *type; + int i; + + type = lcnt_lock_type(lock->flag); + ethr_atomic_read(&lock->r_state, &r_state); + ethr_atomic_read(&lock->w_state, &w_state); + + if (tries > 0) rate = (float)(colls/(float)tries)*100; + else rate = 0.0f; + + if (lock->flag & flag) { + erts_printf("%20s [%30s] [r/w state %4ld/%4ld] id %T %s\r\n", + action, + lock->name, + r_state, + w_state, + lock->id, + extra); + + for(i = 0; i < lock->n_stats; i++) { + stats = &(lock->stats[i]); + ethr_atomic_read(&stats->tries, &tries); + ethr_atomic_read(&stats->colls, &colls); + fprintf(stderr, "%69s:%5d [tries %9ld] [colls %9ld] [timer_n %8ld] [timer %4ld s %6ld us]\r\n", + stats->file, + stats->line, + tries, + colls, + stats->timer_n, + stats->timer.s, + (unsigned long)stats->timer.ns/1000); + } + fprintf(stderr, "\r\n"); + } +} + +static void print_lock(erts_lcnt_lock_t *lock, char *action) { + print_lock_x(lock, ERTS_LCNT_LT_ALL, action, ""); +} + +#endif + +static erts_lcnt_lock_stats_t *lcnt_get_lock_stats(erts_lcnt_lock_t *lock, char *file, unsigned int line) { + unsigned int i; + erts_lcnt_lock_stats_t *stats = NULL; + + for (i = 0; i < lock->n_stats; i++) { + if ((lock->stats[i].file == file) && (lock->stats[i].line == line)) { + return &(lock->stats[i]); + } + } + if (lock->n_stats < ERTS_LCNT_MAX_LOCK_LOCATIONS) { + stats = &lock->stats[lock->n_stats]; + lock->n_stats++; + + stats->file = file; + stats->line = line; + return stats; + } + return &lock->stats[0]; + +} + +static void lcnt_update_stats(erts_lcnt_lock_stats_t *stats, int lock_in_conflict, erts_lcnt_time_t *time_wait) { + + ethr_atomic_inc(&stats->tries); + + /* beware of trylock */ + if (lock_in_conflict) ethr_atomic_inc(&stats->colls); + + if (time_wait) { + lcnt_time_add(&(stats->timer), time_wait); + stats->timer_n++; + } +} + +/* + * interface + */ + +void erts_lcnt_init() { + erts_lcnt_thread_data_t *eltd = NULL; + + /* init lock */ + if (ethr_mutex_init(&lcnt_data_lock) != 0) abort(); + + /* init tsd */ + lcnt_n_thr = 0; + + ethr_tsd_key_create(&lcnt_thr_data_key); + + lcnt_lock(); + + erts_lcnt_rt_options = ERTS_LCNT_OPT_PROCLOCK; + + eltd = lcnt_thread_data_alloc(); + + ethr_tsd_set(lcnt_thr_data_key, eltd); + + /* init lcnt structure */ + erts_lcnt_data = (erts_lcnt_data_t*)malloc(sizeof(erts_lcnt_data_t)); + erts_lcnt_data->current_locks = erts_lcnt_list_init(); + erts_lcnt_data->deleted_locks = erts_lcnt_list_init(); + + lcnt_unlock(); + + /* set start timer and zero statistics */ + erts_lcnt_clear_counters(); +} + +/* list operations */ + +/* BEGIN ASSUMPTION: lcnt_data_lock taken */ + +erts_lcnt_lock_list_t *erts_lcnt_list_init(void) { + erts_lcnt_lock_list_t *list; + + list = (erts_lcnt_lock_list_t*)malloc(sizeof(erts_lcnt_lock_list_t)); + list->head = NULL; + list->tail = NULL; + list->n = 0; + return list; +} + +/* only do this on the list with the deleted locks! */ +void erts_lcnt_list_clear(erts_lcnt_lock_list_t *list) { + erts_lcnt_lock_t *lock = NULL, + *next = NULL; + + lock = list->head; + + while(lock != NULL) { + next = lock->next; + free(lock); + lock = next; + } + + list->head = NULL; + list->tail = NULL; + list->n = 0; +} + +void erts_lcnt_list_insert(erts_lcnt_lock_list_t *list, erts_lcnt_lock_t *lock) { + erts_lcnt_lock_t *tail = NULL; + + tail = list->tail; + if (tail) { + tail->next = lock; + lock->prev = tail; + } else { + list->head = lock; + lock->prev = NULL; + ASSERT(!lock->next); + } + lock->next = NULL; + list->tail = lock; + + list->n++; +} + +void erts_lcnt_list_delete(erts_lcnt_lock_list_t *list, erts_lcnt_lock_t *lock) { + + if (lock->next) lock->next->prev = lock->prev; + if (lock->prev) lock->prev->next = lock->next; + if (list->head == lock) list->head = lock->next; + if (list->tail == lock) list->tail = lock->prev; + + lock->prev = NULL; + lock->next = NULL; + list->n--; +} +/* END ASSUMPTION: lcnt_data_lock taken */ + + +/* lock operations */ + +/* interface to erl_threads.h */ +/* only lock on init and destroy, all others should use atomics */ +void erts_lcnt_init_lock(erts_lcnt_lock_t *lock, char *name, Uint16 flag ) { + erts_lcnt_init_lock_x(lock, name, flag, am_undefined); +} +void erts_lcnt_init_lock_x(erts_lcnt_lock_t *lock, char *name, Uint16 flag, Eterm id) { + int i; + lcnt_lock(); + + lock->next = NULL; + lock->prev = NULL; + lock->flag = flag; + lock->name = name; + lock->id = id; + + ethr_atomic_init(&lock->r_state, 0); + ethr_atomic_init(&lock->w_state, 0); + +#ifdef DEBUG + ethr_atomic_init(&lock->flowstate, 0); +#endif + + lock->n_stats = 1; + + for (i = 0; i < ERTS_LCNT_MAX_LOCK_LOCATIONS; i++) { + lcnt_clear_stats(&lock->stats[i]); + } + erts_lcnt_list_insert(erts_lcnt_data->current_locks, lock); + + lcnt_unlock(); +} + +void erts_lcnt_destroy_lock(erts_lcnt_lock_t *lock) { + erts_lcnt_lock_t *deleted_lock; + + /* copy structure and insert the copy */ + deleted_lock = (erts_lcnt_lock_t*)malloc(sizeof(erts_lcnt_lock_t)); + + lcnt_lock(); + + memcpy(deleted_lock, lock, sizeof(erts_lcnt_lock_t)); + deleted_lock->next = NULL; + deleted_lock->prev = NULL; + + erts_lcnt_list_insert(erts_lcnt_data->deleted_locks, deleted_lock); + + /* delete original */ + erts_lcnt_list_delete(erts_lcnt_data->current_locks, lock); + + lcnt_unlock(); +} + +/* lock */ + +void erts_lcnt_lock_opt(erts_lcnt_lock_t *lock, Uint16 option) { + long r_state = 0, w_state = 0; + erts_lcnt_thread_data_t *eltd; + + if (erts_lcnt_rt_options & ERTS_LCNT_OPT_SUSPEND) return; + + eltd = lcnt_get_thread_data(); + + ASSERT(eltd); + + ethr_atomic_read(&lock->w_state, &w_state); + + if (option & ERTS_LCNT_LO_WRITE) { + ethr_atomic_read(&lock->r_state, &r_state); + ethr_atomic_inc( &lock->w_state); + } + if (option & ERTS_LCNT_LO_READ) { + ethr_atomic_inc( &lock->r_state); + } + + /* we cannot acquire w_lock if either w or r are taken */ + /* we cannot acquire r_lock if w_lock is taken */ + + if ((w_state > 0) || (r_state > 0)){ + eltd->lock_in_conflict = 1; + if (eltd->timer_set == 0) lcnt_time(&eltd->timer); + eltd->timer_set++; + } else { + eltd->lock_in_conflict = 0; + } +} + +void erts_lcnt_lock(erts_lcnt_lock_t *lock) { + long w_state; + erts_lcnt_thread_data_t *eltd; + + if (erts_lcnt_rt_options & ERTS_LCNT_OPT_SUSPEND) return; + + ethr_atomic_read(&lock->w_state, &w_state); + ethr_atomic_inc( &lock->w_state); + + eltd = lcnt_get_thread_data(); + + ASSERT(eltd); + + if (w_state > 0) { + eltd->lock_in_conflict = 1; + /* only set the timer if nobody else has it + * This should only happen when proc_locks aquires several locks + * 'atomicly'. All other locks will block the thread if w_state > 0 + * i.e. locked. + */ + if (eltd->timer_set == 0) lcnt_time(&eltd->timer); + eltd->timer_set++; + + } else { + eltd->lock_in_conflict = 0; + } +} + +/* if a lock wasn't really a lock operation, bad bad process locks */ + +void erts_lcnt_lock_unaquire(erts_lcnt_lock_t *lock) { + /* should check if this thread was "waiting" */ + + if (erts_lcnt_rt_options & ERTS_LCNT_OPT_SUSPEND) return; + + ethr_atomic_dec( &lock->w_state); +} + +/* erts_lcnt_lock_post + * used when we get a lock (i.e. directly after a lock operation) + * if the timer was set then we had to wait for the lock + * lock_post will calculate the wait time. + */ +void erts_lcnt_lock_post(erts_lcnt_lock_t *lock) { + erts_lcnt_lock_post_x(lock, (char*)str_undefined, 0); +} + +void erts_lcnt_lock_post_x(erts_lcnt_lock_t *lock, char *file, unsigned int line) { + erts_lcnt_thread_data_t *eltd; + erts_lcnt_time_t timer; + erts_lcnt_time_t time_wait; + erts_lcnt_lock_stats_t *stats; +#ifdef DEBUG + long flowstate; +#endif + + if (erts_lcnt_rt_options & ERTS_LCNT_OPT_SUSPEND) return; + +#ifdef DEBUG + if (!(lock->flag & (ERTS_LCNT_LT_RWMUTEX | ERTS_LCNT_LT_RWSPINLOCK))) { + ethr_atomic_read(&lock->flowstate, &flowstate); + ASSERT(flowstate == 0); + ethr_atomic_inc( &lock->flowstate); + } +#endif + + eltd = lcnt_get_thread_data(); + + ASSERT(eltd); + + /* if lock was in conflict, time it */ + + stats = lcnt_get_lock_stats(lock, file, line); + + if (eltd->timer_set) { + lcnt_time(&timer); + + eltd->timer_set--; + + lcnt_time_diff(&time_wait, &timer, &(eltd->timer)); + lcnt_update_stats(stats, eltd->lock_in_conflict, &time_wait); + + ASSERT(eltd->timer_set >= 0); + } else { + lcnt_update_stats(stats, eltd->lock_in_conflict, NULL); + } + +} + +/* unlock */ + +void erts_lcnt_unlock_opt(erts_lcnt_lock_t *lock, Uint16 option) { + if (erts_lcnt_rt_options & ERTS_LCNT_OPT_SUSPEND) return; + if (option & ERTS_LCNT_LO_WRITE) ethr_atomic_dec(&lock->w_state); + if (option & ERTS_LCNT_LO_READ ) ethr_atomic_dec(&lock->r_state); +} + +void erts_lcnt_unlock(erts_lcnt_lock_t *lock) { +#ifdef DEBUG + long w_state; + long flowstate; +#endif + if (erts_lcnt_rt_options & ERTS_LCNT_OPT_SUSPEND) return; +#ifdef DEBUG + /* flowstate */ + ethr_atomic_read(&lock->flowstate, &flowstate); + ASSERT(flowstate == 1); + ethr_atomic_dec( &lock->flowstate); + + /* write state */ + ethr_atomic_read(&lock->w_state, &w_state); + ASSERT(w_state > 0) +#endif + ethr_atomic_dec(&lock->w_state); +} + +/* trylock */ + +void erts_lcnt_trylock_opt(erts_lcnt_lock_t *lock, int res, Uint16 option) { + if (erts_lcnt_rt_options & ERTS_LCNT_OPT_SUSPEND) return; + /* Determine lock_state via res instead of state */ + if (res != EBUSY) { + if (option & ERTS_LCNT_LO_WRITE) ethr_atomic_inc(&lock->w_state); + if (option & ERTS_LCNT_LO_READ ) ethr_atomic_inc(&lock->r_state); + lcnt_update_stats(&(lock->stats[0]), 0, NULL); + } else { + ethr_atomic_inc(&lock->stats[0].tries); + ethr_atomic_inc(&lock->stats[0].colls); + } +} + + +void erts_lcnt_trylock(erts_lcnt_lock_t *lock, int res) { + /* Determine lock_state via res instead of state */ +#ifdef DEBUG + long flowstate; +#endif + if (erts_lcnt_rt_options & ERTS_LCNT_OPT_SUSPEND) return; + if (res != EBUSY) { + +#ifdef DEBUG + ethr_atomic_read(&lock->flowstate, &flowstate); + ASSERT(flowstate == 0); + ethr_atomic_inc( &lock->flowstate); +#endif + ethr_atomic_inc(&lock->w_state); + + lcnt_update_stats(&(lock->stats[0]), 0, NULL); + + } else { + ethr_atomic_inc(&lock->stats[0].tries); + ethr_atomic_inc(&lock->stats[0].colls); + } +} + +/* thread operations */ + +static void *lcnt_thr_init(erts_lcnt_thread_data_t *eltd) { + void *(*function)(void *); + void *argument; + void *res; + function = eltd->function; + argument = eltd->argument; + + ethr_tsd_set(lcnt_thr_data_key, eltd); + + res = (void *)function(argument); + free(eltd); + return (void *)res; +} + + + +int erts_lcnt_thr_create(ethr_tid *tid, void * (*function)(void *), void *arg, ethr_thr_opts *opts) { + erts_lcnt_thread_data_t *eltd; + + lcnt_lock(); + /* lock for thread id global update */ + eltd = lcnt_thread_data_alloc(); + lcnt_unlock(); + + eltd->function = function; + eltd->argument = arg; + + return ethr_thr_create(tid, (void *)lcnt_thr_init, (void *)eltd, opts); +} + + +/* bindings for bifs */ + +Uint16 erts_lcnt_set_rt_opt(Uint16 opt) { + Uint16 prev; + prev = (erts_lcnt_rt_options & opt); + erts_lcnt_rt_options |= opt; + return prev; +} + +Uint16 erts_lcnt_clear_rt_opt(Uint16 opt) { + Uint16 prev; + prev = (erts_lcnt_rt_options & opt); + erts_lcnt_rt_options &= ~opt; + return prev; +} + +void erts_lcnt_clear_counters(void) { + erts_lcnt_lock_t *lock; + erts_lcnt_lock_list_t *list; + erts_lcnt_lock_stats_t *stats; + int i; + + lcnt_lock(); + + list = erts_lcnt_data->current_locks; + + for (lock = list->head; lock != NULL; lock = lock->next) { + for( i = 0; i < ERTS_LCNT_MAX_LOCK_LOCATIONS; i++) { + stats = &lock->stats[i]; + lcnt_clear_stats(stats); + } + lock->n_stats = 1; + } + + /* empty deleted locks in lock list */ + erts_lcnt_list_clear(erts_lcnt_data->deleted_locks); + + lcnt_time(&timer_start); + + lcnt_unlock(); +} + +erts_lcnt_data_t *erts_lcnt_get_data(void) { + erts_lcnt_time_t timer_stop; + + lcnt_lock(); + + lcnt_time(&timer_stop); + lcnt_time_diff(&(erts_lcnt_data->duration), &timer_stop, &timer_start); + + lcnt_unlock(); + + return erts_lcnt_data; +} + +char *erts_lcnt_lock_type(Uint16 type) { + return lcnt_lock_type(type); +} + +#endif /* ifdef ERTS_ENABLE_LOCK_COUNT */ diff --git a/erts/emulator/beam/erl_lock_count.h b/erts/emulator/beam/erl_lock_count.h new file mode 100644 index 0000000000..8564c36203 --- /dev/null +++ b/erts/emulator/beam/erl_lock_count.h @@ -0,0 +1,195 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2008-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* + * Description: Statistics for locks. + * + * Author: Björn-Egil Dahlberg + * Date: 2008-07-03 + * Abstract: + * Locks statistics internal representation. + * + * Conceptual representation, + * - set name + * | - id (the unique lock) + * | | - lock type + * | | - statistics + * | | | - location (file and line number) + * | | | - tries + * | | | - collisions (including trylock busy) + * | | | - timer (time spent in waiting for lock) + * | | | - n_timer (collisions excluding trylock busy) + * + * Each instance of a lock is the unique lock, i.e. set and id in that set. + * For each lock there is a set of statistics with where and what impact + * the lock aqusition had. + */ + +#include "sys.h" + +#ifndef ERTS_LOCK_COUNT_H__ +#define ERTS_LOCK_COUNT_H__ + +#ifdef ERTS_ENABLE_LOCK_COUNT +#include "ethread.h" + +#define ERTS_LCNT_MAX_LOCK_LOCATIONS (10) + +#define ERTS_LCNT_LT_SPINLOCK (((Uint16) 1) << 0) +#define ERTS_LCNT_LT_RWSPINLOCK (((Uint16) 1) << 1) +#define ERTS_LCNT_LT_MUTEX (((Uint16) 1) << 2) +#define ERTS_LCNT_LT_RWMUTEX (((Uint16) 1) << 3) +#define ERTS_LCNT_LT_PROCLOCK (((Uint16) 1) << 4) +#define ERTS_LCNT_LT_ALLOC (((Uint16) 1) << 5) + +#define ERTS_LCNT_LO_READ (((Uint16) 1) << 6) +#define ERTS_LCNT_LO_WRITE (((Uint16) 1) << 7) + +#define ERTS_LCNT_LO_READ_WRITE ( ERTS_LCNT_LO_READ \ + | ERTS_LCNT_LO_WRITE ) + +#define ERTS_LCNT_LT_ALL ( ERTS_LCNT_LT_SPINLOCK \ + | ERTS_LCNT_LT_RWSPINLOCK \ + | ERTS_LCNT_LT_MUTEX \ + | ERTS_LCNT_LT_RWMUTEX \ + | ERTS_LCNT_LT_PROCLOCK ) +/* runtime options */ + +#define ERTS_LCNT_OPT_SUSPEND (((Uint16) 1) << 0) +#define ERTS_LCNT_OPT_LOCATION (((Uint16) 1) << 1) +#define ERTS_LCNT_OPT_PROCLOCK (((Uint16) 1) << 2) + +typedef struct { + unsigned long s; + unsigned long ns; +} erts_lcnt_time_t; + +extern erts_lcnt_time_t timer_start; + +typedef struct erts_lcnt_lock_stats_s { + /* "tries" and "colls" needs to be atomic since + * trylock busy does not aquire a lock and there + * is no post action to rectify the situation + */ + + char *file; /* which file the lock was taken */ + unsigned int line; /* line number in file */ + + ethr_atomic_t tries; /* n tries to get lock */ + ethr_atomic_t colls; /* n collisions of tries to get lock */ + + unsigned long timer_n; /* #times waited for lock */ + erts_lcnt_time_t timer; /* total wait time for lock */ +} erts_lcnt_lock_stats_t; + +/* rw locks uses both states, other locks only uses w_state */ +typedef struct erts_lcnt_lock_s { + char *name; /* lock name */ + Uint16 flag; /* lock type */ + Eterm id; /* id if possible */ + +#ifdef DEBUG + ethr_atomic_t flowstate; +#endif + + /* lock states */ + ethr_atomic_t w_state; /* 0 not taken, otherwise n threads waiting */ + ethr_atomic_t r_state; /* 0 not taken, > 0 -> writes will wait */ + + /* statistics */ + unsigned int n_stats; + erts_lcnt_lock_stats_t stats[ERTS_LCNT_MAX_LOCK_LOCATIONS]; /* first entry is "undefined"*/ + + /* chains for list handling */ + /* data is hold by lcnt_lock */ + struct erts_lcnt_lock_s *prev; + struct erts_lcnt_lock_s *next; +} erts_lcnt_lock_t; + +typedef struct { + erts_lcnt_lock_t *head; + erts_lcnt_lock_t *tail; + unsigned long n; +} erts_lcnt_lock_list_t; + +typedef struct { + erts_lcnt_time_t duration; /* time since last clear */ + erts_lcnt_lock_list_t *current_locks; + erts_lcnt_lock_list_t *deleted_locks; +} erts_lcnt_data_t; + +typedef struct { + int id; + + erts_lcnt_time_t timer; /* timer */ + int timer_set; /* bool */ + int lock_in_conflict; /* bool */ + + /* function pointer */ + void *(*function)(void *); + void *argument; + +} erts_lcnt_thread_data_t; + +/* globals */ + +extern Uint16 erts_lcnt_rt_options; + +/* function declerations */ + +void erts_lcnt_init(void); + +/* list operations (local) */ +erts_lcnt_lock_list_t *erts_lcnt_list_init(void); + +void erts_lcnt_list_clear( erts_lcnt_lock_list_t *list); +void erts_lcnt_list_insert(erts_lcnt_lock_list_t *list, erts_lcnt_lock_t *lock); +void erts_lcnt_list_delete(erts_lcnt_lock_list_t *list, erts_lcnt_lock_t *lock); + +/* lock operations (global) */ +void erts_lcnt_init_lock(erts_lcnt_lock_t *lock, char *name, Uint16 flag); +void erts_lcnt_init_lock_x(erts_lcnt_lock_t *lock, char *name, Uint16 flag, Eterm id); +void erts_lcnt_destroy_lock(erts_lcnt_lock_t *lock); + +void erts_lcnt_lock(erts_lcnt_lock_t *lock); +void erts_lcnt_lock_opt(erts_lcnt_lock_t *lock, Uint16 option); +void erts_lcnt_lock_post(erts_lcnt_lock_t *lock); +void erts_lcnt_lock_post_x(erts_lcnt_lock_t *lock, char *file, unsigned int line); +void erts_lcnt_lock_unaquire(erts_lcnt_lock_t *lock); + +void erts_lcnt_unlock(erts_lcnt_lock_t *lock); +void erts_lcnt_unlock_opt(erts_lcnt_lock_t *lock, Uint16 option); + +void erts_lcnt_trylock_opt(erts_lcnt_lock_t *lock, int res, Uint16 option); +void erts_lcnt_trylock(erts_lcnt_lock_t *lock, int res); + +/* thread operations */ + +int erts_lcnt_thr_create(ethr_tid *tid, void * (*function)(void *), void *arg, ethr_thr_opts *opts); + +/* bif interface */ + +Uint16 erts_lcnt_set_rt_opt(Uint16 opt); +Uint16 erts_lcnt_clear_rt_opt(Uint16 opt); +void erts_lcnt_clear_counters(void); +char *erts_lcnt_lock_type(Uint16 type); +erts_lcnt_data_t *erts_lcnt_get_data(void); + +#endif /* ifdef ERTS_ENABLE_LOCK_COUNT */ +#endif /* ifndef ERTS_LOCK_COUNT_H__ */ diff --git a/erts/emulator/beam/erl_math.c b/erts/emulator/beam/erl_math.c new file mode 100644 index 0000000000..16d4fdc09c --- /dev/null +++ b/erts/emulator/beam/erl_math.c @@ -0,0 +1,233 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1997-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "erl_process.h" +#include "error.h" +#include "bif.h" +#include "big.h" + +static Eterm +math_call_1(Process* p, double (*func)(double), Eterm arg1) +{ + FloatDef a1; + Eterm res; + Eterm* hp; + + ERTS_FP_CHECK_INIT(p); + if (is_float(arg1)) { + GET_DOUBLE(arg1, a1); + } else if (is_small(arg1)) { + a1.fd = signed_val(arg1); + } else if (is_big(arg1)) { + if (big_to_double(arg1, &a1.fd) < 0) { + badarith: + p->freason = BADARITH; + return THE_NON_VALUE; + } + } else { + p->freason = BADARG; + return THE_NON_VALUE; + } + a1.fd = (*func)(a1.fd); + ERTS_FP_ERROR_THOROUGH(p, a1.fd, goto badarith); + hp = HAlloc(p, FLOAT_SIZE_OBJECT); + res = make_float(hp); + PUT_DOUBLE(a1, hp); + return res; +} + + +static Eterm +math_call_2(Process* p, double (*func)(double, double), Eterm arg1, Eterm arg2) +{ + FloatDef a1; + FloatDef a2; + Eterm res; + Eterm* hp; + + ERTS_FP_CHECK_INIT(p); + if (is_float(arg1)) { + GET_DOUBLE(arg1, a1); + } else if (is_small(arg1)) { + a1.fd = signed_val(arg1); + } else if (is_big(arg1)) { + if (big_to_double(arg1, &a1.fd) < 0) { + badarith: + p->freason = BADARITH; + return THE_NON_VALUE; + } + } else { + p->freason = BADARG; + return THE_NON_VALUE; + } + + if (is_float(arg2)) { + GET_DOUBLE(arg2, a2); + } else if (is_small(arg2)) { + a2.fd = signed_val(arg2); + } else if (is_big(arg2)) { + if (big_to_double(arg2, &a2.fd) < 0) { + goto badarith; + } + } else { + p->freason = BADARG; + return THE_NON_VALUE; + } + + a1.fd = (*func)(a1.fd, a2.fd); + ERTS_FP_ERROR_THOROUGH(p, a1.fd, goto badarith); + hp = HAlloc(p, FLOAT_SIZE_OBJECT); + res = make_float(hp); + PUT_DOUBLE(a1, hp); + return res; +} + +BIF_RETTYPE math_cos_1(BIF_ALIST_1) +{ + return math_call_1(BIF_P, cos, BIF_ARG_1); +} + +BIF_RETTYPE math_cosh_1(BIF_ALIST_1) +{ + return math_call_1(BIF_P, cosh, BIF_ARG_1); +} + +BIF_RETTYPE math_sin_1(BIF_ALIST_1) +{ + return math_call_1(BIF_P, sin, BIF_ARG_1); +} + +BIF_RETTYPE math_sinh_1(BIF_ALIST_1) +{ + return math_call_1(BIF_P, sinh, BIF_ARG_1); +} + +BIF_RETTYPE math_tan_1(BIF_ALIST_1) +{ + return math_call_1(BIF_P, tan, BIF_ARG_1); +} + + +BIF_RETTYPE math_tanh_1(BIF_ALIST_1) +{ + return math_call_1(BIF_P, tanh, BIF_ARG_1); +} + + +BIF_RETTYPE math_acos_1(BIF_ALIST_1) +{ + return math_call_1(BIF_P, acos, BIF_ARG_1); +} + +BIF_RETTYPE math_acosh_1(BIF_ALIST_1) +{ +#ifdef NO_ACOSH + BIF_ERROR(BIF_P, EXC_UNDEF); +#else + return math_call_1(BIF_P, acosh, BIF_ARG_1); +#endif +} + +BIF_RETTYPE math_asin_1(BIF_ALIST_1) +{ + return math_call_1(BIF_P, asin, BIF_ARG_1); +} + +BIF_RETTYPE math_asinh_1(BIF_ALIST_1) +{ +#ifdef NO_ASINH + BIF_ERROR(BIF_P, EXC_UNDEF); +#else + return math_call_1(BIF_P, asinh, BIF_ARG_1); +#endif +} + +BIF_RETTYPE math_atan_1(BIF_ALIST_1) +{ + return math_call_1(BIF_P, atan, BIF_ARG_1); +} + +BIF_RETTYPE math_atanh_1(BIF_ALIST_1) +{ +#ifdef NO_ATANH + BIF_ERROR(BIF_P, EXC_UNDEF); +#else + return math_call_1(BIF_P, atanh, BIF_ARG_1); +#endif +} + +BIF_RETTYPE math_erf_1(BIF_ALIST_1) +{ +#ifdef NO_ERF + BIF_ERROR(BIF_P, EXC_UNDEF); +#else + return math_call_1(BIF_P, erf, BIF_ARG_1); +#endif +} + +BIF_RETTYPE math_erfc_1(BIF_ALIST_1) +{ +#ifdef NO_ERFC + BIF_ERROR(BIF_P, EXC_UNDEF); +#else + return math_call_1(BIF_P, erfc, BIF_ARG_1); +#endif +} + +BIF_RETTYPE math_exp_1(BIF_ALIST_1) +{ + return math_call_1(BIF_P, exp, BIF_ARG_1); +} + +BIF_RETTYPE math_log_1(BIF_ALIST_1) +{ + return math_call_1(BIF_P, log, BIF_ARG_1); +} + + +BIF_RETTYPE math_log10_1(BIF_ALIST_1) +{ + return math_call_1(BIF_P, log10, BIF_ARG_1); +} + +BIF_RETTYPE math_sqrt_1(BIF_ALIST_1) +{ + return math_call_1(BIF_P, sqrt, BIF_ARG_1); +} + +BIF_RETTYPE math_atan2_2(BIF_ALIST_2) +{ + return math_call_2(BIF_P, atan2, BIF_ARG_1, BIF_ARG_2); +} + +BIF_RETTYPE math_pow_2(BIF_ALIST_2) +{ + return math_call_2(BIF_P, pow, BIF_ARG_1, BIF_ARG_2); +} + + + + diff --git a/erts/emulator/beam/erl_md5.c b/erts/emulator/beam/erl_md5.c new file mode 100644 index 0000000000..8d0352a367 --- /dev/null +++ b/erts/emulator/beam/erl_md5.c @@ -0,0 +1,340 @@ +/* + * MD5C.C - RSA Data Security, Inc., MD5 message-digest algorithm + */ + +/* Copyright (C) 1991-2, RSA Data Security, Inc. Created 1991. All + * rights reserved. + * + * License to copy and use this software is granted provided that it + * is identified as the "RSA Data Security, Inc. MD5 Message-Digest + * Algorithm" in all material mentioning or referencing this software + * or this function. + * + * License is also granted to make and use derivative works provided + * that such works are identified as "derived from the RSA Data + * Security, Inc. MD5 Message-Digest Algorithm" in all material + * mentioning or referencing the derived work. + * + * RSA Data Security, Inc. makes no representations concerning either + * the merchantability of this software or the suitability of this + * software for any particular purpose. It is provided "as is" + * without express or implied warranty of any kind. + * + * These notices must be retained in any copies of any part of this + * documentation and/or software. + */ + +/* %ExternalCopyright% */ +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "erl_process.h" +#include "error.h" +#include "bif.h" +#include "erl_binary.h" + +typedef void *POINTER; + +/* + * Constants for MD5Transform routine. + */ + +#define S11 7 +#define S12 12 +#define S13 17 +#define S14 22 +#define S21 5 +#define S22 9 +#define S23 14 +#define S24 20 +#define S31 4 +#define S32 11 +#define S33 16 +#define S34 23 +#define S41 6 +#define S42 10 +#define S43 15 +#define S44 21 + +static void MD5Transform(Uint32 [4], unsigned char [64]); +static void Encode(unsigned char *, Uint32 *, unsigned int); +static void Decode(Uint32 *, unsigned char *, unsigned int); + +static unsigned char PADDING[64] = { + 0x80, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 +}; + +/* + * F, G, H and I are basic MD5 functions. + */ +#define F(x, y, z) (((x) & (y)) | ((~x) & (z))) +#define G(x, y, z) (((x) & (z)) | ((y) & (~z))) +#define H(x, y, z) ((x) ^ (y) ^ (z)) +#define I(x, y, z) ((y) ^ ((x) | (~z))) + +/* + * ROTATE_LEFT rotates x left n bits. + */ +#define ROTATE_LEFT(x, n) (((x) << (n)) | ((x) >> (32-(n)))) + +/* + * FF, GG, HH, and II transformations for rounds 1, 2, 3, and 4. + * Rotation is separate from addition to prevent recomputation. + */ +#define FF(a, b, c, d, x, s, ac) { \ + (a) += F ((b), (c), (d)) + (x) + (Uint32)(ac); \ + (a) = ROTATE_LEFT ((a), (s)); \ + (a) += (b); \ +} +#define GG(a, b, c, d, x, s, ac) { \ + (a) += G ((b), (c), (d)) + (x) + (Uint32)(ac); \ + (a) = ROTATE_LEFT ((a), (s)); \ + (a) += (b); \ +} +#define HH(a, b, c, d, x, s, ac) { \ + (a) += H ((b), (c), (d)) + (x) + (Uint32)(ac); \ + (a) = ROTATE_LEFT ((a), (s)); \ + (a) += (b); \ +} +#define II(a, b, c, d, x, s, ac) { \ + (a) += I ((b), (c), (d)) + (x) + (Uint32)(ac); \ + (a) = ROTATE_LEFT ((a), (s)); \ + (a) += (b); \ +} + +/* + * MD5 initialization. Begins an MD5 operation, writing a new context. + */ +void MD5Init(MD5_CTX* context) +{ + context->count[0] = context->count[1] = 0; + + /* + * Load magic initialization constants. + */ + context->state[0] = 0x67452301; + context->state[1] = 0xefcdab89; + context->state[2] = 0x98badcfe; + context->state[3] = 0x10325476; +} + +/* + * MD5 block update operation. Continues an MD5 message-digest + * operation, processing another message block, and updating the + * context. + */ +void MD5Update (context, input, inputLen) + MD5_CTX *context; /* context */ + unsigned char *input; /* input block */ + unsigned int inputLen; /* length of input block */ +{ + unsigned int i, index, partLen; + + /* + * Compute number of bytes mod 64 + */ + index = (unsigned int)((context->count[0] >> 3) & 0x3F); + + /* Update number of bits */ + if ((context->count[0] += ((Uint32)inputLen << 3)) + < ((Uint32)inputLen << 3)) + context->count[1]++; + context->count[1] += ((Uint32)inputLen >> 29); + + partLen = 64 - index; + + /* + * Transform as many times as possible. + */ + if (inputLen >= partLen) { + sys_memcpy + ((POINTER)&context->buffer[index], (POINTER)input, partLen); + MD5Transform (context->state, context->buffer); + + for (i = partLen; i + 63 < inputLen; i += 64) + MD5Transform (context->state, &input[i]); + + index = 0; + } + else + i = 0; + + /* + * Buffer remaining input + */ + sys_memcpy((POINTER)&context->buffer[index], (POINTER)&input[i], inputLen-i); +} + +/* + * MD5 finalization. Ends an MD5 message-digest operation, writing the + the message digest and zeroizing the context. + */ +void MD5Final (digest, context) + unsigned char digest[16]; /* message digest */ + MD5_CTX *context; /* context */ +{ + unsigned char bits[8]; + unsigned int index, padLen; + + /* + * Save number of bits + */ + Encode (bits, context->count, 8); + + /* + * Pad out to 56 mod 64. + */ + index = (unsigned int)((context->count[0] >> 3) & 0x3f); + padLen = (index < 56) ? (56 - index) : (120 - index); + MD5Update (context, PADDING, padLen); + + /* + * Append length (before padding) + */ + MD5Update (context, bits, 8); + + /* + * Store state in digest + */ + Encode (digest, context->state, 16); + + /* + * Zeroize sensitive information. + */ + sys_memset ((POINTER)context, 0, sizeof (*context)); +} + +/* + * MD5 basic transformation. Transforms state based on block. + */ +static void MD5Transform (state, block) + Uint32 state[4]; + unsigned char block[64]; +{ + Uint32 a = state[0], b = state[1], c = state[2], d = state[3], x[16]; + + Decode (x, block, 64); + + /* Round 1 */ + FF (a, b, c, d, x[ 0], S11, 0xd76aa478); /* 1 */ + FF (d, a, b, c, x[ 1], S12, 0xe8c7b756); /* 2 */ + FF (c, d, a, b, x[ 2], S13, 0x242070db); /* 3 */ + FF (b, c, d, a, x[ 3], S14, 0xc1bdceee); /* 4 */ + FF (a, b, c, d, x[ 4], S11, 0xf57c0faf); /* 5 */ + FF (d, a, b, c, x[ 5], S12, 0x4787c62a); /* 6 */ + FF (c, d, a, b, x[ 6], S13, 0xa8304613); /* 7 */ + FF (b, c, d, a, x[ 7], S14, 0xfd469501); /* 8 */ + FF (a, b, c, d, x[ 8], S11, 0x698098d8); /* 9 */ + FF (d, a, b, c, x[ 9], S12, 0x8b44f7af); /* 10 */ + FF (c, d, a, b, x[10], S13, 0xffff5bb1); /* 11 */ + FF (b, c, d, a, x[11], S14, 0x895cd7be); /* 12 */ + FF (a, b, c, d, x[12], S11, 0x6b901122); /* 13 */ + FF (d, a, b, c, x[13], S12, 0xfd987193); /* 14 */ + FF (c, d, a, b, x[14], S13, 0xa679438e); /* 15 */ + FF (b, c, d, a, x[15], S14, 0x49b40821); /* 16 */ + + /* Round 2 */ + GG (a, b, c, d, x[ 1], S21, 0xf61e2562); /* 17 */ + GG (d, a, b, c, x[ 6], S22, 0xc040b340); /* 18 */ + GG (c, d, a, b, x[11], S23, 0x265e5a51); /* 19 */ + GG (b, c, d, a, x[ 0], S24, 0xe9b6c7aa); /* 20 */ + GG (a, b, c, d, x[ 5], S21, 0xd62f105d); /* 21 */ + GG (d, a, b, c, x[10], S22, 0x2441453); /* 22 */ + GG (c, d, a, b, x[15], S23, 0xd8a1e681); /* 23 */ + GG (b, c, d, a, x[ 4], S24, 0xe7d3fbc8); /* 24 */ + GG (a, b, c, d, x[ 9], S21, 0x21e1cde6); /* 25 */ + GG (d, a, b, c, x[14], S22, 0xc33707d6); /* 26 */ + GG (c, d, a, b, x[ 3], S23, 0xf4d50d87); /* 27 */ + GG (b, c, d, a, x[ 8], S24, 0x455a14ed); /* 28 */ + GG (a, b, c, d, x[13], S21, 0xa9e3e905); /* 29 */ + GG (d, a, b, c, x[ 2], S22, 0xfcefa3f8); /* 30 */ + GG (c, d, a, b, x[ 7], S23, 0x676f02d9); /* 31 */ + GG (b, c, d, a, x[12], S24, 0x8d2a4c8a); /* 32 */ + + /* Round 3 */ + HH (a, b, c, d, x[ 5], S31, 0xfffa3942); /* 33 */ + HH (d, a, b, c, x[ 8], S32, 0x8771f681); /* 34 */ + HH (c, d, a, b, x[11], S33, 0x6d9d6122); /* 35 */ + HH (b, c, d, a, x[14], S34, 0xfde5380c); /* 36 */ + HH (a, b, c, d, x[ 1], S31, 0xa4beea44); /* 37 */ + HH (d, a, b, c, x[ 4], S32, 0x4bdecfa9); /* 38 */ + HH (c, d, a, b, x[ 7], S33, 0xf6bb4b60); /* 39 */ + HH (b, c, d, a, x[10], S34, 0xbebfbc70); /* 40 */ + HH (a, b, c, d, x[13], S31, 0x289b7ec6); /* 41 */ + HH (d, a, b, c, x[ 0], S32, 0xeaa127fa); /* 42 */ + HH (c, d, a, b, x[ 3], S33, 0xd4ef3085); /* 43 */ + HH (b, c, d, a, x[ 6], S34, 0x4881d05); /* 44 */ + HH (a, b, c, d, x[ 9], S31, 0xd9d4d039); /* 45 */ + HH (d, a, b, c, x[12], S32, 0xe6db99e5); /* 46 */ + HH (c, d, a, b, x[15], S33, 0x1fa27cf8); /* 47 */ + HH (b, c, d, a, x[ 2], S34, 0xc4ac5665); /* 48 */ + + /* Round 4 */ + II (a, b, c, d, x[ 0], S41, 0xf4292244); /* 49 */ + II (d, a, b, c, x[ 7], S42, 0x432aff97); /* 50 */ + II (c, d, a, b, x[14], S43, 0xab9423a7); /* 51 */ + II (b, c, d, a, x[ 5], S44, 0xfc93a039); /* 52 */ + II (a, b, c, d, x[12], S41, 0x655b59c3); /* 53 */ + II (d, a, b, c, x[ 3], S42, 0x8f0ccc92); /* 54 */ + II (c, d, a, b, x[10], S43, 0xffeff47d); /* 55 */ + II (b, c, d, a, x[ 1], S44, 0x85845dd1); /* 56 */ + II (a, b, c, d, x[ 8], S41, 0x6fa87e4f); /* 57 */ + II (d, a, b, c, x[15], S42, 0xfe2ce6e0); /* 58 */ + II (c, d, a, b, x[ 6], S43, 0xa3014314); /* 59 */ + II (b, c, d, a, x[13], S44, 0x4e0811a1); /* 60 */ + II (a, b, c, d, x[ 4], S41, 0xf7537e82); /* 61 */ + II (d, a, b, c, x[11], S42, 0xbd3af235); /* 62 */ + II (c, d, a, b, x[ 2], S43, 0x2ad7d2bb); /* 63 */ + II (b, c, d, a, x[ 9], S44, 0xeb86d391); /* 64 */ + + state[0] += a; + state[1] += b; + state[2] += c; + state[3] += d; + + /* + * Zeroize sensitive information. + */ + sys_memset ((POINTER)x, 0, sizeof (x)); +} + +/* + * Encodes input (Uint32) into output (unsigned char). Assumes len is + * a multiple of 4. + */ +static void Encode (output, input, len) + unsigned char *output; + Uint32 *input; + unsigned int len; +{ + unsigned int i, j; + + for (i = 0, j = 0; j < len; i++, j += 4) { + output[j] = (unsigned char)(input[i] & 0xff); + output[j+1] = (unsigned char)((input[i] >> 8) & 0xff); + output[j+2] = (unsigned char)((input[i] >> 16) & 0xff); + output[j+3] = (unsigned char)((input[i] >> 24) & 0xff); + } +} + +/* + * Decodes input (unsigned char) into output (Uint32). Assumes len is + * a multiple of 4. + */ +static void Decode (output, input, len) + Uint32 *output; + unsigned char *input; + unsigned int len; +{ + unsigned int i, j; + + for (i = 0, j = 0; j < len; i++, j += 4) + output[i] = ((Uint32)input[j]) | (((Uint32)input[j+1]) << 8) | + (((Uint32)input[j+2]) << 16) | (((Uint32)input[j+3]) << 24); +} diff --git a/erts/emulator/beam/erl_message.c b/erts/emulator/beam/erl_message.c new file mode 100644 index 0000000000..81fbdfbd5a --- /dev/null +++ b/erts/emulator/beam/erl_message.c @@ -0,0 +1,1070 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1997-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ +/* + * Message passing primitives. + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "erl_message.h" +#include "erl_process.h" +#include "erl_nmgc.h" + +ERTS_SCHED_PREF_QUICK_ALLOC_IMPL(message, + ErlMessage, + ERL_MESSAGE_BUF_SZ, + ERTS_ALC_T_MSG_REF) + +#if defined(DEBUG) && 0 +#define HARD_DEBUG +#else +#undef HARD_DEBUG +#endif + +void +init_message(void) +{ + init_message_alloc(); +} + +void +free_message(ErlMessage* mp) +{ + message_free(mp); +} + +/* Allocate message buffer (size in words) */ +ErlHeapFragment* +new_message_buffer(Uint size) +{ + ErlHeapFragment* bp; + bp = (ErlHeapFragment*) ERTS_HEAP_ALLOC(ERTS_ALC_T_HEAP_FRAG, + ERTS_HEAP_FRAG_SIZE(size)); + ERTS_INIT_HEAP_FRAG(bp, size); + return bp; +} + +ErlHeapFragment* +erts_resize_message_buffer(ErlHeapFragment *bp, Uint size, + Eterm *brefs, Uint brefs_size) +{ +#ifdef DEBUG + int i; +#endif +#ifdef HARD_DEBUG + ErlHeapFragment *dbg_bp; + Eterm *dbg_brefs; + Uint dbg_size; + Uint dbg_tot_size; + Eterm *dbg_hp; +#endif + ErlHeapFragment* nbp; + +#ifdef DEBUG + { + Uint off_sz = size < bp->size ? size : bp->size; + for (i = 0; i < brefs_size; i++) { + Eterm *ptr; + if (is_immed(brefs[i])) + continue; + ptr = ptr_val(brefs[i]); + ASSERT(&bp->mem[0] <= ptr && ptr < &bp->mem[0] + off_sz); + + } + } +#endif + + if (size == bp->size) + return bp; + +#ifdef HARD_DEBUG + dbg_brefs = erts_alloc(ERTS_ALC_T_UNDEF, sizeof(Eterm *)*brefs_size); + dbg_bp = new_message_buffer(bp->size); + dbg_hp = dbg_bp->mem; + dbg_tot_size = 0; + for (i = 0; i < brefs_size; i++) { + dbg_size = size_object(brefs[i]); + dbg_tot_size += dbg_size; + dbg_brefs[i] = copy_struct(brefs[i], dbg_size, &dbg_hp, + &dbg_bp->off_heap); + } + ASSERT(dbg_tot_size == (size < bp->size ? size : bp->size)); +#endif + + nbp = (ErlHeapFragment*) ERTS_HEAP_REALLOC(ERTS_ALC_T_HEAP_FRAG, + (void *) bp, + (sizeof(ErlHeapFragment) + - sizeof(Eterm) + + bp->size*sizeof(Eterm)), + (sizeof(ErlHeapFragment) + - sizeof(Eterm) + + size*sizeof(Eterm))); + if (bp != nbp) { + Uint off_sz = size < nbp->size ? size : nbp->size; + Eterm *sp = &bp->mem[0]; + Eterm *ep = sp + off_sz; + Sint offs = &nbp->mem[0] - sp; + erts_offset_off_heap(&nbp->off_heap, offs, sp, ep); + erts_offset_heap(&nbp->mem[0], off_sz, offs, sp, ep); + if (brefs && brefs_size) + erts_offset_heap_ptr(brefs, brefs_size, offs, sp, ep); +#ifdef DEBUG + for (i = 0; i < brefs_size; i++) { + Eterm *ptr; + if (is_immed(brefs[i])) + continue; + ptr = ptr_val(brefs[i]); + ASSERT(&nbp->mem[0] <= ptr && ptr < &nbp->mem[0] + off_sz); + } +#endif + } + nbp->size = size; + + +#ifdef HARD_DEBUG + for (i = 0; i < brefs_size; i++) + ASSERT(eq(dbg_brefs[i], brefs[i])); + free_message_buffer(dbg_bp); + erts_free(ERTS_ALC_T_UNDEF, dbg_brefs); +#endif + + return nbp; +} + + +void +erts_cleanup_offheap(ErlOffHeap *offheap) +{ + if (offheap->mso) { + erts_cleanup_mso(offheap->mso); + } +#ifndef HYBRID /* FIND ME! */ + if (offheap->funs) { + erts_cleanup_funs(offheap->funs); + } +#endif + if (offheap->externals) { + erts_cleanup_externals(offheap->externals); + } +} + +void +free_message_buffer(ErlHeapFragment* bp) +{ + erts_cleanup_offheap(&bp->off_heap); + ERTS_HEAP_FREE(ERTS_ALC_T_HEAP_FRAG, + (void *) bp, + (sizeof(ErlHeapFragment) + - sizeof(Eterm) + + bp->size*sizeof(Eterm))); +} + +static ERTS_INLINE void +link_mbuf_to_proc(Process *proc, ErlHeapFragment *bp) +{ + if (bp) { + /* Link the message buffer */ + bp->next = MBUF(proc); + MBUF(proc) = bp; + MBUF_SIZE(proc) += bp->size; + FLAGS(proc) |= F_FORCE_GC; + + /* Move any binaries into the process */ + if (bp->off_heap.mso != NULL) { + ProcBin** next_p = &bp->off_heap.mso; + while (*next_p != NULL) { + next_p = &((*next_p)->next); + } + *next_p = MSO(proc).mso; + MSO(proc).mso = bp->off_heap.mso; + bp->off_heap.mso = NULL; + MSO(proc).overhead += bp->off_heap.overhead; + } + + /* Move any funs into the process */ +#ifndef HYBRID + if (bp->off_heap.funs != NULL) { + ErlFunThing** next_p = &bp->off_heap.funs; + while (*next_p != NULL) { + next_p = &((*next_p)->next); + } + *next_p = MSO(proc).funs; + MSO(proc).funs = bp->off_heap.funs; + bp->off_heap.funs = NULL; + } +#endif + + /* Move any external things into the process */ + if (bp->off_heap.externals != NULL) { + ExternalThing** next_p = &bp->off_heap.externals; + while (*next_p != NULL) { + next_p = &((*next_p)->next); + } + *next_p = MSO(proc).externals; + MSO(proc).externals = bp->off_heap.externals; + bp->off_heap.externals = NULL; + } + } +} + +Eterm +erts_msg_distext2heap(Process *pp, + ErtsProcLocks *plcksp, + ErlHeapFragment **bpp, + Eterm *tokenp, + ErtsDistExternal *dist_extp) +{ + Eterm msg; + Uint tok_sz = 0; + Eterm *hp = NULL; + Eterm *hp_end = NULL; + ErlOffHeap *ohp; + Sint sz; + + *bpp = NULL; + sz = erts_decode_dist_ext_size(dist_extp, 0); + if (sz < 0) + goto decode_error; + if (is_not_nil(*tokenp)) { + ErlHeapFragment *heap_frag = erts_dist_ext_trailer(dist_extp); + tok_sz = heap_frag->size; + sz += tok_sz; + } + if (pp) + hp = erts_alloc_message_heap(sz, bpp, &ohp, pp, plcksp); + else { + *bpp = new_message_buffer(sz); + hp = (*bpp)->mem; + ohp = &(*bpp)->off_heap; + } + hp_end = hp + sz; + msg = erts_decode_dist_ext(&hp, ohp, dist_extp); + if (is_non_value(msg)) + goto decode_error; + if (is_not_nil(*tokenp)) { + ErlHeapFragment *heap_frag = erts_dist_ext_trailer(dist_extp); + *tokenp = copy_struct(*tokenp, tok_sz, &hp, ohp); + erts_cleanup_offheap(&heap_frag->off_heap); + } + erts_free_dist_ext_copy(dist_extp); + if (hp_end != hp) { + if (!(*bpp)) { + HRelease(pp, hp_end, hp); + } + else { + Uint final_size = hp - &(*bpp)->mem[0]; + Eterm brefs[2] = {msg, *tokenp}; + ASSERT(sz - (hp_end - hp) == final_size); + *bpp = erts_resize_message_buffer(*bpp, final_size, &brefs[0], 2); + msg = brefs[0]; + *tokenp = brefs[1]; + } + } + return msg; + + decode_error: + if (is_not_nil(*tokenp)) { + ErlHeapFragment *heap_frag = erts_dist_ext_trailer(dist_extp); + erts_cleanup_offheap(&heap_frag->off_heap); + } + erts_free_dist_ext_copy(dist_extp); + if (*bpp) + free_message_buffer(*bpp); + else if (hp) { + HRelease(pp, hp_end, hp); + } + *bpp = NULL; + return THE_NON_VALUE; + } + +static ERTS_INLINE void +notify_new_message(Process *receiver) +{ + ERTS_SMP_LC_ASSERT(ERTS_PROC_LOCK_STATUS + & erts_proc_lc_my_proc_locks(receiver)); + + ACTIVATE(receiver); + + switch (receiver->status) { + case P_GARBING: + switch (receiver->gcstatus) { + case P_SUSPENDED: + goto suspended; + case P_WAITING: + goto waiting; + default: + break; + } + break; + case P_SUSPENDED: + suspended: + receiver->rstatus = P_RUNABLE; + break; + case P_WAITING: + waiting: + erts_add_to_runq(receiver); + break; + default: + break; + } +} + +void +erts_queue_dist_message(Process *rcvr, + ErtsProcLocks *rcvr_locks, + ErtsDistExternal *dist_ext, + Eterm token) +{ + ErlMessage* mp; +#ifdef ERTS_SMP + ErtsProcLocks need_locks; +#endif + + ERTS_SMP_LC_ASSERT(*rcvr_locks == erts_proc_lc_my_proc_locks(rcvr)); + + mp = message_alloc(); + +#ifdef ERTS_SMP + need_locks = ~(*rcvr_locks) & (ERTS_PROC_LOCK_MSGQ|ERTS_PROC_LOCK_STATUS); + if (need_locks) { + *rcvr_locks |= need_locks; + if (erts_smp_proc_trylock(rcvr, need_locks) == EBUSY) { + if (need_locks == ERTS_PROC_LOCK_MSGQ) { + erts_smp_proc_unlock(rcvr, ERTS_PROC_LOCK_STATUS); + need_locks = (ERTS_PROC_LOCK_MSGQ + | ERTS_PROC_LOCK_STATUS); + } + erts_smp_proc_lock(rcvr, need_locks); + } + } + + if (rcvr->is_exiting || ERTS_PROC_PENDING_EXIT(rcvr)) { + /* Drop message if receiver is exiting or has a pending exit ... */ + if (is_not_nil(token)) { + ErlHeapFragment *heap_frag; + heap_frag = erts_dist_ext_trailer(mp->data.dist_ext); + erts_cleanup_offheap(&heap_frag->off_heap); + } + erts_free_dist_ext_copy(dist_ext); + message_free(mp); + } + else +#endif + if (IS_TRACED_FL(rcvr, F_TRACE_RECEIVE)) { + /* Ahh... need to decode it in order to trace it... */ + ErlHeapFragment *mbuf; + Eterm msg; + message_free(mp); + msg = erts_msg_distext2heap(rcvr, rcvr_locks, &mbuf, &token, dist_ext); + if (is_value(msg)) + erts_queue_message(rcvr, rcvr_locks, mbuf, msg, token); + } + else { + /* Enqueue message on external format */ + + ERL_MESSAGE_TERM(mp) = THE_NON_VALUE; + ERL_MESSAGE_TOKEN(mp) = token; + mp->next = NULL; + + mp->data.dist_ext = dist_ext; + LINK_MESSAGE(rcvr, mp); + + notify_new_message(rcvr); + } +} + +/* Add a message last in message queue */ +void +erts_queue_message(Process* receiver, + ErtsProcLocks *receiver_locks, + ErlHeapFragment* bp, + Eterm message, + Eterm seq_trace_token) +{ + ErlMessage* mp; +#ifdef ERTS_SMP + ErtsProcLocks need_locks; +#else + ASSERT(bp != NULL || receiver->mbuf == NULL); +#endif + + ERTS_SMP_LC_ASSERT(*receiver_locks == erts_proc_lc_my_proc_locks(receiver)); + + mp = message_alloc(); + +#ifdef ERTS_SMP + need_locks = ~(*receiver_locks) & (ERTS_PROC_LOCK_MSGQ + | ERTS_PROC_LOCK_STATUS); + if (need_locks) { + *receiver_locks |= need_locks; + if (erts_smp_proc_trylock(receiver, need_locks) == EBUSY) { + if (need_locks == ERTS_PROC_LOCK_MSGQ) { + erts_smp_proc_unlock(receiver, ERTS_PROC_LOCK_STATUS); + need_locks = (ERTS_PROC_LOCK_MSGQ + | ERTS_PROC_LOCK_STATUS); + } + erts_smp_proc_lock(receiver, need_locks); + } + } + + if (receiver->is_exiting || ERTS_PROC_PENDING_EXIT(receiver)) { + /* Drop message if receiver is exiting or has a pending + * exit ... + */ + if (bp) + free_message_buffer(bp); + message_free(mp); + return; + } +#endif + + ERL_MESSAGE_TERM(mp) = message; + ERL_MESSAGE_TOKEN(mp) = seq_trace_token; + mp->next = NULL; + +#ifdef ERTS_SMP + if (*receiver_locks & ERTS_PROC_LOCK_MAIN) { + mp->data.heap_frag = bp; + + /* + * We move 'in queue' to 'private queue' and place + * message at the end of 'private queue' in order + * to ensure that the 'in queue' doesn't contain + * references into the heap. By ensuring this, + * we don't need to include the 'in queue' in + * the root set when garbage collecting. + */ + ERTS_SMP_MSGQ_MV_INQ2PRIVQ(receiver); + LINK_MESSAGE_PRIVQ(receiver, mp); + } + else { + mp->data.heap_frag = bp; + LINK_MESSAGE(receiver, mp); + } +#else + mp->data.heap_frag = bp; + LINK_MESSAGE(receiver, mp); +#endif + + notify_new_message(receiver); + + if (IS_TRACED_FL(receiver, F_TRACE_RECEIVE)) { + trace_receive(receiver, message); + } + +#ifndef ERTS_SMP + ERTS_HOLE_CHECK(receiver); +#endif +} + +void +erts_link_mbuf_to_proc(struct process *proc, ErlHeapFragment *bp) +{ + Eterm* htop = HEAP_TOP(proc); + + link_mbuf_to_proc(proc, bp); + if (htop < HEAP_LIMIT(proc)) { + *htop = make_pos_bignum_header(HEAP_LIMIT(proc)-htop-1); + HEAP_TOP(proc) = HEAP_LIMIT(proc); + } +} + +/* + * Moves content of message buffer attached to a message into a heap. + * The message buffer is deallocated. + */ +void +erts_move_msg_mbuf_to_heap(Eterm** hpp, ErlOffHeap* off_heap, ErlMessage *msg) +{ + /* Unions for typecasts avoids warnings about type-punned pointers and aliasing */ + union { + Uint** upp; + ProcBin **pbpp; + ErlFunThing **efpp; + ExternalThing **etpp; + } oh_list_pp, oh_el_next_pp; + union { + Uint *up; + ProcBin *pbp; + ErlFunThing *efp; + ExternalThing *etp; + } oh_el_p; + Eterm term, token, *fhp, *hp; + Sint offs; + Uint sz; + ErlHeapFragment *bp; + +#ifdef HARD_DEBUG + ProcBin *dbg_mso_start = off_heap->mso; + ErlFunThing *dbg_fun_start = off_heap->funs; + ExternalThing *dbg_external_start = off_heap->externals; + Eterm dbg_term, dbg_token; + ErlHeapFragment *dbg_bp; + Uint *dbg_hp, *dbg_thp_start; + Uint dbg_term_sz, dbg_token_sz; +#endif + + bp = msg->data.heap_frag; + term = ERL_MESSAGE_TERM(msg); + token = ERL_MESSAGE_TOKEN(msg); + if (!bp) { + ASSERT(is_immed(term) && is_immed(token)); + return; + } + +#ifdef HARD_DEBUG + dbg_term_sz = size_object(term); + dbg_token_sz = size_object(token); + ASSERT(bp->size == dbg_term_sz + dbg_token_sz); + + dbg_bp = new_message_buffer(bp->size); + dbg_hp = dbg_bp->mem; + dbg_term = copy_struct(term, dbg_term_sz, &dbg_hp, &dbg_bp->off_heap); + dbg_token = copy_struct(token, dbg_token_sz, &dbg_hp, &dbg_bp->off_heap); + dbg_thp_start = *hpp; +#endif + + ASSERT(bp); + msg->data.attached = NULL; + + off_heap->overhead += bp->off_heap.overhead; + sz = bp->size; + +#ifdef DEBUG + if (is_not_immed(term)) { + ASSERT(bp->mem <= ptr_val(term)); + ASSERT(bp->mem + bp->size > ptr_val(term)); + } + + if (is_not_immed(token)) { + ASSERT(bp->mem <= ptr_val(token)); + ASSERT(bp->mem + bp->size > ptr_val(token)); + } +#endif + + fhp = bp->mem; + hp = *hpp; + offs = hp - fhp; + + oh_list_pp.upp = NULL; + oh_el_next_pp.upp = NULL; /* Shut up compiler warning */ + oh_el_p.up = NULL; /* Shut up compiler warning */ + while (sz--) { + Uint cpy_sz; + Eterm val = *fhp++; + + switch (primary_tag(val)) { + case TAG_PRIMARY_IMMED1: + *hp++ = val; + break; + case TAG_PRIMARY_LIST: + case TAG_PRIMARY_BOXED: + ASSERT(bp->mem <= ptr_val(val)); + ASSERT(bp->mem + bp->size > ptr_val(val)); + *hp++ = offset_ptr(val, offs); + break; + case TAG_PRIMARY_HEADER: + *hp++ = val; + switch (val & _HEADER_SUBTAG_MASK) { + case ARITYVAL_SUBTAG: + break; + case REFC_BINARY_SUBTAG: + oh_list_pp.pbpp = &off_heap->mso; + oh_el_p.up = (hp-1); + oh_el_next_pp.pbpp = &(oh_el_p.pbp)->next; + cpy_sz = thing_arityval(val); + goto cpy_words; + case FUN_SUBTAG: +#ifndef HYBRID + oh_list_pp.efpp = &off_heap->funs; + oh_el_p.up = (hp-1); + oh_el_next_pp.efpp = &(oh_el_p.efp)->next; +#endif + cpy_sz = thing_arityval(val); + goto cpy_words; + case EXTERNAL_PID_SUBTAG: + case EXTERNAL_PORT_SUBTAG: + case EXTERNAL_REF_SUBTAG: + oh_list_pp.etpp = &off_heap->externals; + oh_el_p.up = (hp-1); + oh_el_next_pp.etpp = &(oh_el_p.etp)->next; + cpy_sz = thing_arityval(val); + goto cpy_words; + default: + cpy_sz = header_arity(val); + + cpy_words: + sz -= cpy_sz; + while (cpy_sz >= 8) { + cpy_sz -= 8; + *hp++ = *fhp++; + *hp++ = *fhp++; + *hp++ = *fhp++; + *hp++ = *fhp++; + *hp++ = *fhp++; + *hp++ = *fhp++; + *hp++ = *fhp++; + *hp++ = *fhp++; + } + switch (cpy_sz) { + case 7: *hp++ = *fhp++; + case 6: *hp++ = *fhp++; + case 5: *hp++ = *fhp++; + case 4: *hp++ = *fhp++; + case 3: *hp++ = *fhp++; + case 2: *hp++ = *fhp++; + case 1: *hp++ = *fhp++; + default: break; + } + if (oh_list_pp.upp) { +#ifdef HARD_DEBUG + Uint *dbg_old_oh_list_p = *oh_list_pp.upp; +#endif + /* Add to offheap list */ + *oh_el_next_pp.upp = *oh_list_pp.upp; + *oh_list_pp.upp = oh_el_p.up; + ASSERT(*hpp <= oh_el_p.up); + ASSERT(hp > oh_el_p.up); +#ifdef HARD_DEBUG + switch (val & _HEADER_SUBTAG_MASK) { + case REFC_BINARY_SUBTAG: + ASSERT(off_heap->mso == *oh_list_pp.pbpp); + ASSERT(off_heap->mso->next + == (ProcBin *) dbg_old_oh_list_p); + break; +#ifndef HYBRID + case FUN_SUBTAG: + ASSERT(off_heap->funs == *oh_list_pp.efpp); + ASSERT(off_heap->funs->next + == (ErlFunThing *) dbg_old_oh_list_p); + break; +#endif + case EXTERNAL_PID_SUBTAG: + case EXTERNAL_PORT_SUBTAG: + case EXTERNAL_REF_SUBTAG: + ASSERT(off_heap->externals + == *oh_list_pp.etpp); + ASSERT(off_heap->externals->next + == (ExternalThing *) dbg_old_oh_list_p); + break; + default: + ASSERT(0); + } +#endif + oh_list_pp.upp = NULL; + + + } + break; + } + break; + } + } + + ASSERT(bp->size == hp - *hpp); + *hpp = hp; + + if (is_not_immed(token)) { + ASSERT(bp->mem <= ptr_val(token)); + ASSERT(bp->mem + bp->size > ptr_val(token)); + ERL_MESSAGE_TOKEN(msg) = offset_ptr(token, offs); +#ifdef HARD_DEBUG + ASSERT(dbg_thp_start <= ptr_val(ERL_MESSAGE_TOKEN(msg))); + ASSERT(hp > ptr_val(ERL_MESSAGE_TOKEN(msg))); +#endif + } + + if (is_not_immed(term)) { + ASSERT(bp->mem <= ptr_val(term)); + ASSERT(bp->mem + bp->size > ptr_val(term)); + ERL_MESSAGE_TERM(msg) = offset_ptr(term, offs); +#ifdef HARD_DEBUG + ASSERT(dbg_thp_start <= ptr_val(ERL_MESSAGE_TERM(msg))); + ASSERT(hp > ptr_val(ERL_MESSAGE_TERM(msg))); +#endif + } + + +#ifdef HARD_DEBUG + { + int i, j; + { + ProcBin *mso = off_heap->mso; + i = j = 0; + while (mso != dbg_mso_start) { + mso = mso->next; + i++; + } + mso = bp->off_heap.mso; + while (mso) { + mso = mso->next; + j++; + } + ASSERT(i == j); + } + { + ErlFunThing *fun = off_heap->funs; + i = j = 0; + while (fun != dbg_fun_start) { + fun = fun->next; + i++; + } + fun = bp->off_heap.funs; + while (fun) { + fun = fun->next; + j++; + } + ASSERT(i == j); + } + { + ExternalThing *external = off_heap->externals; + i = j = 0; + while (external != dbg_external_start) { + external = external->next; + i++; + } + external = bp->off_heap.externals; + while (external) { + external = external->next; + j++; + } + ASSERT(i == j); + } + } +#endif + + + bp->off_heap.mso = NULL; +#ifndef HYBRID + bp->off_heap.funs = NULL; +#endif + bp->off_heap.externals = NULL; + free_message_buffer(bp); + +#ifdef HARD_DEBUG + ASSERT(eq(ERL_MESSAGE_TERM(msg), dbg_term)); + ASSERT(eq(ERL_MESSAGE_TOKEN(msg), dbg_token)); + free_message_buffer(dbg_bp); +#endif + +} + +Uint +erts_msg_attached_data_size_aux(ErlMessage *msg) +{ + Sint sz; + ASSERT(is_non_value(ERL_MESSAGE_TERM(msg))); + ASSERT(msg->data.dist_ext); + ASSERT(msg->data.dist_ext->heap_size < 0); + + sz = erts_decode_dist_ext_size(msg->data.dist_ext, 0); + if (sz < 0) { + /* Bad external; remove it */ + if (is_not_nil(ERL_MESSAGE_TOKEN(msg))) { + ErlHeapFragment *heap_frag; + heap_frag = erts_dist_ext_trailer(msg->data.dist_ext); + erts_cleanup_offheap(&heap_frag->off_heap); + } + erts_free_dist_ext_copy(msg->data.dist_ext); + msg->data.dist_ext = NULL; + return 0; + } + + msg->data.dist_ext->heap_size = sz; + if (is_not_nil(msg->m[1])) { + ErlHeapFragment *heap_frag; + heap_frag = erts_dist_ext_trailer(msg->data.dist_ext); + sz += heap_frag->size; + } + return sz; +} + +void +erts_move_msg_attached_data_to_heap(Eterm **hpp, ErlOffHeap *ohp, ErlMessage *msg) +{ + if (is_value(ERL_MESSAGE_TERM(msg))) + erts_move_msg_mbuf_to_heap(hpp, ohp, msg); + else if (msg->data.dist_ext) { + ASSERT(msg->data.dist_ext->heap_size >= 0); + if (is_not_nil(ERL_MESSAGE_TOKEN(msg))) { + ErlHeapFragment *heap_frag; + heap_frag = erts_dist_ext_trailer(msg->data.dist_ext); + ERL_MESSAGE_TOKEN(msg) = copy_struct(ERL_MESSAGE_TOKEN(msg), + heap_frag->size, + hpp, + ohp); + erts_cleanup_offheap(&heap_frag->off_heap); + } + ERL_MESSAGE_TERM(msg) = erts_decode_dist_ext(hpp, + ohp, + msg->data.dist_ext); + erts_free_dist_ext_copy(msg->data.dist_ext); + msg->data.dist_ext = NULL; + } + /* else: bad external detected when calculating size */ +} + +/* + * Send a local message when sender & receiver processes are known. + */ + +void +erts_send_message(Process* sender, + Process* receiver, + ErtsProcLocks *receiver_locks, + Eterm message, + unsigned flags) +{ + Uint msize; + ErlHeapFragment* bp = NULL; + Eterm token = NIL; + + BM_STOP_TIMER(system); + BM_MESSAGE(message,sender,receiver); + BM_START_TIMER(send); + + if (SEQ_TRACE_TOKEN(sender) != NIL && !(flags & ERTS_SND_FLG_NO_SEQ_TRACE)) { + Eterm* hp; + + BM_SWAP_TIMER(send,size); + msize = size_object(message); + BM_SWAP_TIMER(size,send); + + seq_trace_update_send(sender); + seq_trace_output(SEQ_TRACE_TOKEN(sender), message, SEQ_TRACE_SEND, + receiver->id, sender); + bp = new_message_buffer(msize + 6 /* TUPLE5 */); + hp = bp->mem; + + BM_SWAP_TIMER(send,copy); + token = copy_struct(SEQ_TRACE_TOKEN(sender), + 6 /* TUPLE5 */, + &hp, + &bp->off_heap); + + message = copy_struct(message, msize, &hp, &bp->off_heap); + BM_MESSAGE_COPIED(msize); + BM_SWAP_TIMER(copy,send); + + erts_queue_message(receiver, + receiver_locks, + bp, + message, + token); + BM_SWAP_TIMER(send,system); +#ifdef HYBRID + } else { + ErlMessage* mp = message_alloc(); + BM_SWAP_TIMER(send,copy); +#ifdef INCREMENTAL + /* TODO: During GC activate processes if the message relies in + * the fromspace and the sender is active. During major + * collections add the message to the gray stack if it relies + * in the old generation and the sender is active and the + * receiver is inactive. + + if (!IS_CONST(message) && (ma_gc_flags & GC_CYCLE) && + (ptr_val(message) >= inc_fromspc && + ptr_val(message) < inc_fromend) && INC_IS_ACTIVE(sender)) + INC_ACTIVATE(receiver); + else if (!IS_CONST(message) && (ma_gc_flags & GC_CYCLE) && + (ptr_val(message) >= global_old_heap && + ptr_val(message) < global_old_hend) && + INC_IS_ACTIVE(sender) && !INC_IS_ACTIVE(receiver)) + Mark message in blackmap and add it to the gray stack + */ + + if (!IS_CONST(message)) + INC_ACTIVATE(receiver); +#endif + LAZY_COPY(sender,message); + BM_SWAP_TIMER(copy,send); + ERL_MESSAGE_TERM(mp) = message; + ERL_MESSAGE_TOKEN(mp) = NIL; + mp->next = NULL; + LINK_MESSAGE(receiver, mp); + ACTIVATE(receiver); + + if (receiver->status == P_WAITING) { + erts_add_to_runq(receiver); + } else if (receiver->status == P_SUSPENDED) { + receiver->rstatus = P_RUNABLE; + } + if (IS_TRACED_FL(receiver, F_TRACE_RECEIVE)) { + trace_receive(receiver, message); + } + + BM_SWAP_TIMER(send,system); + return; +#else + } else if (sender == receiver) { + /* Drop message if receiver has a pending exit ... */ +#ifdef ERTS_SMP + ErtsProcLocks need_locks = (~(*receiver_locks) + & (ERTS_PROC_LOCK_MSGQ + | ERTS_PROC_LOCK_STATUS)); + if (need_locks) { + *receiver_locks |= need_locks; + if (erts_smp_proc_trylock(receiver, need_locks) == EBUSY) { + if (need_locks == ERTS_PROC_LOCK_MSGQ) { + erts_smp_proc_unlock(receiver, ERTS_PROC_LOCK_STATUS); + need_locks = ERTS_PROC_LOCK_MSGQ|ERTS_PROC_LOCK_STATUS; + } + erts_smp_proc_lock(receiver, need_locks); + } + } + if (!ERTS_PROC_PENDING_EXIT(receiver)) +#endif + { + ErlMessage* mp = message_alloc(); + + mp->data.attached = NULL; + ERL_MESSAGE_TERM(mp) = message; + ERL_MESSAGE_TOKEN(mp) = NIL; + mp->next = NULL; + /* + * We move 'in queue' to 'private queue' and place + * message at the end of 'private queue' in order + * to ensure that the 'in queue' doesn't contain + * references into the heap. By ensuring this, + * we don't need to include the 'in queue' in + * the root set when garbage collecting. + */ + + ERTS_SMP_MSGQ_MV_INQ2PRIVQ(receiver); + LINK_MESSAGE_PRIVQ(receiver, mp); + + if (IS_TRACED_FL(receiver, F_TRACE_RECEIVE)) { + trace_receive(receiver, message); + } + } + BM_SWAP_TIMER(send,system); + return; + } else { +#ifdef ERTS_SMP + ErlOffHeap *ohp; + Eterm *hp; + BM_SWAP_TIMER(send,size); + msize = size_object(message); + BM_SWAP_TIMER(size,send); + hp = erts_alloc_message_heap(msize,&bp,&ohp,receiver,receiver_locks); + BM_SWAP_TIMER(send,copy); + message = copy_struct(message, msize, &hp, ohp); + BM_MESSAGE_COPIED(msz); + BM_SWAP_TIMER(copy,send); + erts_queue_message(receiver, receiver_locks, bp, message, token); + BM_SWAP_TIMER(send,system); +#else + ErlMessage* mp = message_alloc(); + Eterm *hp; + BM_SWAP_TIMER(send,size); + msize = size_object(message); + BM_SWAP_TIMER(size,send); + + if (receiver->stop - receiver->htop <= msize) { + BM_SWAP_TIMER(send,system); + erts_garbage_collect(receiver, msize, receiver->arg_reg, receiver->arity); + BM_SWAP_TIMER(system,send); + } + hp = receiver->htop; + receiver->htop = hp + msize; + BM_SWAP_TIMER(send,copy); + message = copy_struct(message, msize, &hp, &receiver->off_heap); + BM_MESSAGE_COPIED(msize); + BM_SWAP_TIMER(copy,send); + ERL_MESSAGE_TERM(mp) = message; + ERL_MESSAGE_TOKEN(mp) = NIL; + mp->next = NULL; + mp->data.attached = NULL; + LINK_MESSAGE(receiver, mp); + + if (receiver->status == P_WAITING) { + erts_add_to_runq(receiver); + } else if (receiver->status == P_SUSPENDED) { + receiver->rstatus = P_RUNABLE; + } + if (IS_TRACED_FL(receiver, F_TRACE_RECEIVE)) { + trace_receive(receiver, message); + } + BM_SWAP_TIMER(send,system); +#endif /* #ifndef ERTS_SMP */ + return; +#endif /* HYBRID */ + } +} + +/* + * This function delivers an EXIT message to a process + * which is trapping EXITs. + */ + +void +erts_deliver_exit_message(Eterm from, Process *to, ErtsProcLocks *to_locksp, + Eterm reason, Eterm token) +{ + Eterm mess; + Eterm save; + Eterm from_copy; + Uint sz_reason; + Uint sz_token; + Uint sz_from; + Eterm* hp; + Eterm temptoken; + ErlHeapFragment* bp = NULL; + + if (token != NIL) { + + ASSERT(is_tuple(token)); + sz_reason = size_object(reason); + sz_token = size_object(token); + sz_from = size_object(from); + bp = new_message_buffer(sz_reason + sz_from + sz_token + 4); + hp = bp->mem; + mess = copy_struct(reason, sz_reason, &hp, &bp->off_heap); + from_copy = copy_struct(from, sz_from, &hp, &bp->off_heap); + save = TUPLE3(hp, am_EXIT, from_copy, mess); + hp += 4; + /* the trace token must in this case be updated by the caller */ + seq_trace_output(token, save, SEQ_TRACE_SEND, to->id, NULL); + temptoken = copy_struct(token, sz_token, &hp, &bp->off_heap); + erts_queue_message(to, to_locksp, bp, save, temptoken); + } else { + ErlOffHeap *ohp; + sz_reason = size_object(reason); + sz_from = IS_CONST(from) ? 0 : size_object(from); + + hp = erts_alloc_message_heap(sz_reason+sz_from+4, + &bp, + &ohp, + to, + to_locksp); + + mess = copy_struct(reason, sz_reason, &hp, ohp); + from_copy = (IS_CONST(from) + ? from + : copy_struct(from, sz_from, &hp, ohp)); + save = TUPLE3(hp, am_EXIT, from_copy, mess); + erts_queue_message(to, to_locksp, bp, save, NIL); + } +} diff --git a/erts/emulator/beam/erl_message.h b/erts/emulator/beam/erl_message.h new file mode 100644 index 0000000000..f14f14a586 --- /dev/null +++ b/erts/emulator/beam/erl_message.h @@ -0,0 +1,251 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1997-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifndef __ERL_MESSAGE_H__ +#define __ERL_MESSAGE_H__ + +struct proc_bin; +struct external_thing_; + +/* + * This struct represents data that must be updated by structure copy, + * but is stored outside of any heap. + */ + +typedef struct erl_off_heap { + struct proc_bin* mso; /* List of associated binaries. */ +#ifndef HYBRID /* FIND ME! */ + struct erl_fun_thing* funs; /* List of funs. */ +#endif + struct external_thing_* externals; /* List of external things. */ + int overhead; /* Administrative overhead (used to force GC). */ +} ErlOffHeap; + +#include "external.h" +#include "erl_process.h" + +/* + * This struct represents a heap fragment, which is used when there + * isn't sufficient room in the process heap and we can't do a GC. + */ + +typedef struct erl_heap_fragment ErlHeapFragment; +struct erl_heap_fragment { + ErlHeapFragment* next; /* Next heap fragment */ + ErlOffHeap off_heap; /* Offset heap data. */ + unsigned size; /* Size in words of mem */ + Eterm mem[1]; /* Data */ +}; + +#define ERTS_SET_MBUF_HEAP_END(BP, HENDP) \ +do { \ + unsigned real_size__ = (BP)->size; \ + ASSERT((BP)->mem <= (HENDP) && (HENDP) <= (BP)->mem + real_size__); \ + (BP)->size = (HENDP) - (BP)->mem; \ + /* We do not reallocate since buffer *might* be moved. */ \ + /* FIXME: Memory count is wrong, but at least it's almost */ \ + /* right... */ \ +} while (0) + +typedef struct erl_mesg { + struct erl_mesg* next; /* Next message */ + union { + ErtsDistExternal *dist_ext; + ErlHeapFragment *heap_frag; + void *attached; + } data; + Eterm m[2]; /* m[0] = message, m[1] = seq trace token */ +} ErlMessage; + +#define ERL_MESSAGE_TERM(mp) ((mp)->m[0]) +#define ERL_MESSAGE_TOKEN(mp) ((mp)->m[1]) + +/* Size of default message buffer (erl_message.c) */ +#define ERL_MESSAGE_BUF_SZ 500 + +typedef struct { + ErlMessage* first; + ErlMessage** last; /* point to the last next pointer */ + ErlMessage** save; + int len; /* queue length */ +} ErlMessageQueue; + +#ifdef ERTS_SMP + +typedef struct { + ErlMessage* first; + ErlMessage** last; /* point to the last next pointer */ + int len; /* queue length */ +} ErlMessageInQueue; + +#endif + +/* Get "current" message */ +#define PEEK_MESSAGE(p) (*(p)->msg.save) + + +/* Add message last in private message queue */ +#define LINK_MESSAGE_PRIVQ(p, mp) do { \ + *(p)->msg.last = (mp); \ + (p)->msg.last = &(mp)->next; \ + (p)->msg.len++; \ +} while(0) + + +#ifdef ERTS_SMP + +/* Move in message queue to end of private message queue */ +#define ERTS_SMP_MSGQ_MV_INQ2PRIVQ(P) \ +do { \ + if ((P)->msg_inq.first) { \ + *(P)->msg.last = (P)->msg_inq.first; \ + (P)->msg.last = (P)->msg_inq.last; \ + (P)->msg.len += (P)->msg_inq.len; \ + (P)->msg_inq.first = NULL; \ + (P)->msg_inq.last = &(P)->msg_inq.first; \ + (P)->msg_inq.len = 0; \ + } \ +} while (0) + +/* Add message last in message queue */ +#define LINK_MESSAGE(p, mp) do { \ + *(p)->msg_inq.last = (mp); \ + (p)->msg_inq.last = &(mp)->next; \ + (p)->msg_inq.len++; \ +} while(0) + +#else + +#define ERTS_SMP_MSGQ_MV_INQ2PRIVQ(P) + +/* Add message last in message queue */ +#define LINK_MESSAGE(p, mp) LINK_MESSAGE_PRIVQ((p), (mp)) + +#endif + +/* Unlink current message */ +#define UNLINK_MESSAGE(p,msgp) do { \ + ErlMessage* __mp = (msgp)->next; \ + *(p)->msg.save = __mp; \ + (p)->msg.len--; \ + if (__mp == NULL) \ + (p)->msg.last = (p)->msg.save; \ +} while(0) + +/* Reset message save point (after receive match) */ +#define JOIN_MESSAGE(p) \ + (p)->msg.save = &(p)->msg.first + +/* Save current message */ +#define SAVE_MESSAGE(p) \ + (p)->msg.save = &(*(p)->msg.save)->next + +/* + * ErtsMoveMsgAttachmentIntoProc() moves data attached to a message + * onto the heap of a process. The attached data is the content of + * the the message either on the internal format or on the external + * format, and also possibly a seq trace token on the internal format. + * If the message content is on the external format, the decode might + * fail. If the decoding fails, ERL_MESSAGE_TERM(M) will contain + * THE_NON_VALUE. That is, ERL_MESSAGE_TERM(M) *has* to be checked + * afterwards and taken care of appropriately. + * + * ErtsMoveMsgAttachmentIntoProc() will shallow copy to heap if + * possible; otherwise, move to heap via garbage collection. + * + * ErtsMoveMsgAttachmentIntoProc() is used when receiveing messages + * in process_main() and in hipe_check_get_msg(). + */ + +#define ErtsMoveMsgAttachmentIntoProc(M, P, ST, HT, FC, SWPO, SWPI) \ +do { \ + if ((M)->data.attached) { \ + Uint need__ = erts_msg_attached_data_size((M)); \ + if ((ST) - (HT) >= need__) { \ + Uint *htop__ = (HT); \ + erts_move_msg_attached_data_to_heap(&htop__, &MSO((P)), (M));\ + ASSERT(htop__ - (HT) <= need__); \ + (HT) = htop__; \ + } \ + else { \ + { SWPO ; } \ + (FC) -= erts_garbage_collect((P), 0, NULL, 0); \ + { SWPI ; } \ + } \ + ASSERT(!(M)->data.attached); \ + } \ +} while (0) + +#define ERTS_SND_FLG_NO_SEQ_TRACE (((unsigned) 1) << 0) + +#define ERTS_HEAP_FRAG_SIZE(DATA_WORDS) \ + (sizeof(ErlHeapFragment) - sizeof(Eterm) + (DATA_WORDS)*sizeof(Eterm)) +#define ERTS_INIT_HEAP_FRAG(HEAP_FRAG_P, DATA_WORDS) \ +do { \ + (HEAP_FRAG_P)->next = NULL; \ + (HEAP_FRAG_P)->size = (DATA_WORDS); \ + (HEAP_FRAG_P)->off_heap.mso = NULL; \ + (HEAP_FRAG_P)->off_heap.funs = NULL; \ + (HEAP_FRAG_P)->off_heap.externals = NULL; \ + (HEAP_FRAG_P)->off_heap.overhead = 0; \ +} while (0) + +void init_message(void); +void free_message(ErlMessage *); +ErlHeapFragment* new_message_buffer(Uint); +ErlHeapFragment* erts_resize_message_buffer(ErlHeapFragment *, Uint, + Eterm *, Uint); +void free_message_buffer(ErlHeapFragment *); +void erts_queue_dist_message(Process*, ErtsProcLocks*, ErtsDistExternal *, Eterm); +void erts_queue_message(Process*, ErtsProcLocks*, ErlHeapFragment*, Eterm, Eterm); +void erts_deliver_exit_message(Eterm, Process*, ErtsProcLocks *, Eterm, Eterm); +void erts_send_message(Process*, Process*, ErtsProcLocks*, Eterm, unsigned); +void erts_link_mbuf_to_proc(Process *proc, ErlHeapFragment *bp); + +void erts_move_msg_mbuf_to_heap(Eterm**, ErlOffHeap*, ErlMessage *); + +Uint erts_msg_attached_data_size_aux(ErlMessage *msg); +void erts_move_msg_attached_data_to_heap(Eterm **, ErlOffHeap *, ErlMessage *); + +Eterm erts_msg_distext2heap(Process *, ErtsProcLocks *, ErlHeapFragment **, + Eterm *, ErtsDistExternal *); + +ERTS_GLB_INLINE Uint erts_msg_attached_data_size(ErlMessage *msg); + +#if ERTS_GLB_INLINE_INCL_FUNC_DEF +ERTS_GLB_INLINE Uint erts_msg_attached_data_size(ErlMessage *msg) +{ + ASSERT(msg->data.attached); + if (is_value(ERL_MESSAGE_TERM(msg))) + return msg->data.heap_frag->size; + else if (msg->data.dist_ext->heap_size < 0) + return erts_msg_attached_data_size_aux(msg); + else { + Uint sz = msg->data.dist_ext->heap_size; + if (is_not_nil(ERL_MESSAGE_TOKEN(msg))) { + ErlHeapFragment *heap_frag; + heap_frag = erts_dist_ext_trailer(msg->data.dist_ext); + sz += heap_frag->size; + } + return sz; + } +} +#endif + +#endif diff --git a/erts/emulator/beam/erl_monitors.c b/erts/emulator/beam/erl_monitors.c new file mode 100644 index 0000000000..d873c7a701 --- /dev/null +++ b/erts/emulator/beam/erl_monitors.c @@ -0,0 +1,1019 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2004-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/************************************************************************** + * Monitors and links data structure manipulation. + * Monitors and links are organized as AVL trees with the reference as + * key in the monitor case and the pid of the linked process as key in the + * link case. Lookups the order of the references is somewhat special. Local + * references are strictly smaller than remote references and are sorted + * by inlined comparision functionality. Remote references are handled by the + * usual cmp function. + * Each Monitor is tagged with different tags depending on which end of the + * monitor it is. + * A monitor is removed either explicitly by reference or all monitors are + * removed when the process exits. No need to access the monitor by pid. + **************************************************************************/ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "erl_process.h" +#include "error.h" +#include "erl_db.h" +#include "bif.h" +#include "big.h" +#include "erl_monitors.h" + +#define STACK_NEED 50 +#define MAX_MONITORS 0xFFFFFFFFUL + +#define DIR_LEFT 0 +#define DIR_RIGHT 1 +#define DIR_END 2 + +static erts_smp_atomic_t tot_link_lh_size; + +/* Implements the sort order in monitor trees, which is different from + the ordinary term order. + No short local ref's should ever exist (the ref is created by the bif's + in runtime), therefore: + All local ref's are less than external ref's + Local ref's are inline-compared, + External ref's are compared by cmp */ + +#if 0 +#define CMP_MON_REF(Ref1,Ref2) \ +cmp((Ref1),(Ref2)) /* XXX, the inline comparision yet to be done */ +#else +#define CMP_MON_REF(Ref1,Ref2) cmp_mon_ref((Ref1),(Ref2)) +#endif + +static ERTS_INLINE int cmp_mon_ref(Eterm ref1, Eterm ref2) +{ + Eterm *b1, *b2; + + + b1 = boxed_val(ref1); + b2 = boxed_val(ref2); + if (is_ref_thing_header(*b1)) { + if (is_ref_thing_header(*b2)) { + return memcmp(b1+1,b2+1,ERTS_REF_WORDS*sizeof(Uint)); + } + return -1; + } + if (is_ref_thing_header(*b2)) { + return 1; + } + return cmp(ref1,ref2); +} + +#define CP_LINK_VAL(To, Hp, From) \ +do { \ + if (IS_CONST(From)) \ + (To) = (From); \ + else { \ + Uint i__; \ + Uint len__; \ + ASSERT((Hp)); \ + ASSERT(is_internal_ref((From)) || is_external((From))); \ + (To) = make_boxed((Hp)); \ + len__ = thing_arityval(*boxed_val((From))) + 1; \ + for(i__ = 0; i__ < len__; i__++) \ + (*((Hp)++)) = boxed_val((From))[i__]; \ + if (is_external((To))) { \ + external_thing_ptr((To))->next = NULL; \ + erts_refc_inc(&(external_thing_ptr((To))->node->refc), 2);\ + } \ + } \ +} while (0) + +static ErtsMonitor *create_monitor(Uint type, Eterm ref, Eterm pid, Eterm name) +{ + Uint mon_size = ERTS_MONITOR_SIZE; + ErtsMonitor *n; + Eterm *hp; + + mon_size += NC_HEAP_SIZE(ref); + if (!IS_CONST(pid)) { + mon_size += NC_HEAP_SIZE(pid); + } + + if (mon_size <= ERTS_MONITOR_SH_SIZE) { + n = (ErtsMonitor *) erts_alloc(ERTS_ALC_T_MONITOR_SH, + mon_size*sizeof(Uint)); + } else { + n = (ErtsMonitor *) erts_alloc(ERTS_ALC_T_MONITOR_LH, + mon_size*sizeof(Uint)); + erts_smp_atomic_add(&tot_link_lh_size, mon_size*sizeof(Uint)); + } + hp = n->heap; + + + n->left = n->right = NULL; /* Always the same initial value*/ + n->type = (Uint16) type; + n->balance = 0; /* Always the same initial value */ + n->name = name; /* atom() or [] */ + CP_LINK_VAL(n->ref, hp, ref); /*XXX Unneccesary check, never immediate*/ + CP_LINK_VAL(n->pid, hp, pid); + + return n; +} + +static ErtsLink *create_link(Uint type, Eterm pid) +{ + Uint lnk_size = ERTS_LINK_SIZE; + ErtsLink *n; + Eterm *hp; + + if (!IS_CONST(pid)) { + lnk_size += NC_HEAP_SIZE(pid); + } + + if (lnk_size <= ERTS_LINK_SH_SIZE) { + n = (ErtsLink *) erts_alloc(ERTS_ALC_T_NLINK_SH, + lnk_size*sizeof(Uint)); + } else { + n = (ErtsLink *) erts_alloc(ERTS_ALC_T_NLINK_LH, + lnk_size*sizeof(Uint)); + erts_smp_atomic_add(&tot_link_lh_size, lnk_size*sizeof(Uint)); + } + hp = n->heap; + + + n->left = n->right = NULL; /* Always the same initial value*/ + n->type = (Uint16) type; + n->balance = 0; /* Always the same initial value */ + if (n->type == LINK_NODE) { + ERTS_LINK_REFC(n) = 0; + } else { + ERTS_LINK_ROOT(n) = NULL; + } + CP_LINK_VAL(n->pid, hp, pid); + + return n; +} + +#undef CP_LINK_VAL + +static ErtsSuspendMonitor *create_suspend_monitor(Eterm pid) +{ + ErtsSuspendMonitor *smon = erts_alloc(ERTS_ALC_T_SUSPEND_MON, + sizeof(ErtsSuspendMonitor)); + smon->left = smon->right = NULL; /* Always the same initial value */ + smon->balance = 0; /* Always the same initial value */ + smon->pending = 0; + smon->active = 0; + smon->pid = pid; + return smon; +} + +void +erts_init_monitors(void) +{ + erts_smp_atomic_init(&tot_link_lh_size, 0); +} + +Uint +erts_tot_link_lh_size(void) +{ + return (Uint) erts_smp_atomic_read(&tot_link_lh_size); +} + +void erts_destroy_monitor(ErtsMonitor *mon) +{ + Uint mon_size = ERTS_MONITOR_SIZE; + ErlNode *node; + + ASSERT(!IS_CONST(mon->ref)); + mon_size += NC_HEAP_SIZE(mon->ref); + if (is_external(mon->ref)) { + node = external_thing_ptr(mon->ref)->node; + erts_deref_node_entry(node); + } + if (!IS_CONST(mon->pid)) { + mon_size += NC_HEAP_SIZE(mon->pid); + if (is_external(mon->pid)) { + node = external_thing_ptr(mon->pid)->node; + erts_deref_node_entry(node); + } + } + if (mon_size <= ERTS_MONITOR_SH_SIZE) { + erts_free(ERTS_ALC_T_MONITOR_SH, (void *) mon); + } else { + erts_free(ERTS_ALC_T_MONITOR_LH, (void *) mon); + erts_smp_atomic_add(&tot_link_lh_size, -1*mon_size*sizeof(Uint)); + } +} + +void erts_destroy_link(ErtsLink *lnk) +{ + Uint lnk_size = ERTS_LINK_SIZE; + ErlNode *node; + + ASSERT(lnk->type == LINK_NODE || ERTS_LINK_ROOT(lnk) == NULL); + + if (!IS_CONST(lnk->pid)) { + lnk_size += NC_HEAP_SIZE(lnk->pid); + if (is_external(lnk->pid)) { + node = external_thing_ptr(lnk->pid)->node; + erts_deref_node_entry(node); + } + } + if (lnk_size <= ERTS_LINK_SH_SIZE) { + erts_free(ERTS_ALC_T_NLINK_SH, (void *) lnk); + } else { + erts_free(ERTS_ALC_T_NLINK_LH, (void *) lnk); + erts_smp_atomic_add(&tot_link_lh_size, -1*lnk_size*sizeof(Uint)); + } +} + +void erts_destroy_suspend_monitor(ErtsSuspendMonitor *smon) +{ + erts_free(ERTS_ALC_T_SUSPEND_MON, smon); +} + +static void insertion_rotation(int dstack[], int dpos, + void *tstack[], int tpos, + int state) { + + ErtsMonitorOrLink **this; + ErtsMonitorOrLink *p1, *p2, *p; + int dir; + + while (state && ( dir = dstack[--dpos] ) != DIR_END) { + this = tstack[--tpos]; + p = *this; + if (dir == DIR_LEFT) { + switch (p->balance) { + case 1: + p->balance = 0; + state = 0; + break; + case 0: + p->balance = -1; + break; + case -1: /* The icky case */ + p1 = p->left; + if (p1->balance == -1) { /* Single LL rotation */ + p->left = p1->right; + p1->right = p; + p->balance = 0; + (*this) = p1; + } else { /* Double RR rotation */ + p2 = p1->right; + p1->right = p2->left; + p2->left = p1; + p->left = p2->right; + p2->right = p; + p->balance = (p2->balance == -1) ? +1 : 0; + p1->balance = (p2->balance == 1) ? -1 : 0; + (*this) = p2; + } + (*this)->balance = 0; + state = 0; + break; + } + } else { /* dir == DIR_RIGHT */ + switch (p->balance) { + case -1: + p->balance = 0; + state = 0; + break; + case 0: + p->balance = 1; + break; + case 1: + p1 = p->right; + if (p1->balance == 1) { /* Single RR rotation */ + p->right = p1->left; + p1->left = p; + p->balance = 0; + (*this) = p1; + } else { /* Double RL rotation */ + p2 = p1->left; + p1->left = p2->right; + p2->right = p1; + p->right = p2->left; + p2->left = p; + p->balance = (p2->balance == 1) ? -1 : 0; + p1->balance = (p2->balance == -1) ? 1 : 0; + (*this) = p2; + } + (*this)->balance = 0; + state = 0; + break; + } + } + } +} + +void erts_add_monitor(ErtsMonitor **root, Uint type, Eterm ref, Eterm pid, + Eterm name) +{ + void *tstack[STACK_NEED]; + int tpos = 0; + int dstack[STACK_NEED+1]; + int dpos = 1; + int state = 0; + ErtsMonitor **this = root; + Sint c; + + dstack[0] = DIR_END; + for (;;) { + if (!*this) { /* Found our place */ + state = 1; + *this = create_monitor(type,ref,pid,name); + break; + } else if ((c = CMP_MON_REF(ref,(*this)->ref)) < 0) { + /* go left */ + dstack[dpos++] = DIR_LEFT; + tstack[tpos++] = this; + this = &((*this)->left); + } else if (c > 0) { /* go right */ + dstack[dpos++] = DIR_RIGHT; + tstack[tpos++] = this; + this = &((*this)->right); + } else { /* Equal key is an error for monitors */ + erl_exit(1,"Insertion of already present monitor!"); + break; + } + } + insertion_rotation(dstack, dpos, tstack, tpos, state); +} + + +/* Returns 0 if OK, < 0 if already present */ +int erts_add_link(ErtsLink **root, Uint type, Eterm pid) +{ + void *tstack[STACK_NEED]; + int tpos = 0; + int dstack[STACK_NEED+1]; + int dpos = 1; + int state = 0; + ErtsLink **this = root; + Sint c; + + dstack[0] = DIR_END; + for (;;) { + if (!*this) { /* Found our place */ + state = 1; + *this = create_link(type,pid); + break; + } else if ((c = cmp(pid,(*this)->pid)) < 0) { + /* go left */ + dstack[dpos++] = DIR_LEFT; + tstack[tpos++] = this; + this = &((*this)->left); + } else if (c > 0) { /* go right */ + dstack[dpos++] = DIR_RIGHT; + tstack[tpos++] = this; + this = &((*this)->right); + } else { /* Equal key is an error for monitors */ + return -1; + } + } + insertion_rotation(dstack, dpos, tstack, tpos, state); + return 0; +} + +ErtsSuspendMonitor * +erts_add_or_lookup_suspend_monitor(ErtsSuspendMonitor **root, Eterm pid) +{ + void *tstack[STACK_NEED]; + int tpos = 0; + int dstack[STACK_NEED+1]; + int dpos = 1; + int state = 0; + ErtsSuspendMonitor **this = root; + ErtsSuspendMonitor *res; + Sint c; + + dstack[0] = DIR_END; + for (;;) { + if (!*this) { /* Found our place */ + state = 1; + res = *this = create_suspend_monitor(pid); + break; + } else if ((c = cmp(pid,(*this)->pid)) < 0) { + /* go left */ + dstack[dpos++] = DIR_LEFT; + tstack[tpos++] = this; + this = &((*this)->left); + } else if (c > 0) { /* go right */ + dstack[dpos++] = DIR_RIGHT; + tstack[tpos++] = this; + this = &((*this)->right); + } else { /* Already here... */ + ASSERT((*this)->pid == pid); + return *this; + } + } + insertion_rotation(dstack, dpos, tstack, tpos, state); + return res; +} + + +/* Returns the new or old link structure */ +ErtsLink *erts_add_or_lookup_link(ErtsLink **root, Uint type, Eterm pid) +{ + void *tstack[STACK_NEED]; + int tpos = 0; + int dstack[STACK_NEED+1]; + int dpos = 1; + int state = 0; + ErtsLink **this = root; + Sint c; + ErtsLink *ret = NULL; + + dstack[0] = DIR_END; + for (;;) { + if (!*this) { /* Found our place */ + state = 1; + *this = create_link(type,pid); + ret = *this; + break; + } else if ((c = cmp(pid,(*this)->pid)) < 0) { + /* go left */ + dstack[dpos++] = DIR_LEFT; + tstack[tpos++] = this; + this = &((*this)->left); + } else if (c > 0) { /* go right */ + dstack[dpos++] = DIR_RIGHT; + tstack[tpos++] = this; + this = &((*this)->right); + } else { /* Equal key is an error for monitors */ + return *this; + } + } + insertion_rotation(dstack, dpos, tstack, tpos, state); + return ret; +} + + +/* + * Deletion helpers + */ +static int balance_left(ErtsMonitorOrLink **this) +{ + ErtsMonitorOrLink *p, *p1, *p2; + int b1, b2, h = 1; + + p = *this; + switch (p->balance) { + case -1: + p->balance = 0; + break; + case 0: + p->balance = 1; + h = 0; + break; + case 1: + p1 = p->right; + b1 = p1->balance; + if (b1 >= 0) { /* Single RR rotation */ + p->right = p1->left; + p1->left = p; + if (b1 == 0) { + p->balance = 1; + p1->balance = -1; + h = 0; + } else { + p->balance = p1->balance = 0; + } + (*this) = p1; + } else { /* Double RL rotation */ + p2 = p1->left; + b2 = p2->balance; + p1->left = p2->right; + p2->right = p1; + p->right = p2->left; + p2->left = p; + p->balance = (b2 == 1) ? -1 : 0; + p1->balance = (b2 == -1) ? 1 : 0; + p2->balance = 0; + (*this) = p2; + } + break; + } + return h; +} + +static int balance_right(ErtsMonitorOrLink **this) +{ + ErtsMonitorOrLink *p, *p1, *p2; + int b1, b2, h = 1; + + p = *this; + switch (p->balance) { + case 1: + p->balance = 0; + break; + case 0: + p->balance = -1; + h = 0; + break; + case -1: + p1 = p->left; + b1 = p1->balance; + if (b1 <= 0) { /* Single LL rotation */ + p->left = p1->right; + p1->right = p; + if (b1 == 0) { + p->balance = -1; + p1->balance = 1; + h = 0; + } else { + p->balance = p1->balance = 0; + } + (*this) = p1; + } else { /* Double LR rotation */ + p2 = p1->right; + b2 = p2->balance; + p1->right = p2->left; + p2->left = p1; + p->left = p2->right; + p2->right = p; + p->balance = (b2 == -1) ? 1 : 0; + p1->balance = (b2 == 1) ? -1 : 0; + p2->balance = 0; + (*this) = p2; + } + } + return h; +} + +static int delsub(ErtsMonitorOrLink **this) +{ + ErtsMonitorOrLink **tstack[STACK_NEED]; + int tpos = 0; + ErtsMonitorOrLink *q = (*this); + ErtsMonitorOrLink **r = &(q->left); + int h; + + /* + * Walk down the tree to the right and search + * for a void right child, pick that child out + * and return it to be put in the deleted + * object's place. + */ + + while ((*r)->right != NULL) { + tstack[tpos++] = r; + r = &((*r)->right); + } + *this = *r; + *r = (*r)->left; + (*this)->left = q->left; + (*this)->right = q->right; + (*this)->balance = q->balance; + tstack[0] = &((*this)->left); + h = 1; + while (tpos && h) { + r = tstack[--tpos]; + h = balance_right(r); + } + return h; +} + +ErtsMonitor *erts_remove_monitor(ErtsMonitor **root, Eterm ref) +{ + ErtsMonitor **tstack[STACK_NEED]; + int tpos = 0; + int dstack[STACK_NEED+1]; + int dpos = 1; + int state = 0; + ErtsMonitor **this = root; + Sint c; + int dir; + ErtsMonitor *q = NULL; + + dstack[0] = DIR_END; + for (;;) { + if (!*this) { /* Failure */ + return NULL; + } else if ((c = CMP_MON_REF(ref,(*this)->ref)) < 0) { + dstack[dpos++] = DIR_LEFT; + tstack[tpos++] = this; + this = &((*this)->left); + } else if (c > 0) { /* go right */ + dstack[dpos++] = DIR_RIGHT; + tstack[tpos++] = this; + this = &((*this)->right); + } else { /* Equal key, found the one to delete */ + q = (*this); + if (q->right == NULL) { + (*this) = q->left; + state = 1; + } else if (q->left == NULL) { + (*this) = q->right; + state = 1; + } else { + dstack[dpos++] = DIR_LEFT; + tstack[tpos++] = this; + state = delsub((ErtsMonitorOrLink **) this); + } + break; + } + } + while (state && ( dir = dstack[--dpos] ) != DIR_END) { + this = tstack[--tpos]; + if (dir == DIR_LEFT) { + state = balance_left((ErtsMonitorOrLink **) this); + } else { + state = balance_right((ErtsMonitorOrLink **) this); + } + } + return q; +} + +ErtsLink *erts_remove_link(ErtsLink **root, Eterm pid) +{ + ErtsLink **tstack[STACK_NEED]; + int tpos = 0; + int dstack[STACK_NEED+1]; + int dpos = 1; + int state = 0; + ErtsLink **this = root; + Sint c; + int dir; + ErtsLink *q = NULL; + + dstack[0] = DIR_END; + for (;;) { + if (!*this) { /* Failure */ + return NULL; + } else if ((c = cmp(pid,(*this)->pid)) < 0) { + dstack[dpos++] = DIR_LEFT; + tstack[tpos++] = this; + this = &((*this)->left); + } else if (c > 0) { /* go right */ + dstack[dpos++] = DIR_RIGHT; + tstack[tpos++] = this; + this = &((*this)->right); + } else { /* Equal key, found the one to delete */ + q = (*this); + if (q->right == NULL) { + (*this) = q->left; + state = 1; + } else if (q->left == NULL) { + (*this) = q->right; + state = 1; + } else { + dstack[dpos++] = DIR_LEFT; + tstack[tpos++] = this; + state = delsub((ErtsMonitorOrLink **) this); + } + break; + } + } + while (state && ( dir = dstack[--dpos] ) != DIR_END) { + this = tstack[--tpos]; + if (dir == DIR_LEFT) { + state = balance_left((ErtsMonitorOrLink **) this); + } else { + state = balance_right((ErtsMonitorOrLink **) this); + } + } + return q; +} + +void +erts_delete_suspend_monitor(ErtsSuspendMonitor **root, Eterm pid) +{ + ErtsSuspendMonitor **tstack[STACK_NEED]; + int tpos = 0; + int dstack[STACK_NEED+1]; + int dpos = 1; + int state = 0; + ErtsSuspendMonitor **this = root; + Sint c; + int dir; + ErtsSuspendMonitor *q = NULL; + + dstack[0] = DIR_END; + for (;;) { + if (!*this) { /* Nothing found */ + return; + } else if ((c = cmp(pid,(*this)->pid)) < 0) { + dstack[dpos++] = DIR_LEFT; + tstack[tpos++] = this; + this = &((*this)->left); + } else if (c > 0) { /* go right */ + dstack[dpos++] = DIR_RIGHT; + tstack[tpos++] = this; + this = &((*this)->right); + } else { /* Equal key, found the one to delete */ + q = (*this); + ASSERT(q->pid == pid); + if (q->right == NULL) { + (*this) = q->left; + state = 1; + } else if (q->left == NULL) { + (*this) = q->right; + state = 1; + } else { + dstack[dpos++] = DIR_LEFT; + tstack[tpos++] = this; + state = delsub((ErtsMonitorOrLink **) this); + } + erts_destroy_suspend_monitor(q); + break; + } + } + while (state && ( dir = dstack[--dpos] ) != DIR_END) { + this = tstack[--tpos]; + if (dir == DIR_LEFT) { + state = balance_left((ErtsMonitorOrLink **) this); + } else { + state = balance_right((ErtsMonitorOrLink **) this); + } + } +} + +ErtsMonitor *erts_lookup_monitor(ErtsMonitor *root, Eterm ref) +{ + Sint c; + + for (;;) { + if (root == NULL || (c = CMP_MON_REF(ref,root->ref)) == 0) { + return root; + } else if (c < 0) { + root = root->left; + } else { /* c > 0 */ + root = root->right; + } + } +} + +ErtsLink *erts_lookup_link(ErtsLink *root, Eterm pid) +{ + Sint c; + + for (;;) { + if (root == NULL || (c = cmp(pid,root->pid)) == 0) { + return root; + } else if (c < 0) { + root = root->left; + } else { /* c > 0 */ + root = root->right; + } + } +} + +ErtsSuspendMonitor * +erts_lookup_suspend_monitor(ErtsSuspendMonitor *root, Eterm pid) +{ + Sint c; + + for (;;) { + if (root == NULL || (c = cmp(pid,root->pid)) == 0) { + return root; + } else if (c < 0) { + root = root->left; + } else { /* c > 0 */ + root = root->right; + } + } +} + +void erts_sweep_monitors(ErtsMonitor *root, + void (*doit)(ErtsMonitor *, void *), + void *context) +{ + ErtsMonitor *tstack[STACK_NEED]; + int tpos = 0; + int dstack[STACK_NEED+1]; + int dpos = 1; + int dir; + + dstack[0] = DIR_END; + + for (;;) { + if (root == NULL) { + if ((dir = dstack[dpos-1]) == DIR_END) { + return; + } + if (dir == DIR_LEFT) { + /* Still has DIR_RIGHT to do */ + dstack[dpos-1] = DIR_RIGHT; + root = (tstack[tpos-1])->right; + } else { + /* stacktop is an object to be deleted */ + (*doit)(tstack[--tpos],context); /* expeted to do the + deletion */ + --dpos; + root = NULL; + } + } else { + dstack[dpos++] = DIR_LEFT; + tstack[tpos++] = root; + root = root->left; + } + } +} + +void erts_sweep_links(ErtsLink *root, + void (*doit)(ErtsLink *, void *), + void *context) +{ + ErtsLink *tstack[STACK_NEED]; + int tpos = 0; + int dstack[STACK_NEED+1]; + int dpos = 1; + int dir; + + dstack[0] = DIR_END; + + for (;;) { + if (root == NULL) { + if ((dir = dstack[dpos-1]) == DIR_END) { + return; + } + if (dir == DIR_LEFT) { + /* Still has DIR_RIGHT to do */ + dstack[dpos-1] = DIR_RIGHT; + root = (tstack[tpos-1])->right; + } else { + /* stacktop is an object to be deleted */ + (*doit)(tstack[--tpos],context); /* expeted to do the + deletion */ + --dpos; + root = NULL; + } + } else { + dstack[dpos++] = DIR_LEFT; + tstack[tpos++] = root; + root = root->left; + } + } +} + +void erts_sweep_suspend_monitors(ErtsSuspendMonitor *root, + void (*doit)(ErtsSuspendMonitor *, void *), + void *context) +{ + ErtsSuspendMonitor *tstack[STACK_NEED]; + int tpos = 0; + int dstack[STACK_NEED+1]; + int dpos = 1; + int dir; + + dstack[0] = DIR_END; + + for (;;) { + if (root == NULL) { + if ((dir = dstack[dpos-1]) == DIR_END) { + return; + } + if (dir == DIR_LEFT) { + /* Still has DIR_RIGHT to do */ + dstack[dpos-1] = DIR_RIGHT; + root = (tstack[tpos-1])->right; + } else { + /* stacktop is an object to be deleted */ + (*doit)(tstack[--tpos],context); /* expeted to do the + deletion */ + --dpos; + root = NULL; + } + } else { + dstack[dpos++] = DIR_LEFT; + tstack[tpos++] = root; + root = root->left; + } + } +} + + +/* Debug BIF, always present, but undocumented... */ + +static void erts_dump_monitors(ErtsMonitor *root, int indent) +{ + if (root == NULL) + return; + erts_dump_monitors(root->right,indent+2); + erts_printf("%*s[%b16d:%b16u:%T:%T:%T]\n", indent, "", root->balance, + root->type, root->ref, root->pid, root->name); + erts_dump_monitors(root->left,indent+2); +} + +static void erts_dump_links_aux(ErtsLink *root, int indent, + erts_dsprintf_buf_t *dsbufp) +{ + if (root == NULL) + return; + erts_dump_links_aux(root->right, indent+2, dsbufp); + dsbufp->str_len = 0; + erts_dsprintf(dsbufp, "%*s[%b16d:%b16u:%T:%p]", indent, "", + root->balance, root->type, root->pid, ERTS_LINK_ROOT(root)); + if (ERTS_LINK_ROOT(root) != NULL) { + ErtsLink *sub = ERTS_LINK_ROOT(root); + int len = dsbufp->str_len; + erts_dump_links_aux(sub->right, indent+len+5, dsbufp); + erts_dsprintf(dsbufp, "-> %*s[%b16d:%b16u:%T:%p]", indent, "", + sub->balance, sub->type, sub->pid, ERTS_LINK_ROOT(sub)); + erts_printf("%s\n", dsbufp->str); + erts_dump_links_aux(sub->left, indent+len+5, dsbufp); + } else { + erts_printf("%s\n", dsbufp->str); + } + erts_dump_links_aux(root->left, indent+2, dsbufp); +} + +static void erts_dump_links(ErtsLink *root, int indent) +{ + erts_dsprintf_buf_t *dsbufp = erts_create_tmp_dsbuf(0); + erts_dump_links_aux(root, indent, dsbufp); + erts_destroy_tmp_dsbuf(dsbufp); +} + +Eterm erts_debug_dump_monitors_1(Process *p, Eterm pid) +{ + Process *rp; + DistEntry *dep; + rp = erts_pid2proc(p, ERTS_PROC_LOCK_MAIN, pid, ERTS_PROC_LOCK_LINK); + if (!rp) { + ERTS_SMP_ASSERT_IS_NOT_EXITING(p); + if (is_atom(pid) && is_node_name_atom(pid) && + (dep = erts_find_dist_entry(pid)) != NULL) { + erts_printf("Dumping dist monitors-------------------\n"); + erts_smp_de_links_lock(dep); + erts_dump_monitors(dep->monitors,0); + erts_smp_de_links_unlock(dep); + erts_printf("Monitors dumped-------------------------\n"); + erts_deref_dist_entry(dep); + BIF_RET(am_true); + } else { + BIF_ERROR(p,BADARG); + } + } else { + erts_printf("Dumping pid monitors--------------------\n"); + erts_dump_monitors(rp->monitors,0); + erts_printf("Monitors dumped-------------------------\n"); + erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_LINK); + BIF_RET(am_true); + } +} + +Eterm erts_debug_dump_links_1(Process *p, Eterm pid) +{ + Process *rp; + DistEntry *dep; + if (is_internal_port(pid)) { + Port *rport = erts_id2port(pid, p, ERTS_PROC_LOCK_MAIN); + if (rport) { + erts_printf("Dumping port links----------------------\n"); + erts_dump_links(rport->nlinks,0); + erts_printf("Links dumped----------------------------\n"); + erts_smp_port_unlock(rport); + BIF_RET(am_true); + } else { + BIF_ERROR(p,BADARG); + } + } else { + rp = erts_pid2proc(p, ERTS_PROC_LOCK_MAIN, pid, ERTS_PROC_LOCK_LINK); + if (!rp) { + ERTS_SMP_ASSERT_IS_NOT_EXITING(p); + if (is_atom(pid) && is_node_name_atom(pid) && + (dep = erts_find_dist_entry(pid)) != NULL) { + erts_printf("Dumping dist links----------------------\n"); + erts_smp_de_links_lock(dep); + erts_dump_links(dep->nlinks,0); + erts_smp_de_links_unlock(dep); + erts_printf("Links dumped----------------------------\n"); + erts_deref_dist_entry(dep); + BIF_RET(am_true); + } else { + BIF_ERROR(p,BADARG); + } + + } else { + erts_printf("Dumping pid links-----------------------\n"); + erts_dump_links(rp->nlinks,0); + erts_printf("Links dumped----------------------------\n"); + erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_LINK); + BIF_RET(am_true); + } + } +} diff --git a/erts/emulator/beam/erl_monitors.h b/erts/emulator/beam/erl_monitors.h new file mode 100644 index 0000000000..d3f6d410dd --- /dev/null +++ b/erts/emulator/beam/erl_monitors.h @@ -0,0 +1,180 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2004-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/********************************************************************** + * Header for monitors and links data structures. + * Monitors are kept in an AVL tree and the data structures for + * the four different types of monitors are like this: + ********************************************************************** + * Local monitor by pid/port: + * (Ref is always same in all involved data structures) + ********************************************************************** + * Process/Port X Process Y + * +-------------+ +-------------+ + * Type: | MON_ORIGIN | | MON_TARGET | + * +-------------+ +-------------+ + * Pid: | Pid(Y) | | Pid/Port(X) | + * +-------------+ +-------------+ + * Name: | [] | | [] | + * +-------------+ +-------------+ + ********************************************************************** + * Local monitor by name: (Ref is always same in all involved data structures) + ********************************************************************** + * Process X Process Y (name foo) + * +-------------+ +-------------+ + * Type: | MON_ORIGIN | | MON_TARGET | + * +-------------+ +-------------+ + * Pid: | Pid(Y) | | Pid(X) | + * +-------------+ +-------------+ + * Name: | Atom(foo) | | Atom(foo) | + * +-------------+ +-------------+ + ********************************************************************** + * Remote monitor by pid: (Ref is always same in all involved data structures) + ********************************************************************** + * Node A | Node B + * ---------------------------------+---------------------------------- + * Process X (@A) Distentry @A Distentry @B Process Y (@B) + * for node B for node A + * +-------------+ +-------------+ +-------------+ +-------------+ + * Type: | MON_ORIGIN | | MON_TARGET | | MON_ORIGIN | | MON_TARGET | + * +-------------+ +-------------+ +-------------+ +-------------+ + * Pid: | Pid(Y) | | Pid(X) | | Pid(Y) | | Pid(X) | + * +-------------+ +-------------+ +-------------+ +-------------+ + * Name: | [] | | [] | | [] | | [] | + * +-------------+ +-------------+ +-------------+ +-------------+ + ********************************************************************** + * Remote monitor by name: (Ref is always same in all involved data structures) + ********************************************************************** + * Node A | Node B + * ---------------------------------+---------------------------------- + * Process X (@A) Distentry @A Distentry @B Process Y (@B) + * for node B for node A (name foo) + * +-------------+ +-------------+ +-------------+ +-------------+ + * Type: | MON_ORIGIN | | MON_TARGET | | MON_ORIGIN | | MON_TARGET | + * +-------------+ +-------------+ +-------------+ +-------------+ + * Pid: | Atom(node B)| | Pid(X) | | Pid(Y) | | Pid(X) | + * +-------------+ +-------------+ +-------------+ +-------------+ + * Name: | Atom(foo) | | Atom(foo) | | Atom(foo) | | Atom(foo) | + * +-------------+ +-------------+ +-------------+ +-------------+ + * The reason for the node atom in X->pid is that we don't know the actual + * pid of the monitored process on the other node when setting the monitor + * (which is done asyncronously). + **********************************************************************/ +#ifndef _ERL_MONITORS_H +#define _ERL_MONITORS_H + +/* Type tags for monitors */ +#define MON_ORIGIN 1 +#define MON_TARGET 3 + +/* Type tags for links */ +#define LINK_PID 1 /* ...Or port */ +#define LINK_NODE 3 /* "Node monitor" */ + +/* Size of a monitor without heap, in words (fixalloc) */ +#define ERTS_MONITOR_SIZE ((sizeof(ErtsMonitor) - sizeof(Uint))/sizeof(Uint)) +#define ERTS_MONITOR_SH_SIZE (ERTS_MONITOR_SIZE + REF_THING_SIZE) +#define ERTS_LINK_SIZE ((sizeof(ErtsLink) - sizeof(Uint))/sizeof(Uint)) +#define ERTS_LINK_SH_SIZE ERTS_LINK_SIZE /* Size of fix-alloced links */ + +/* ErtsMonitor and ErtsLink *need* to begin in a similar way as + ErtsMonitorOrLink */ +typedef struct erts_monitor_or_link { + struct erts_monitor_or_link *left, *right; + Sint16 balance; +} ErtsMonitorOrLink; + +typedef struct erts_monitor { + struct erts_monitor *left, *right; + Sint16 balance; + Uint16 type; /* MON_ORIGIN | MON_TARGET */ + Eterm ref; + Eterm pid; /* In case of distributed named monitor, this is the + nodename atom in MON_ORIGIN process, otherwise a pid or + , in case of a MON_TARGET, a port */ + Eterm name; /* When monitoring a named process: atom() else [] */ + Uint heap[1]; /* Larger in reality */ +} ErtsMonitor; + +typedef struct erts_link { + struct erts_link *left, *right; + Sint16 balance; + Uint16 type; /* LINK_PID | LINK_NODE */ + Eterm pid; /* When node monitor, + the node atom is here instead */ + union { + struct erts_link *root; /* Used only in dist entries */ + Uint refc; + } shared; + Uint heap[1]; /* Larger in reality */ +} ErtsLink; + +typedef struct erts_suspend_monitor { + struct erts_suspend_monitor *left, *right; + Sint16 balance; + + int pending; + int active; + Eterm pid; +} ErtsSuspendMonitor; + +#define ERTS_LINK_ROOT(Linkp) ((Linkp)->shared.root) +#define ERTS_LINK_REFC(Linkp) ((Linkp)->shared.refc) + +#define ERTS_LINK_ROOT_AS_UINT(Linkp) (*((Uint *) &((Linkp)->root))) + +Uint erts_tot_link_lh_size(void); + + +/* Prototypes */ +void erts_destroy_monitor(ErtsMonitor *mon); +void erts_add_monitor(ErtsMonitor **root, Uint type, Eterm ref, Eterm pid, + Eterm name); +ErtsMonitor *erts_remove_monitor(ErtsMonitor **root, Eterm ref); +ErtsMonitor *erts_lookup_monitor(ErtsMonitor *root, Eterm ref); +void erts_sweep_monitors(ErtsMonitor *root, + void (*doit)(ErtsMonitor *, void *), + void *context); + +void erts_destroy_link(ErtsLink *lnk); +/* Returns 0 if OK, < 0 if already present */ +int erts_add_link(ErtsLink **root, Uint type, Eterm pid); +ErtsLink *erts_add_or_lookup_link(ErtsLink **root, Uint type, Eterm pid); +ErtsLink *erts_remove_link(ErtsLink **root, Eterm pid); +ErtsLink *erts_lookup_link(ErtsLink *root, Eterm pid); +void erts_sweep_links(ErtsLink *root, + void (*doit)(ErtsLink *, void *), + void *context); + +void erts_destroy_suspend_monitor(ErtsSuspendMonitor *sproc); +void erts_sweep_suspend_monitors(ErtsSuspendMonitor *root, + void (*doit)(ErtsSuspendMonitor *, void *), + void *context); +ErtsSuspendMonitor *erts_add_or_lookup_suspend_monitor(ErtsSuspendMonitor **root, + Eterm pid); +ErtsSuspendMonitor *erts_lookup_suspend_monitor(ErtsSuspendMonitor *root, + Eterm pid); +void erts_delete_suspend_monitor(ErtsSuspendMonitor **root, Eterm pid); +void erts_init_monitors(void); + +#define erts_doforall_monitors erts_sweep_monitors +#define erts_doforall_links erts_sweep_links +#define erts_doforall_suspend_monitors erts_sweep_suspend_monitors + +#endif /* _ERL_MONITORS_H */ diff --git a/erts/emulator/beam/erl_mtrace.c b/erts/emulator/beam/erl_mtrace.c new file mode 100644 index 0000000000..8b8ac2ec80 --- /dev/null +++ b/erts/emulator/beam/erl_mtrace.c @@ -0,0 +1,1240 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2003-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* + * Description: Memory allocation trace. The trace is sent over a + * tcp/ip connection. + * + * The trace format is not intended to be documented. + * Instead a library for parsing the trace will be + * distributed. This in order to more easily be able + * to make changes in the trace format. The library + * for parsing the trace is currently not included in + * the OTP distribution, but will be in the future. + * + * Author: Rickard Green + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "global.h" +#include "erl_sock.h" +#include "erl_threads.h" +#include "erl_memory_trace_protocol.h" +#include "erl_mtrace.h" + +#if defined(MAXHOSTNAMELEN) && MAXHOSTNAMELEN > 255 +# undef MAXHOSTNAMELEN +#endif + +#ifndef MAXHOSTNAMELEN +# define MAXHOSTNAMELEN 255 +#endif + +#define TRACE_PRINTOUTS 0 +#ifdef TRACE_PRINTOUTS +#define MSB2BITS(X) ((((unsigned)(X))+1)*8) +#endif + +static erts_mtx_t mtrace_op_mutex; +static erts_mtx_t mtrace_buf_mutex; + +#define TRACE_BUF_SZ (16*1024) + + +#define UI8_MSB_EHF_SZ ERTS_MT_UI8_MSB_EHDR_FLD_SZ +#define UI16_MSB_EHF_SZ ERTS_MT_UI16_MSB_EHDR_FLD_SZ +#define UI32_MSB_EHF_SZ ERTS_MT_UI32_MSB_EHDR_FLD_SZ +#define UI64_MSB_EHF_SZ ERTS_MT_UI64_MSB_EHDR_FLD_SZ +#define UI_MSB_EHF_SZ ERTS_MT_UI64_MSB_EHDR_FLD_SZ +#define TAG_EHF_SZ ERTS_MT_TAG_EHDR_FLD_SZ + +#define UI8_MSB_EHF_MSK ERTS_MT_UI8_MSB_EHDR_FLD_MSK +#define UI16_MSB_EHF_MSK ERTS_MT_UI16_MSB_EHDR_FLD_MSK +#define UI32_MSB_EHF_MSK ERTS_MT_UI32_MSB_EHDR_FLD_MSK +#define UI_MSB_EHF_MSK ERTS_MT_UI64_MSB_EHDR_FLD_MSK +#define UI64_MSB_EHF_MSK ERTS_MT_UI64_MSB_EHDR_FLD_MSK +#define TAG_EHF_MSK ERTS_MT_TAG_EHDR_FLD_MSK + +#define UI8_SZ (1) +#define UI16_SZ (2) +#define UI32_SZ (4) +#define UI64_SZ (8) +#ifdef ARCH_64 +# define UI_SZ UI64_SZ +#else +# define UI_SZ UI32_SZ +#endif + +#define WRITE_UI8(P, V) (*(P) = (byte) ((V) & 0xff)) + +#define WRITE_UI16(P, V) \ + ((P)[0] = (byte) (((V) >> 8) & 0xff), \ + (P)[1] = (byte) ( (V) & 0xff)) + +#define WRITE_UI32(P, V) \ + ((P)[0] = (byte) (((V) >> 24) & 0xff), \ + (P)[1] = (byte) (((V) >> 16) & 0xff), \ + (P)[2] = (byte) (((V) >> 8) & 0xff), \ + (P)[3] = (byte) ( (V) & 0xff)) + +#define WRITE_UI64(P, V) \ + ((P)[0] = (byte) (((V) >> 56) & 0xff), \ + (P)[1] = (byte) (((V) >> 48) & 0xff), \ + (P)[2] = (byte) (((V) >> 40) & 0xff), \ + (P)[3] = (byte) (((V) >> 32) & 0xff), \ + (P)[4] = (byte) (((V) >> 24) & 0xff), \ + (P)[5] = (byte) (((V) >> 16) & 0xff), \ + (P)[6] = (byte) (((V) >> 8) & 0xff), \ + (P)[7] = (byte) ( (V) & 0xff)) + +#define PUT_UI8(P, V) (WRITE_UI8((P), (V)), (P) += UI8_SZ) +#define PUT_UI16(P, V) (WRITE_UI16((P), (V)), (P) += UI16_SZ) +#define PUT_UI32(P, V) (WRITE_UI32((P), (V)), (P) += UI32_SZ) +#define PUT_UI64(P, V) (WRITE_UI64((P), (V)), (P) += UI64_SZ) + +#define PUT_VSZ_UI16(P, M, V) \ +do { \ + Uint16 v__ = (Uint16) (V); \ + if (v__ >= (((Uint16) 1) << 8)) (M) = 1; else (M) = 0; \ + switch ((M)) { \ + case 1: *((P)++) = (byte) ((v__ >> 8) & 0xff); \ + case 0: *((P)++) = (byte) ( v__ & 0xff); \ + } \ +} while (0) + +#define PUT_VSZ_UI32(P, M, V) \ +do { \ + Uint32 v__ = (Uint32) (V); \ + if (v__ >= (((Uint32) 1) << 16)) { \ + if (v__ >= (((Uint32) 1) << 24)) (M) = 3; else (M) = 2; \ + } else { \ + if (v__ >= (((Uint32) 1) << 8)) (M) = 1; else (M) = 0; \ + } \ + switch ((M)) { \ + case 3: *((P)++) = (byte) ((v__ >> 24) & 0xff); \ + case 2: *((P)++) = (byte) ((v__ >> 16) & 0xff); \ + case 1: *((P)++) = (byte) ((v__ >> 8) & 0xff); \ + case 0: *((P)++) = (byte) ( v__ & 0xff); \ + } \ +} while (0) + +#ifdef ARCH_64 + +#define PUT_VSZ_UI64(P, M, V) \ +do { \ + Uint64 v__ = (Uint64) (V); \ + if (v__ >= (((Uint64) 1) << 32)) { \ + if (v__ >= (((Uint64) 1) << 48)) { \ + if (v__ >= (((Uint64) 1) << 56)) (M) = 7; else (M) = 6; \ + } else { \ + if (v__ >= (((Uint64) 1) << 40)) (M) = 5; else (M) = 4; \ + } \ + } else { \ + if (v__ >= (((Uint64) 1) << 16)) { \ + if (v__ >= (((Uint64) 1) << 24)) (M) = 3; else (M) = 2; \ + } else { \ + if (v__ >= (((Uint64) 1) << 8)) (M) = 1; else (M) = 0; \ + } \ + } \ + switch ((M)) { \ + case 7: *((P)++) = (byte) ((v__ >> 56) & 0xff); \ + case 6: *((P)++) = (byte) ((v__ >> 48) & 0xff); \ + case 5: *((P)++) = (byte) ((v__ >> 40) & 0xff); \ + case 4: *((P)++) = (byte) ((v__ >> 32) & 0xff); \ + case 3: *((P)++) = (byte) ((v__ >> 24) & 0xff); \ + case 2: *((P)++) = (byte) ((v__ >> 16) & 0xff); \ + case 1: *((P)++) = (byte) ((v__ >> 8) & 0xff); \ + case 0: *((P)++) = (byte) ( v__ & 0xff); \ + } \ +} while (0) + +#define PUT_VSZ_UI PUT_VSZ_UI64 +#else /* #ifdef ARCH_64 */ +#define PUT_VSZ_UI PUT_VSZ_UI32 +#endif /* #ifdef ARCH_64 */ + +#define MAKE_TBUF_SZ(SZ) \ + (TRACE_BUF_SZ < (SZ) \ + ? (disable_trace(1, "Internal buffer overflow", 0), 0) \ + : (endp - tracep < (SZ) ? send_trace_buffer() : 1)) + + +static void disable_trace(int error, char *reason, int eno); +static int send_trace_buffer(void); + +#ifdef DEBUG +void +check_alloc_entry(byte *sp, byte *ep, + byte tag, + Uint16 ct_no, int ct_no_n, + Uint16 type, int type_n, + Uint res, int res_n, + Uint size, int size_n, + Uint32 ti,int ti_n); +void +check_realloc_entry(byte *sp, byte *ep, + byte tag, + Uint16 ct_no, int ct_no_n, + Uint16 type, int type_n, + Uint res, int res_n, + Uint ptr, int ptr_n, + Uint size, int size_n, + Uint32 ti,int ti_n); +void +check_free_entry(byte *sp, byte *ep, + byte tag, + Uint16 ct_no, int ct_no_n, + Uint16 t_no, int t_no_n, + Uint ptr, int ptr_n, + Uint32 ti,int ti_n); +void +check_time_inc_entry(byte *sp, byte *ep, + Uint32 secs, int secs_n, + Uint32 usecs, int usecs_n); +#endif + + + +int erts_mtrace_enabled; +static erts_sock_t socket_desc; +static byte trace_buffer[TRACE_BUF_SZ]; +static byte *tracep; +static byte *endp; +static SysTimeval last_tv; + +#if ERTS_MTRACE_SEGMENT_ID >= ERTS_ALC_A_MIN || ERTS_MTRACE_SEGMENT_ID < 0 +#error ERTS_MTRACE_SEGMENT_ID >= ERTS_ALC_A_MIN || ERTS_MTRACE_SEGMENT_ID < 0 +#endif + +char* erl_errno_id(int error); + +#define INVALID_TIME_INC (0xffffffff) + +static ERTS_INLINE Uint32 +get_time_inc(void) +{ + Sint32 secs; + Sint32 usecs; + Uint32 res; + SysTimeval tv; + sys_gettimeofday(&tv); + + secs = tv.tv_sec - last_tv.tv_sec; + if (tv.tv_usec >= last_tv.tv_usec) + usecs = tv.tv_usec - last_tv.tv_usec; + else { + secs--; + usecs = 1000000 + tv.tv_usec - last_tv.tv_usec; + } + + ASSERT(0 <= usecs); + ASSERT(usecs < 1000000); + + if (secs < 0) { + /* Clock stepped backwards; we pretend that no time has past. */ + res = 0; + } + else if (secs < ERTS_MT_TIME_INC_SECS_MASK) { + res = ((((Uint32) secs) << ERTS_MT_TIME_INC_SECS_SHIFT) + | (((Uint32) usecs) << ERTS_MT_TIME_INC_USECS_SHIFT)); + } + else { + /* Increment too large to fit in a 32-bit integer; + put a time inc entry in trace ... */ + if (MAKE_TBUF_SZ(UI8_SZ + UI16_SZ + 2*UI32_SZ)) { + byte *hdrp; + Uint16 hdr; + int secs_n, usecs_n; + + *(tracep++) = ERTS_MT_TIME_INC_BDY_TAG; + + hdrp = tracep; + tracep += 2; + + PUT_VSZ_UI32(tracep, secs_n, secs); + PUT_VSZ_UI32(tracep, usecs_n, usecs); + + hdr = usecs_n; + + hdr <<= UI32_MSB_EHF_SZ; + hdr |= secs_n; + + WRITE_UI16(hdrp, hdr); +#ifdef DEBUG + check_time_inc_entry(hdrp-1, tracep, + (Uint32) secs, secs_n, + (Uint32) usecs, usecs_n); +#endif + res = 0; + } + else { + res = INVALID_TIME_INC; + } + } + + last_tv = tv; + return res; +} + + +static void +disable_trace(int error, char *reason, int eno) +{ + char *mt_dis = "Memory trace disabled"; + char *eno_str; + + erts_mtrace_enabled = 0; + erts_sock_close(socket_desc); + socket_desc = ERTS_SOCK_INVALID_SOCKET; + + if (eno == 0) + erts_fprintf(stderr, "%s: %s\n", mt_dis, reason); + else { + eno_str = erl_errno_id(eno); + if (strcmp(eno_str, "unknown") == 0) + erts_fprintf(stderr, "%s: %s: %d\n", mt_dis, reason, eno); + else + erts_fprintf(stderr, "%s: %s: %s\n", mt_dis, reason, eno_str); + } +} + +static int +send_trace_buffer(void) +{ + ssize_t ssz; + size_t sz; + + sz = tracep - trace_buffer; + tracep = trace_buffer; + + do { + ssz = erts_sock_send(socket_desc, (void *) tracep, sz); + if (ssz < 0) { + int socket_errno = erts_sock_errno(); + +#ifdef EINTR + if (socket_errno == EINTR) + continue; +#endif + disable_trace(0, "Connection lost", socket_errno); + return 0; + } + if (ssz > sz) { + disable_trace(1, "Unexpected error", 0); + return 0; + } + tracep += ssz; + sz -= ssz; + } while (sz); + + tracep = trace_buffer; + return 1; +} + +#if ERTS_ALC_N_MAX >= (1 << 16) +#error "Excessively large type numbers" +#endif + + +static int +write_trace_header(char *nodename, char *pid, char *hostname) +{ +#ifdef DEBUG + byte *startp; +#endif + Uint16 entry_sz; + Uint32 flags, n_len, h_len, p_len, hdr_prolog_len; + int i, no, str_len; + const char *str; + struct { + Uint32 gsec; + Uint32 sec; + Uint32 usec; + } start_time; + + sys_gettimeofday(&last_tv); + + start_time.gsec = (Uint32) (last_tv.tv_sec / 1000000000); + start_time.sec = (Uint32) (last_tv.tv_sec % 1000000000); + start_time.usec = (Uint32) last_tv.tv_usec; + + if (!MAKE_TBUF_SZ(3*UI32_SZ)) + return 0; + + flags = 0; +#ifdef ARCH_64 + flags |= ERTS_MT_64_BIT_FLAG; +#endif + flags |= ERTS_MT_CRR_INFO; +#ifdef ERTS_CAN_TRACK_MALLOC + flags |= ERTS_MT_SEG_CRR_INFO; +#endif + + /* + * The following 3 ui32 words *always* have to come + * first in the trace. + */ + PUT_UI32(tracep, ERTS_MT_START_WORD); + PUT_UI32(tracep, ERTS_MT_MAJOR_VSN); + PUT_UI32(tracep, ERTS_MT_MINOR_VSN); + + n_len = strlen(nodename); + h_len = strlen(hostname); + p_len = strlen(pid); + hdr_prolog_len = (2*UI32_SZ + + 3*UI16_SZ + + 3*UI32_SZ + + 3*UI8_SZ + + n_len + + h_len + + p_len); + + if (!MAKE_TBUF_SZ(hdr_prolog_len)) + return 0; + + /* + * New stuff can be added at the end the of header prolog + * (EOHP). The reader should skip stuff at the end, that it + * doesn't understand. + */ + +#ifdef DEBUG + startp = tracep; +#endif + + PUT_UI32(tracep, hdr_prolog_len); + PUT_UI32(tracep, flags); + PUT_UI16(tracep, ERTS_MTRACE_SEGMENT_ID); + PUT_UI16(tracep, ERTS_ALC_A_MAX); + PUT_UI16(tracep, ERTS_ALC_N_MAX); + + PUT_UI32(tracep, start_time.gsec); + PUT_UI32(tracep, start_time.sec); + PUT_UI32(tracep, start_time.usec); + + PUT_UI8(tracep, (byte) n_len); + memcpy((void *) tracep, (void *) nodename, n_len); + tracep += n_len; + + PUT_UI8(tracep, (byte) h_len); + memcpy((void *) tracep, (void *) hostname, h_len); + tracep += h_len; + + PUT_UI8(tracep, (byte) p_len); + memcpy((void *) tracep, (void *) pid, p_len); + tracep += p_len; + + ASSERT(startp + hdr_prolog_len == tracep); + + /* + * EOHP + */ + + /* + * All tags from here on should be followed by an Uint16 size + * field containing the total size of the entry. + * + * New stuff can eigther be added at the end of an entry, or + * as a new tagged entry. The reader should skip stuff at the + * end, that it doesn't understand. + */ + + for (i = ERTS_ALC_A_MIN; i <= ERTS_ALC_A_MAX; i++) { + Uint16 aflags = 0; + +#ifndef ERTS_CAN_TRACK_MALLOC + if (i != ERTS_ALC_A_SYSTEM) +#endif + aflags |= ERTS_MT_ALLCTR_USD_CRR_INFO; + + str = ERTS_ALC_A2AD(i); + ASSERT(str); + str_len = strlen(str); + if (str_len >= (1 << 8)) { + disable_trace(1, "Excessively large allocator string", 0); + return 0; + } + + entry_sz = UI8_SZ + 3*UI16_SZ + UI8_SZ; + entry_sz += (erts_allctrs_info[i].alloc_util ? 2 : 1)*UI16_SZ; + entry_sz += UI8_SZ + str_len; + + if (!MAKE_TBUF_SZ(entry_sz)) + return 0; + +#ifdef DEBUG + startp = tracep; +#endif + PUT_UI8(tracep, ERTS_MT_ALLOCATOR_HDR_TAG); + PUT_UI16(tracep, entry_sz); + PUT_UI16(tracep, aflags); + PUT_UI16(tracep, (Uint16) i); + PUT_UI8( tracep, (byte) str_len); + memcpy((void *) tracep, (void *) str, str_len); + tracep += str_len; + if (erts_allctrs_info[i].alloc_util) { + PUT_UI8(tracep, 2); + PUT_UI16(tracep, ERTS_MTRACE_SEGMENT_ID); + PUT_UI16(tracep, ERTS_ALC_A_SYSTEM); + } + else { + PUT_UI8(tracep, 1); + switch (i) { + case ERTS_ALC_A_SYSTEM: + PUT_UI16(tracep, ERTS_MTRACE_SEGMENT_ID); + break; + case ERTS_ALC_A_FIXED_SIZE: + if (erts_allctrs_info[ERTS_FIX_CORE_ALLOCATOR].enabled) + PUT_UI16(tracep, ERTS_FIX_CORE_ALLOCATOR); + else + PUT_UI16(tracep, ERTS_ALC_A_SYSTEM); + break; + default: + PUT_UI16(tracep, ERTS_MTRACE_SEGMENT_ID); + break; + } + } + ASSERT(startp + entry_sz == tracep); + } + + for (i = ERTS_ALC_N_MIN; i <= ERTS_ALC_N_MAX; i++) { + Uint16 nflags = 0; + str = ERTS_ALC_N2TD(i); + ASSERT(str); + + str_len = strlen(str); + if (str_len >= (1 << 8)) { + disable_trace(1, "Excessively large type string", 0); + return 0; + } + + no = ERTS_ALC_T2A(ERTS_ALC_N2T(i)); + if (!erts_allctrs_info[no].enabled) + no = ERTS_ALC_A_SYSTEM; + ASSERT(ERTS_ALC_A_MIN <= no && no <= ERTS_ALC_A_MAX); + + entry_sz = UI8_SZ + 3*UI16_SZ + UI8_SZ + str_len + UI16_SZ; + + if (!MAKE_TBUF_SZ(entry_sz)) + return 0; + +#ifdef DEBUG + startp = tracep; +#endif + PUT_UI8(tracep, ERTS_MT_BLOCK_TYPE_HDR_TAG); + PUT_UI16(tracep, entry_sz); + PUT_UI16(tracep, nflags); + PUT_UI16(tracep, (Uint16) i); + PUT_UI8(tracep, (byte) str_len); + memcpy((void *) tracep, (void *) str, str_len); + tracep += str_len; + PUT_UI16(tracep, no); + ASSERT(startp + entry_sz == tracep); + } + + entry_sz = UI8_SZ + UI16_SZ; + if (!MAKE_TBUF_SZ(entry_sz)) + return 0; + PUT_UI8(tracep, ERTS_MT_END_OF_HDR_TAG); + PUT_UI16(tracep, entry_sz); + + return 1; +} + +static void *mtrace_alloc(ErtsAlcType_t, void *, Uint); +static void *mtrace_realloc(ErtsAlcType_t, void *, void *, Uint); +static void mtrace_free(ErtsAlcType_t, void *, void *); + +static ErtsAllocatorFunctions_t real_allctrs[ERTS_ALC_A_MAX+1]; + +void erts_mtrace_pre_init(void) +{ +} + +void erts_mtrace_init(char *receiver, char *nodename) +{ + char hostname[MAXHOSTNAMELEN]; + char pid[21]; /* enough for a 64 bit number */ + + socket_desc = ERTS_SOCK_INVALID_SOCKET; + erts_mtrace_enabled = receiver != NULL; + + if (erts_mtrace_enabled) { + unsigned a, b, c, d, p; + byte ip_addr[4]; + Uint16 port; + + erts_mtx_init(&mtrace_buf_mutex, "mtrace_buf"); + erts_mtx_set_forksafe(&mtrace_buf_mutex); + erts_mtx_init(&mtrace_op_mutex, "mtrace_op"); + erts_mtx_set_forksafe(&mtrace_op_mutex); + + socket_desc = erts_sock_open(); + if (socket_desc == ERTS_SOCK_INVALID_SOCKET) { + disable_trace(1, "Failed to open socket", erts_sock_errno()); + return; + } + + if (5 != sscanf(receiver, "%u.%u.%u.%u:%u", &a, &b, &c, &d, &p) + || a >= (1 << 8) || b >= (1 << 8)|| c >= (1 << 8) || d >= (1 << 8) + || p >= (1 << 16)) { + disable_trace(1, "Invalid receiver address", 0); + return; + } + + ip_addr[0] = (byte) a; + ip_addr[1] = (byte) b; + ip_addr[2] = (byte) c; + ip_addr[3] = (byte) d; + + port = (Uint16) p; + + if (!erts_sock_connect(socket_desc, ip_addr, 4, port)) { + disable_trace(1, "Failed to connect to receiver", + erts_sock_errno()); + return; + } + tracep = trace_buffer; + endp = trace_buffer + TRACE_BUF_SZ; + if (erts_sock_gethostname(hostname, MAXHOSTNAMELEN) != 0) + hostname[0] = '\0'; + hostname[MAXHOSTNAMELEN-1] = '\0'; + sys_get_pid(pid); + write_trace_header(nodename ? nodename : "", pid, hostname); + erts_mtrace_update_heap_size(); + } +} + +void +erts_mtrace_install_wrapper_functions(void) +{ + if (erts_mtrace_enabled) { + int i; + /* Install trace functions */ + ASSERT(sizeof(erts_allctrs) == sizeof(real_allctrs)); + + sys_memcpy((void *) real_allctrs, + (void *) erts_allctrs, + sizeof(erts_allctrs)); + + for (i = ERTS_ALC_A_MIN; i <= ERTS_ALC_A_MAX; i++) { + erts_allctrs[i].alloc = mtrace_alloc; + erts_allctrs[i].realloc = mtrace_realloc; + erts_allctrs[i].free = mtrace_free; + erts_allctrs[i].extra = (void *) &real_allctrs[i]; + } + } +} + +void +erts_mtrace_stop(void) +{ + erts_mtx_lock(&mtrace_op_mutex); + erts_mtx_lock(&mtrace_buf_mutex); + if (erts_mtrace_enabled) { + Uint32 ti = get_time_inc(); + + if (ti != INVALID_TIME_INC + && MAKE_TBUF_SZ(UI8_SZ + UI16_SZ + UI32_SZ)) { + byte *hdrp; + Uint16 hdr; + int ti_n; + + *(tracep++) = ERTS_MT_STOP_BDY_TAG; + + hdrp = tracep; + tracep += 2; + + PUT_VSZ_UI32(tracep, ti_n, ti); + + hdr = ti_n; + + WRITE_UI16(hdrp, hdr); + + if(send_trace_buffer()) { + erts_mtrace_enabled = 0; + erts_sock_close(socket_desc); + socket_desc = ERTS_SOCK_INVALID_SOCKET; + } + } + } + erts_mtx_unlock(&mtrace_buf_mutex); + erts_mtx_unlock(&mtrace_op_mutex); +} + +void +erts_mtrace_exit(Uint32 exit_value) +{ + erts_mtx_lock(&mtrace_op_mutex); + erts_mtx_lock(&mtrace_buf_mutex); + if (erts_mtrace_enabled) { + Uint32 ti = get_time_inc(); + + if (ti != INVALID_TIME_INC + && MAKE_TBUF_SZ(UI8_SZ + UI16_SZ + 2*UI32_SZ)) { + byte *hdrp; + Uint16 hdr; + int ti_n, exit_value_n; + + *(tracep++) = ERTS_MT_EXIT_BDY_TAG; + + hdrp = tracep; + tracep += 2; + + PUT_VSZ_UI32(tracep, exit_value_n, exit_value); + PUT_VSZ_UI32(tracep, ti_n, ti); + + hdr = ti_n; + + hdr <<= UI32_MSB_EHF_SZ; + hdr |= exit_value_n; + + WRITE_UI16(hdrp, hdr); + + if(send_trace_buffer()) { + erts_mtrace_enabled = 0; + erts_sock_close(socket_desc); + socket_desc = ERTS_SOCK_INVALID_SOCKET; + } + } + } + erts_mtx_unlock(&mtrace_buf_mutex); + erts_mtx_unlock(&mtrace_op_mutex); +} + +static ERTS_INLINE void +write_alloc_entry(byte tag, + void *res, + ErtsAlcType_t x, + ErtsAlcType_t y, + Uint size) +{ + erts_mtx_lock(&mtrace_buf_mutex); + if (erts_mtrace_enabled) { + Uint32 ti = get_time_inc(); + + if (ti != INVALID_TIME_INC + && MAKE_TBUF_SZ(UI8_SZ + 2*UI16_SZ + 2*UI_SZ + UI32_SZ)) { + Uint16 hdr, t_no = (Uint16) x, ct_no = (Uint16) y; + byte *hdrp; + int t_no_n, ct_no_n = 0, res_n, size_n, ti_n; + + *(tracep++) = tag; + + hdrp = tracep; + tracep += 2; + + if (tag == ERTS_MT_CRR_ALLOC_BDY_TAG) { + PUT_VSZ_UI16(tracep, ct_no_n, ct_no); + } + PUT_VSZ_UI16(tracep, t_no_n, t_no); + PUT_VSZ_UI( tracep, res_n, res); + PUT_VSZ_UI( tracep, size_n, size); + PUT_VSZ_UI32(tracep, ti_n, ti); + + hdr = ti_n; + + hdr <<= UI_MSB_EHF_SZ; + hdr |= size_n; + + hdr <<= UI_MSB_EHF_SZ; + hdr |= res_n; + + hdr <<= UI16_MSB_EHF_SZ; + hdr |= t_no_n; + + if (tag == ERTS_MT_CRR_ALLOC_BDY_TAG) { + hdr <<= UI16_MSB_EHF_SZ; + hdr |= ct_no_n; + } + + WRITE_UI16(hdrp, hdr); + +#if TRACE_PRINTOUTS + print_trace_entry(tag, + ct_no, ct_no_n, + t_no, t_no_n, + (Uint) res, res_n, + 0, 0, + size, size_n, + ti, ti_n); +#endif + +#ifdef DEBUG + check_alloc_entry(hdrp-1, tracep, + tag, + ct_no, ct_no_n, + t_no, t_no_n, + (Uint) res, res_n, + size, size_n, + ti, ti_n); +#endif + + } + + } + erts_mtx_unlock(&mtrace_buf_mutex); + +} + +static ERTS_INLINE void +write_realloc_entry(byte tag, + void *res, + ErtsAlcType_t x, + ErtsAlcType_t y, + void *ptr, + Uint size) +{ + erts_mtx_lock(&mtrace_buf_mutex); + if (erts_mtrace_enabled) { + Uint32 ti = get_time_inc(); + + if (ti != INVALID_TIME_INC + && MAKE_TBUF_SZ(UI8_SZ + 2*UI16_SZ + 3*UI_SZ + UI32_SZ)) { + Uint16 hdr, t_no = (Uint16) x, ct_no = (Uint16) y; + byte *hdrp; + int t_no_n, ct_no_n = 0, res_n, ptr_n, size_n, ti_n; + + *(tracep++) = tag; + + hdrp = tracep; + tracep += 2; + + if (tag == ERTS_MT_CRR_REALLOC_BDY_TAG) { + PUT_VSZ_UI16(tracep, ct_no_n, ct_no); + } + PUT_VSZ_UI16(tracep, t_no_n, t_no); + PUT_VSZ_UI( tracep, res_n, res); + PUT_VSZ_UI( tracep, ptr_n, ptr); + PUT_VSZ_UI( tracep, size_n, size); + PUT_VSZ_UI32(tracep, ti_n, ti); + + hdr = ti_n; + + hdr <<= UI_MSB_EHF_SZ; + hdr |= size_n; + + hdr <<= UI_MSB_EHF_SZ; + hdr |= ptr_n; + + hdr <<= UI_MSB_EHF_SZ; + hdr |= res_n; + + hdr <<= UI16_MSB_EHF_SZ; + hdr |= t_no_n; + + if (tag == ERTS_MT_CRR_REALLOC_BDY_TAG) { + hdr <<= UI16_MSB_EHF_SZ; + hdr |= ct_no_n; + } + + WRITE_UI16(hdrp, hdr); + +#if TRACE_PRINTOUTS + print_trace_entry(tag, + ct_no, ct_no_n, + t_no, t_no_n, + (Uint) res, res_n, + (Uint) ptr, ptr_n, + size, size_n, + ti, ti_n); +#endif + +#ifdef DEBUG + check_realloc_entry(hdrp-1, tracep, + tag, + ct_no, ct_no_n, + t_no, t_no_n, + (Uint) res, res_n, + (Uint) ptr, ptr_n, + size, size_n, + ti, ti_n); +#endif + + } + } + erts_mtx_unlock(&mtrace_buf_mutex); +} + +static ERTS_INLINE void +write_free_entry(byte tag, + ErtsAlcType_t x, + ErtsAlcType_t y, + void *ptr) +{ + erts_mtx_lock(&mtrace_buf_mutex); + if (erts_mtrace_enabled) { + Uint32 ti = get_time_inc(); + + if (ti != INVALID_TIME_INC + && MAKE_TBUF_SZ(UI8_SZ + 2*UI16_SZ + UI_SZ + UI32_SZ)) { + Uint16 hdr, t_no = (Uint16) x, ct_no = (Uint16) y; + byte *hdrp; + int t_no_n, ct_no_n = 0, ptr_n, ti_n; + + *(tracep++) = tag; + + hdrp = tracep; + tracep += 2; + + if (tag == ERTS_MT_CRR_FREE_BDY_TAG) { + PUT_VSZ_UI16(tracep, ct_no_n, ct_no); + } + PUT_VSZ_UI16(tracep, t_no_n, t_no); + PUT_VSZ_UI( tracep, ptr_n, ptr); + PUT_VSZ_UI32(tracep, ti_n, ti); + + hdr = ti_n; + + hdr <<= UI_MSB_EHF_SZ; + hdr |= ptr_n; + + hdr <<= UI16_MSB_EHF_SZ; + hdr |= t_no_n; + + if (tag == ERTS_MT_CRR_FREE_BDY_TAG) { + hdr <<= UI16_MSB_EHF_SZ; + hdr |= ct_no_n; + } + + WRITE_UI16(hdrp, hdr); + +#if TRACE_PRINTOUTS + print_trace_entry(tag, + ct_no, ct_no_n, + t_no, t_no_n, + (Uint) 0, 0, + (Uint) ptr, ptr_n, + 0, 0, + ti, ti_n); +#endif + +#ifdef DEBUG + check_free_entry(hdrp-1, tracep, + tag, + ct_no, ct_no_n, + t_no, t_no_n, + (Uint) ptr, ptr_n, + ti, ti_n); +#endif + } + + } + erts_mtx_unlock(&mtrace_buf_mutex); +} + +static void * +mtrace_alloc(ErtsAlcType_t n, void *extra, Uint size) +{ + ErtsAllocatorFunctions_t *real_af = (ErtsAllocatorFunctions_t *) extra; + void *res; + + erts_mtx_lock(&mtrace_op_mutex); + + res = (*real_af->alloc)(n, real_af->extra, size); + write_alloc_entry(ERTS_MT_ALLOC_BDY_TAG, res, n, 0, size); + + erts_mtx_unlock(&mtrace_op_mutex); + + return res; +} + +static void * +mtrace_realloc(ErtsAlcType_t n, void *extra, void *ptr, Uint size) +{ + ErtsAllocatorFunctions_t *real_af = (ErtsAllocatorFunctions_t *) extra; + void *res; + + erts_mtx_lock(&mtrace_op_mutex); + + res = (*real_af->realloc)(n, real_af->extra, ptr, size); + write_realloc_entry(ERTS_MT_REALLOC_BDY_TAG, res, n, 0, ptr, size); + + erts_mtx_unlock(&mtrace_op_mutex); + + return res; + +} + +static void +mtrace_free(ErtsAlcType_t n, void *extra, void *ptr) +{ + ErtsAllocatorFunctions_t *real_af = (ErtsAllocatorFunctions_t *) extra; + + erts_mtx_lock(&mtrace_op_mutex); + + (*real_af->free)(n, real_af->extra, ptr); + write_free_entry(ERTS_MT_FREE_BDY_TAG, n, 0, ptr); + + erts_mtx_unlock(&mtrace_op_mutex); +} + + +void +erts_mtrace_crr_alloc(void *res, ErtsAlcType_t n, ErtsAlcType_t m, Uint size) +{ + write_alloc_entry(ERTS_MT_CRR_ALLOC_BDY_TAG, res, n, m, size); +} + +void +erts_mtrace_crr_realloc(void *res, ErtsAlcType_t n, ErtsAlcType_t m, void *ptr, + Uint size) +{ + write_realloc_entry(ERTS_MT_CRR_REALLOC_BDY_TAG, res, n, m, ptr, size); +} + +void +erts_mtrace_crr_free(ErtsAlcType_t n, ErtsAlcType_t m, void *ptr) +{ + write_free_entry(ERTS_MT_CRR_FREE_BDY_TAG, n, m, ptr); +} + + +#if TRACE_PRINTOUTS +static void +print_trace_entry(byte tag, + Uint16 t_no, int t_no_n, + Uint16 ct_no, int ct_no_n, + Uint res, int res_n, + Uint ptr, int ptr_n, + Uint size, int size_n, + Uint32 ti,int ti_n) +{ + switch (tag) { + case ERTS_MT_ALLOC_BDY_TAG: + fprintf(stderr, + "{alloc, {%lu, %lu, %lu}, {%u, %u, %u, %u}}\n\r", + + (unsigned long) t_no, (unsigned long) res, + (unsigned long) size, + + MSB2BITS(t_no_n), MSB2BITS(res_n), + MSB2BITS(size_n), MSB2BITS(ti_n)); + break; + case ERTS_MT_REALLOC_BDY_TAG: + fprintf(stderr, + "{realloc, {%lu, %lu, %lu, %lu}, {%u, %u, %u, %u, %u}}\n\r", + + (unsigned long) t_no, (unsigned long) res, + (unsigned long) ptr, (unsigned long) size, + + MSB2BITS(t_no_n), MSB2BITS(res_n), + MSB2BITS(ptr_n), MSB2BITS(size_n), MSB2BITS(ti_n)); + break; + case ERTS_MT_FREE_BDY_TAG: + fprintf(stderr, + "{free, {%lu, %lu}, {%u, %u, %u, %u, %u}}\n\r", + + (unsigned long) t_no, (unsigned long) ptr, + + MSB2BITS(t_no_n), MSB2BITS(ptr_n), MSB2BITS(ti_n)); + break; + case ERTS_MT_CRR_ALLOC_BDY_TAG: + fprintf(stderr, + "{crr_alloc, {%lu, %lu, %lu, %lu}, {%u, %u, %u, %u, %u}}\n\r", + + (unsigned long) ct_no, (unsigned long) t_no, + (unsigned long) res, (unsigned long) size, + + MSB2BITS(ct_no_n), MSB2BITS(t_no_n), + MSB2BITS(res_n), MSB2BITS(size_n), + MSB2BITS(ti_n)); + break; + case ERTS_MT_CRR_REALLOC_BDY_TAG: + fprintf(stderr, + "{crr_realloc, {%lu, %lu, %lu, %lu, %lu}, " + "{%u, %u, %u, %u, %u, %u}}\n\r", + + (unsigned long) ct_no, (unsigned long) t_no, + (unsigned long) res, (unsigned long) ptr, + (unsigned long) size, + + MSB2BITS(ct_no_n), MSB2BITS(t_no_n), + MSB2BITS(res_n), MSB2BITS(ptr_n), + MSB2BITS(size_n), MSB2BITS(ti_n)); + break; + case ERTS_MT_CRR_FREE_BDY_TAG: + fprintf(stderr, + "{crr_free, {%lu, %lu, %lu}, {%u, %u, %u, %u}}\n\r", + + (unsigned long) ct_no, (unsigned long) t_no, + (unsigned long) ptr, + + MSB2BITS(ct_no_n), MSB2BITS(t_no_n), + MSB2BITS(ptr_n), MSB2BITS(ti_n)); + break; + default: + fprintf(stderr, "{'\?\?\?'}\n\r"); + break; + } +} + +#endif /* #if TRACE_PRINTOUTS */ + +#ifdef DEBUG + +#define GET_UI16(P) ((P) += UI16_SZ, \ + (((Uint16) (*((P) - 2) << 8)) | ((Uint16) (*((P) - 1))))) + +static void +check_ui(Uint16 *hdrp, byte **pp, Uint ui, int msb, + Uint16 f_mask, Uint16 f_size) +{ + Uint x; + int n; + + ASSERT((msb & ~f_mask) == 0); + + n = (int) (*hdrp & f_mask); + + ASSERT(n == msb); + + *hdrp >>= f_size; + + x = 0; + switch (n) { +#ifdef ARCH_64 + case 7: x |= *((*pp)++); x <<= 8; + case 6: x |= *((*pp)++); x <<= 8; + case 5: x |= *((*pp)++); x <<= 8; + case 4: x |= *((*pp)++); x <<= 8; +#endif + case 3: x |= *((*pp)++); x <<= 8; + case 2: x |= *((*pp)++); x <<= 8; + case 1: x |= *((*pp)++); x <<= 8; + case 0: x |= *((*pp)++); break; + default: ASSERT(0); + } + + ASSERT(x == ui); +} + + +void +check_alloc_entry(byte *sp, byte *ep, + byte tag, + Uint16 ct_no, int ct_no_n, + Uint16 t_no, int t_no_n, + Uint res, int res_n, + Uint size, int size_n, + Uint32 ti,int ti_n) +{ + byte *p = sp; + Uint16 hdr; + + ASSERT(*p == tag); + p++; + + hdr = GET_UI16(p); + + if (tag == ERTS_MT_CRR_ALLOC_BDY_TAG) + check_ui(&hdr, &p, ct_no, ct_no_n, UI16_MSB_EHF_MSK, UI16_MSB_EHF_SZ); + check_ui(&hdr, &p, t_no, t_no_n, UI16_MSB_EHF_MSK, UI16_MSB_EHF_SZ); + check_ui(&hdr, &p, res, res_n, UI_MSB_EHF_MSK, UI_MSB_EHF_SZ); + check_ui(&hdr, &p, size, size_n, UI_MSB_EHF_MSK, UI_MSB_EHF_SZ); + check_ui(&hdr, &p, ti, ti_n, UI32_MSB_EHF_MSK, UI32_MSB_EHF_SZ); + + ASSERT(hdr == 0); + ASSERT(p == ep); +} + +void +check_realloc_entry(byte *sp, byte *ep, + byte tag, + Uint16 ct_no, int ct_no_n, + Uint16 t_no, int t_no_n, + Uint res, int res_n, + Uint ptr, int ptr_n, + Uint size, int size_n, + Uint32 ti,int ti_n) +{ + byte *p = sp; + Uint16 hdr; + + ASSERT(*p == tag); + p++; + + hdr = GET_UI16(p); + + if (tag == ERTS_MT_CRR_REALLOC_BDY_TAG) + check_ui(&hdr, &p, ct_no, ct_no_n, UI16_MSB_EHF_MSK, UI16_MSB_EHF_SZ); + check_ui(&hdr, &p, t_no, t_no_n, UI16_MSB_EHF_MSK, UI16_MSB_EHF_SZ); + check_ui(&hdr, &p, res, res_n, UI_MSB_EHF_MSK, UI_MSB_EHF_SZ); + check_ui(&hdr, &p, ptr, ptr_n, UI_MSB_EHF_MSK, UI_MSB_EHF_SZ); + check_ui(&hdr, &p, size, size_n, UI_MSB_EHF_MSK, UI_MSB_EHF_SZ); + check_ui(&hdr, &p, ti, ti_n, UI32_MSB_EHF_MSK, UI32_MSB_EHF_SZ); + + ASSERT(hdr == 0); + ASSERT(p == ep); +} + +void +check_free_entry(byte *sp, byte *ep, + byte tag, + Uint16 ct_no, int ct_no_n, + Uint16 t_no, int t_no_n, + Uint ptr, int ptr_n, + Uint32 ti,int ti_n) +{ + byte *p = sp; + Uint16 hdr; + + ASSERT(*p == tag); + p++; + + hdr = GET_UI16(p); + + if (tag == ERTS_MT_CRR_FREE_BDY_TAG) + check_ui(&hdr, &p, ct_no, ct_no_n, UI16_MSB_EHF_MSK, UI16_MSB_EHF_SZ); + check_ui(&hdr, &p, t_no, t_no_n, UI16_MSB_EHF_MSK, UI16_MSB_EHF_SZ); + check_ui(&hdr, &p, ptr, ptr_n, UI_MSB_EHF_MSK, UI_MSB_EHF_SZ); + check_ui(&hdr, &p, ti, ti_n, UI32_MSB_EHF_MSK, UI32_MSB_EHF_SZ); + + ASSERT(hdr == 0); + ASSERT(p == ep); + +} + +void +check_time_inc_entry(byte *sp, byte *ep, + Uint32 secs, int secs_n, + Uint32 usecs, int usecs_n) +{ + byte *p = sp; + Uint16 hdr; + + ASSERT(*p == ERTS_MT_TIME_INC_BDY_TAG); + p++; + + hdr = GET_UI16(p); + + check_ui(&hdr, &p, secs, secs_n, UI32_MSB_EHF_MSK, UI32_MSB_EHF_SZ); + check_ui(&hdr, &p, usecs, usecs_n, UI32_MSB_EHF_MSK, UI32_MSB_EHF_SZ); + + ASSERT(hdr == 0); + ASSERT(p == ep); + +} + +#endif /* #ifdef DEBUG */ + diff --git a/erts/emulator/beam/erl_mtrace.h b/erts/emulator/beam/erl_mtrace.h new file mode 100644 index 0000000000..204543ddb0 --- /dev/null +++ b/erts/emulator/beam/erl_mtrace.h @@ -0,0 +1,51 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2003-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifndef ERL_MTRACE_H__ +#define ERL_MTRACE_H__ + +#include "erl_alloc_types.h" + +#if (defined(ERTS___AFTER_MORECORE_HOOK_CAN_TRACK_MALLOC) \ + || defined(ERTS_BRK_WRAPPERS_CAN_TRACK_MALLOC)) +#undef ERTS_CAN_TRACK_MALLOC +#define ERTS_CAN_TRACK_MALLOC +#endif + +#define ERTS_MTRACE_SEGMENT_ID ERTS_ALC_A_INVALID + +extern int erts_mtrace_enabled; + +void erts_mtrace_pre_init(void); +void erts_mtrace_init(char *receiver, char *nodename); +void erts_mtrace_install_wrapper_functions(void); +void erts_mtrace_stop(void); +void erts_mtrace_exit(Uint32 exit_value); + +void erts_mtrace_crr_alloc(void*, ErtsAlcType_t, ErtsAlcType_t, Uint); +void erts_mtrace_crr_realloc(void*, ErtsAlcType_t, ErtsAlcType_t, void*, Uint); +void erts_mtrace_crr_free(ErtsAlcType_t, ErtsAlcType_t, void*); + + +void erts_mtrace_update_heap_size(void); /* Implemented in + * ../sys/common/erl_mtrace_sys_wrap.c + */ + +#endif /* #ifndef ERL_MTRACE_H__ */ + diff --git a/erts/emulator/beam/erl_nif.c b/erts/emulator/beam/erl_nif.c new file mode 100644 index 0000000000..fa4454a3f3 --- /dev/null +++ b/erts/emulator/beam/erl_nif.c @@ -0,0 +1,641 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ +/* Erlang Native InterFace + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "erl_nif.h" + +#include "sys.h" +#include "global.h" +#include "erl_binary.h" +#include "bif.h" +#include "error.h" +#include "big.h" +#include "beam_bp.h" + +#include + +/* +static ERTS_INLINE Eterm* alloc_heap(ErlNifEnv* env, unsigned need) +{ + return HAlloc(env->proc, need); +} +*/ + +#define MIN_HEAP_FRAG_SZ 200 +static Eterm* alloc_heap_heavy(ErlNifEnv* env, unsigned need); + +static ERTS_INLINE Eterm* alloc_heap(ErlNifEnv* env, unsigned need) +{ + Eterm* hp = env->hp; + env->hp += need; + if (env->hp <= env->hp_end) { + return hp; + } + env->hp = hp; + return alloc_heap_heavy(env,need); +} + +static Eterm* alloc_heap_heavy(ErlNifEnv* env, unsigned need) +{ + Eterm* hp; + + if (env->heap_frag_sz == 0) { + ASSERT(HEAP_LIMIT(env->proc) == env->hp_end); + HEAP_TOP(env->proc) = env->hp; + env->heap_frag_sz = need + MIN_HEAP_FRAG_SZ; + } + else { + HRelease(env->proc, env->hp_end, env->hp); + env->heap_frag_sz *= 2; + } + hp = erts_heap_alloc(env->proc, env->heap_frag_sz); + env->hp = hp + need; + env->hp_end = hp + env->heap_frag_sz; + return hp; +} + +void erts_pre_nif(ErlNifEnv* env, Process* p, void* nif_data) +{ + env->nif_data = nif_data; + env->proc = p; + env->hp = HEAP_TOP(p); + env->hp_end = HEAP_LIMIT(p); + env->heap_frag_sz = 0; + env->fpe_was_unmasked = erts_block_fpe(); +} + +void erts_post_nif(ErlNifEnv* env) +{ + erts_unblock_fpe(env->fpe_was_unmasked); + if (env->heap_frag_sz == 0) { + ASSERT(env->hp_end == HEAP_LIMIT(env->proc)); + ASSERT(env->hp >= HEAP_TOP(env->proc)); + ASSERT(env->hp <= HEAP_LIMIT(env->proc)); + HEAP_TOP(env->proc) = env->hp; + } + else { + ASSERT(env->hp_end != HEAP_LIMIT(env->proc)); + ASSERT(env->hp_end - env->hp <= env->heap_frag_sz); + HRelease(env->proc, env->hp_end, env->hp); + } +} + +void* enif_get_data(ErlNifEnv* env) +{ + return env->nif_data; +} + +void* enif_alloc(ErlNifEnv* env, size_t size) +{ + return erts_alloc_fnf(ERTS_ALC_T_NIF, (Uint) size); +} + +void enif_free(ErlNifEnv* env, void* ptr) +{ + erts_free(ERTS_ALC_T_NIF, ptr); +} + + +int enif_is_binary(ErlNifEnv* env, ERL_NIF_TERM term) +{ + return is_binary(term) && (binary_bitsize(term) % 8 == 0); +} + + +int enif_inspect_binary(ErlNifEnv* env, Eterm bin_term, ErlNifBinary* bin) +{ + bin->tmp_alloc = NULL; + bin->data = erts_get_aligned_binary_bytes(bin_term, &bin->tmp_alloc); + if (bin->data == NULL) { + return 0; + } + bin->bin_term = bin_term; + bin->size = binary_size(bin_term); + bin->ref_bin = NULL; + return 1; +} + + +int enif_alloc_binary(ErlNifEnv* env, unsigned size, ErlNifBinary* bin) +{ + Binary* refbin; + + refbin = erts_bin_drv_alloc_fnf(size); /* BUGBUG: alloc type? */ + if (refbin == NULL) { + return 0; /* The NIF must take action */ + } + refbin->flags = BIN_FLAG_DRV; /* BUGBUG: Flag? */ + erts_refc_init(&refbin->refc, 1); + refbin->orig_size = (long) size; + + bin->size = size; + bin->data = (unsigned char*) refbin->orig_bytes; + bin->bin_term = THE_NON_VALUE; + bin->tmp_alloc = NULL; + bin->ref_bin = refbin; + return 1; +} + +void enif_release_binary(ErlNifEnv* env, ErlNifBinary* bin) +{ + if (bin->ref_bin == NULL) { + erts_free_aligned_binary_bytes(bin->tmp_alloc); + } + else { + Binary* refbin = bin->ref_bin; + ASSERT(bin->tmp_alloc == NULL); + ASSERT(bin->bin_term == THE_NON_VALUE); + if (erts_refc_dectest(&refbin->refc, 0) == 0) { + erts_bin_free(refbin); + } + } +#ifdef DEBUG + bin->bin_term = THE_NON_VALUE; + bin->tmp_alloc = NULL; + bin->ref_bin = NULL; +#endif +} + +Eterm enif_make_binary(ErlNifEnv* env, ErlNifBinary* bin) +{ + if (bin->ref_bin == NULL) { + erts_free_aligned_binary_bytes(bin->tmp_alloc); + return bin->bin_term; + } + else { + Binary* bptr = bin->ref_bin; + ProcBin* pb; + ASSERT(bin->tmp_alloc == NULL); + + /* !! Copy-paste from new_binary() !! */ + pb = (ProcBin *) alloc_heap(env, PROC_BIN_SIZE); + pb->thing_word = HEADER_PROC_BIN; + pb->size = bptr->orig_size; + pb->next = MSO(env->proc).mso; + MSO(env->proc).mso = pb; + pb->val = bptr; + pb->bytes = (byte*) bptr->orig_bytes; + pb->flags = 0; + + MSO(env->proc).overhead += pb->size / sizeof(Eterm); + return make_binary(pb); + } +} + +ERL_NIF_TERM enif_make_badarg(ErlNifEnv* env) +{ + BIF_ERROR(env->proc, BADARG); +} + + +int enif_get_int(ErlNifEnv* env, Eterm term, int* ip) +{ +#if SIZEOF_INT == SIZEOF_VOID_P + return term_to_Sint(term, ip); +#elif SIZEOF_LONG == SIZEOF_VOID_P + Sint i; + if (!term_to_Sint(term, &i) || i < INT_MIN || i > INT_MAX) { + return 0; + } + *ip = (int) i; + return 1; +#else +# error Unknown word size +#endif +} + +int enif_get_ulong(ErlNifEnv* env, Eterm term, unsigned long* ip) +{ +#if SIZEOF_LONG == SIZEOF_VOID_P + return term_to_Uint(term, ip); +#else +# error Unknown long word size +#endif +} + +int enif_get_list_cell(ErlNifEnv* env, Eterm term, Eterm* head, Eterm* tail) +{ + Eterm* val; + if (is_not_list(term)) return 0; + val = list_val(term); + *head = CAR(val); + *tail = CDR(val); + return 1; +} + +ERL_NIF_TERM enif_make_int(ErlNifEnv* env, int i) +{ +#if SIZEOF_INT == SIZEOF_VOID_P + return IS_SSMALL(i) ? make_small(i) : small_to_big(i,alloc_heap(env,2)); +#elif SIZEOF_LONG == SIZEOF_VOID_P + return make_small(i); +#endif +} + +ERL_NIF_TERM enif_make_ulong(ErlNifEnv* env, unsigned long i) +{ +#if SIZEOF_LONG == SIZEOF_VOID_P + Eterm* hp; + Uint sz = 0; + erts_bld_uint(NULL, &sz, i); + hp = alloc_heap(env,sz); + return erts_bld_uint(&hp, NULL, i); +#else +# error Unknown long word size +#endif + +} + + +ERL_NIF_TERM enif_make_atom(ErlNifEnv* env, const char* name) +{ + return am_atom_put(name, sys_strlen(name)); +} + + +ERL_NIF_TERM enif_make_tuple(ErlNifEnv* env, unsigned cnt, ...) +{ + Eterm* hp = alloc_heap(env,cnt+1); + Eterm ret = make_tuple(hp); + va_list ap; + + *hp++ = make_arityval(cnt); + va_start(ap,cnt); + while (cnt--) { + *hp++ = va_arg(ap,Eterm); + } + va_end(ap); + return ret; +} + +ERL_NIF_TERM enif_make_list_cell(ErlNifEnv* env, Eterm car, Eterm cdr) +{ + Eterm* hp = alloc_heap(env,2); + Eterm ret = make_list(hp); + + CAR(hp) = car; + CDR(hp) = cdr; + return ret; +} + +ERL_NIF_TERM enif_make_list(ErlNifEnv* env, unsigned cnt, ...) +{ + Eterm* hp = alloc_heap(env,cnt*2); + Eterm ret = make_list(hp); + Eterm* last = &ret; + va_list ap; + + va_start(ap,cnt); + while (cnt--) { + *last = make_list(hp); + *hp = va_arg(ap,Eterm); + last = ++hp; + ++hp; + } + va_end(ap); + *last = NIL; + return ret; +} + +ERL_NIF_TERM enif_make_string(ErlNifEnv* env, const char* string) +{ + Sint n = strlen(string); + Eterm* hp = alloc_heap(env,n*2); + return erts_bld_string_n(&hp,NULL,string,n); +} + + + + +/*************************************************************************** + ** load_nif/2 ** + ***************************************************************************/ + + +static Uint** get_func_pp(Eterm* mod_code, Eterm f_atom, unsigned arity) +{ + int n = (int) mod_code[MI_NUM_FUNCTIONS]; + int j; + for (j = 0; j < n; ++j) { + Uint* code_ptr = (Uint*) mod_code[MI_FUNCTIONS+j]; + ASSERT(code_ptr[0] == (Uint) BeamOp(op_i_func_info_IaaI)); + if (f_atom == ((Eterm) code_ptr[3]) + && arity == ((unsigned) code_ptr[4])) { + + return (Uint**) &mod_code[MI_FUNCTIONS+j]; + } + } + return NULL; +} + +#define in_area(ptr,start,nbytes) \ + ((unsigned long)((char*)(ptr) - (char*)(start)) < (nbytes)) + +static void refresh_cached_nif_data(Eterm* mod_code, + struct erl_module_nif* mod_nif) +{ + int i; + for (i=0; i < mod_nif->entry->num_of_funcs; i++) { + Eterm f_atom; + ErlNifFunc* func = &mod_nif->entry->funcs[i]; + Uint* code_ptr; + + erts_atom_get(func->name, strlen(func->name), &f_atom); + code_ptr = *get_func_pp(mod_code, f_atom, func->arity); + code_ptr[5+2] = (Uint) mod_nif->data; + } +} + +static Eterm mkatom(const char *str) +{ + return am_atom_put(str, sys_strlen(str)); +} + +static struct tainted_module_t +{ + struct tainted_module_t* next; + Eterm module_atom; +}*first_tainted_module = NULL; + +static void add_taint(Eterm mod_atom) +{ + struct tainted_module_t* t; + for (t=first_tainted_module ; t!=NULL; t=t->next) { + if (t->module_atom == mod_atom) { + return; + } + } + t = erts_alloc_fnf(ERTS_ALC_T_TAINT, sizeof(*t)); + if (t != NULL) { + t->module_atom = mod_atom; + t->next = first_tainted_module; + first_tainted_module = t; + } +} + +Eterm erts_nif_taints(Process* p) +{ + struct tainted_module_t* t; + unsigned cnt = 0; + Eterm list = NIL; + Eterm* hp; + for (t=first_tainted_module ; t!=NULL; t=t->next) { + cnt++; + } + hp = HAlloc(p,cnt*2); + for (t=first_tainted_module ; t!=NULL; t=t->next) { + list = CONS(hp, t->module_atom, list); + hp += 2; + } + return list; +} + + +static Eterm load_nif_error(Process* p, const char* atom, const char* format, ...) +{ + erts_dsprintf_buf_t* dsbufp = erts_create_tmp_dsbuf(0); + Eterm ret; + Eterm* hp; + Eterm** hpp = NULL; + Uint sz = 0; + Uint* szp = &sz; + va_list arglist; + + va_start(arglist, format); + erts_vdsprintf(dsbufp, format, arglist); + va_end(arglist); + + for (;;) { + Eterm txt = erts_bld_string_n(hpp, &sz, dsbufp->str, dsbufp->str_len); + ret = erts_bld_tuple(hpp, szp, 3, am_error, mkatom(atom), txt); + if (hpp != NULL) { + break; + } + hp = HAlloc(p,sz); + hpp = &hp; + szp = NULL; + } + erts_destroy_tmp_dsbuf(dsbufp); + return ret; +} + +BIF_RETTYPE load_nif_2(BIF_ALIST_2) +{ + static const char bad_lib[] = "bad_lib"; + static const char reload[] = "reload"; + static const char upgrade[] = "upgrade"; + char lib_name[256]; /* BUGBUG: Max-length? */ + void* handle = NULL; + void* init_func; + ErlNifEntry* entry = NULL; + ErlNifEnv env; + int len, i, err; + Module* mod; + Eterm mod_atom; + Eterm f_atom; + Eterm* caller; + ErtsSysDdllError errdesc = ERTS_SYS_DDLL_ERROR_INIT; + Eterm ret = am_ok; + int veto; + + len = intlist_to_buf(BIF_ARG_1, lib_name, sizeof(lib_name)-1); + if (len < 1) { + /*erts_fprintf(stderr, "Invalid library path name '%T'\r\n", BIF_ARG_1);*/ + BIF_ERROR(BIF_P, BADARG); + } + lib_name[len] = '\0'; + + /* Block system (is this the right place to do it?) */ + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN); + erts_smp_block_system(0); + + /* Find calling module */ + ASSERT(BIF_P->current != NULL); + ASSERT(BIF_P->current[0] == am_erlang + && BIF_P->current[1] == am_load_nif + && BIF_P->current[2] == 2); + caller = find_function_from_pc(BIF_P->cp); + ASSERT(caller != NULL); + mod_atom = caller[0]; + ASSERT(is_atom(mod_atom)); + mod=erts_get_module(mod_atom); + ASSERT(mod != NULL); + + if (!in_area(caller, mod->code, mod->code_length)) { + ASSERT(in_area(caller, mod->old_code, mod->old_code_length)); + + ret = load_nif_error(BIF_P, "old_code", "Calling load_nif from old " + "module '%T' not allowed", mod_atom); + } + else if ((err=erts_sys_ddll_open2(lib_name, &handle, &errdesc)) != ERL_DE_NO_ERROR) { + ret = load_nif_error(BIF_P, "load_failed", "Failed to load NIF library" + " %s: '%s'", lib_name, errdesc.str); + } + else if (erts_sys_ddll_load_nif_init(handle, &init_func, &errdesc) != ERL_DE_NO_ERROR) { + ret = load_nif_error(BIF_P, bad_lib, "Failed to find library init" + " function: '%s'", errdesc.str); + + } + else if ((add_taint(mod_atom), + (entry = erts_sys_ddll_call_nif_init(init_func)) == NULL)) { + ret = load_nif_error(BIF_P, bad_lib, "Library init-call unsuccessful"); + } + else if (entry->major != ERL_NIF_MAJOR_VERSION + || entry->minor > ERL_NIF_MINOR_VERSION) { + + ret = load_nif_error(BIF_P, bad_lib, "Library version (%d.%d) not compatible (with %d.%d).", + entry->major, entry->minor, ERL_NIF_MAJOR_VERSION, ERL_NIF_MINOR_VERSION); + } + else if (!erts_is_atom_str((char*)entry->name, mod_atom)) { + ret = load_nif_error(BIF_P, bad_lib, "Library module name '%s' does not" + " match calling module '%T'", entry->name, mod_atom); + } + else { + /*erts_fprintf(stderr, "Found module %T\r\n", mod_atom);*/ + + for (i=0; i < entry->num_of_funcs && ret==am_ok; i++) { + Uint** code_pp; + ErlNifFunc* f = &entry->funcs[i]; + if (f->arity > 3) { + ret = load_nif_error(BIF_P,bad_lib,"Function arity too high for NIF %s/%u", + f->name, f->arity); + } + else if (!erts_atom_get(f->name, strlen(f->name), &f_atom) + || (code_pp = get_func_pp(mod->code, f_atom, f->arity))==NULL) { + ret = load_nif_error(BIF_P,bad_lib,"Function not found %T:%s/%u", + mod_atom, f->name, f->arity); + } + else if (code_pp[1] - code_pp[0] < (5+3)) { + ret = load_nif_error(BIF_P,bad_lib,"No explicit call to load_nif" + " in module (%T:%s/%u to small)", + mod_atom, entry->funcs[i].name, entry->funcs[i].arity); + } + /*erts_fprintf(stderr, "Found NIF %T:%s/%u\r\n", + mod_atom, entry->funcs[i].name, entry->funcs[i].arity);*/ + } + } + + if (ret != am_ok) { + goto error; + } + + /* Call load, reload or upgrade: + */ + if (mod->nif.handle != NULL) { /* Reload */ + int k; + ASSERT(mod->nif.entry != NULL); + if (entry->reload == NULL) { + ret = load_nif_error(BIF_P,reload,"Reload not supported by this NIF library."); + goto error; + } + /* Check that no NIF is removed */ + for (k=0; k < mod->nif.entry->num_of_funcs; k++) { + ErlNifFunc* old_func = &mod->nif.entry->funcs[k]; + for (i=0; i < entry->num_of_funcs; i++) { + if (old_func->arity == entry->funcs[i].arity + && sys_strcmp(old_func->name, entry->funcs[i].name) == 0) { + break; + } + } + if (i == entry->num_of_funcs) { + ret = load_nif_error(BIF_P,reload,"Reloaded library missing " + "function %T:%s/%u\r\n", mod_atom, + old_func->name, old_func->arity); + goto error; + } + } + erts_pre_nif(&env, BIF_P, mod->nif.data); + veto = entry->reload(&env, &env.nif_data, BIF_ARG_2); + erts_post_nif(&env); + if (veto) { + ret = load_nif_error(BIF_P, reload, "Library reload-call unsuccessful."); + } + else { + erts_sys_ddll_close(mod->nif.handle); + } + } + else { + if (mod->old_nif.handle != NULL) { /* Upgrade */ + void* prev_old_data = mod->old_nif.data; + if (entry->upgrade == NULL) { + ret = load_nif_error(BIF_P, upgrade, "Upgrade not supported by this NIF library."); + goto error; + } + erts_pre_nif(&env, BIF_P, NULL); + veto = entry->upgrade(&env, &env.nif_data, &mod->old_nif.data, BIF_ARG_2); + erts_post_nif(&env); + if (veto) { + mod->old_nif.data = prev_old_data; + ret = load_nif_error(BIF_P, upgrade, "Library upgrade-call unsuccessful."); + } + else if (mod->old_nif.data != prev_old_data) { + refresh_cached_nif_data(mod->old_code, &mod->old_nif); + } + } + else if (entry->load != NULL) { /* Initial load */ + erts_pre_nif(&env, BIF_P, NULL); + veto = entry->load(&env, &env.nif_data, BIF_ARG_2); + erts_post_nif(&env); + if (veto) { + ret = load_nif_error(BIF_P, "load", "Library load-call unsuccessful."); + } + } + } + if (ret == am_ok) { + /* + ** Everything ok, patch the beam code with op_call_nif + */ + mod->nif.data = env.nif_data; + mod->nif.handle = handle; + mod->nif.entry = entry; + for (i=0; i < entry->num_of_funcs; i++) + { + Uint* code_ptr; + erts_atom_get(entry->funcs[i].name, strlen(entry->funcs[i].name), &f_atom); + code_ptr = *get_func_pp(mod->code, f_atom, entry->funcs[i].arity); + + if (code_ptr[1] == 0) { + code_ptr[5+0] = (Uint) BeamOp(op_call_nif); + } else { /* Function traced, patch the original instruction word */ + BpData* bp = (BpData*) code_ptr[1]; + bp->orig_instr = (Uint) BeamOp(op_call_nif); + } + code_ptr[5+1] = (Uint) entry->funcs[i].fptr; + code_ptr[5+2] = (Uint) mod->nif.data; + } + } + else { + error: + ASSERT(ret != am_ok); + if (handle != NULL) { + erts_sys_ddll_close(handle); + } + erts_sys_ddll_free_error(&errdesc); + } + + erts_smp_release_system(); + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_MAIN); + BIF_RET(ret); +} + diff --git a/erts/emulator/beam/erl_nif.h b/erts/emulator/beam/erl_nif.h new file mode 100644 index 0000000000..8650b7ce47 --- /dev/null +++ b/erts/emulator/beam/erl_nif.h @@ -0,0 +1,122 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* Include file for writers of Native Implemented Functions. +*/ + +#define ERL_NIF_MAJOR_VERSION 0 +#define ERL_NIF_MINOR_VERSION 1 + +#include + +typedef unsigned long ERL_NIF_TERM; + +typedef struct +{ + const char* name; + unsigned arity; + void* fptr; //ERL_NIF_TERM (*fptr)(void*, ...); +}ErlNifFunc; + +struct enif_environment_t; +typedef struct enif_environment_t ErlNifEnv; + +typedef struct enif_entry_t +{ + int major; + int minor; + const char* name; + int num_of_funcs; + ErlNifFunc* funcs; + int (*load) (ErlNifEnv*, void** priv_data, ERL_NIF_TERM load_info); + int (*reload) (ErlNifEnv*, void** priv_data, ERL_NIF_TERM load_info); + int (*upgrade)(ErlNifEnv*, void** priv_data, void** old_priv_data, ERL_NIF_TERM load_info); + void (*unload) (ErlNifEnv*, void* priv_data); +}ErlNifEntry; + + + +typedef struct +{ + unsigned size; + unsigned char* data; + + /* Internals (avert your eyes) */ + ERL_NIF_TERM bin_term; + unsigned char* tmp_alloc; + void* ref_bin; + +}ErlNifBinary; + +#if (defined(__WIN32__) || defined(_WIN32) || defined(_WIN32_)) +# define ERL_NIF_API_FUNC_DECL(RET_TYPE, NAME, ARGS) RET_TYPE (*NAME) ARGS +typedef struct { +# include "erl_nif_api_funcs.h" +} TWinDynNifCallbacks; +extern TWinDynNifCallbacks WinDynNifCallbacks; +# undef ERL_NIF_API_FUNC_DECL +#endif + +#if (defined(__WIN32__) || defined(_WIN32) || defined(_WIN32_)) && !defined(STATIC_ERLANG_DRIVER) +# define ERL_NIF_API_FUNC_MACRO(NAME) (WinDynNifCallbacks.NAME) +# include "erl_nif_api_funcs.h" +/* note that we have to keep ERL_NIF_API_FUNC_MACRO defined */ + +#else /* non windows or included from emulator itself */ + +# define ERL_NIF_API_FUNC_DECL(RET_TYPE, NAME, ARGS) extern RET_TYPE NAME ARGS +# include "erl_nif_api_funcs.h" +# undef ERL_NIF_API_FUNC_DECL +#endif + + + + +#if (defined(__WIN32__) || defined(_WIN32) || defined(_WIN32_)) +# define ERL_NIF_INIT_GLOB TWinDynNifCallbacks WinDynNifCallbacks; +# define ERL_NIF_INIT_DECL(MODNAME) __declspec(dllexport) ErlNifEntry* nif_init(TWinDynNifCallbacks* callbacks) +# define ERL_NIF_INIT_BODY memcpy(&WinDynNifCallbacks,callbacks,sizeof(TWinDynNifCallbacks)) +#else +# define ERL_NIF_INIT_GLOB +# define ERL_NIF_INIT_BODY +# if defined(VXWORKS) +# define ERL_NIF_INIT_DECL(MODNAME) ErlNifEntry* MODNAME ## _init(void) +# else +# define ERL_NIF_INIT_DECL(MODNAME) ErlNifEntry* nif_init(void) +# endif +#endif + + +#define ERL_NIF_INIT(NAME, FUNCS, LOAD, RELOAD, UPGRADE, UNLOAD) \ +ERL_NIF_INIT_GLOB \ +ERL_NIF_INIT_DECL(NAME) \ +{ \ + static ErlNifEntry entry = \ + { \ + ERL_NIF_MAJOR_VERSION, \ + ERL_NIF_MINOR_VERSION, \ + #NAME, \ + sizeof(FUNCS) / sizeof(*FUNCS), \ + FUNCS, \ + LOAD, RELOAD, UPGRADE, UNLOAD \ + }; \ + ERL_NIF_INIT_BODY; \ + return &entry; \ +} + diff --git a/erts/emulator/beam/erl_nif_api_funcs.h b/erts/emulator/beam/erl_nif_api_funcs.h new file mode 100644 index 0000000000..400c1822cc --- /dev/null +++ b/erts/emulator/beam/erl_nif_api_funcs.h @@ -0,0 +1,68 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#if !defined(ERL_NIF_API_FUNC_DECL) && !defined(ERL_NIF_API_FUNC_MACRO) +# error This file should not be included directly +#endif + +#ifdef ERL_NIF_API_FUNC_DECL +ERL_NIF_API_FUNC_DECL(void*,enif_get_data,(ErlNifEnv*)); +ERL_NIF_API_FUNC_DECL(void*,enif_alloc,(ErlNifEnv*, size_t size)); +ERL_NIF_API_FUNC_DECL(void,enif_free,(ErlNifEnv*, void* ptr)); +ERL_NIF_API_FUNC_DECL(int,enif_is_binary,(ErlNifEnv*, ERL_NIF_TERM term)); +ERL_NIF_API_FUNC_DECL(int,enif_inspect_binary,(ErlNifEnv*, ERL_NIF_TERM bin_term, ErlNifBinary* bin)); +ERL_NIF_API_FUNC_DECL(int,enif_alloc_binary,(ErlNifEnv*, unsigned size, ErlNifBinary* bin)); +ERL_NIF_API_FUNC_DECL(void,enif_release_binary,(ErlNifEnv*, ErlNifBinary* bin)); +ERL_NIF_API_FUNC_DECL(int,enif_get_int,(ErlNifEnv*, ERL_NIF_TERM term, int* ip)); +ERL_NIF_API_FUNC_DECL(int,enif_get_ulong,(ErlNifEnv*, ERL_NIF_TERM term, unsigned long* ip)); +ERL_NIF_API_FUNC_DECL(int,enif_get_list_cell,(ErlNifEnv* env, ERL_NIF_TERM term, ERL_NIF_TERM* head, ERL_NIF_TERM* tail)); +ERL_NIF_API_FUNC_DECL(ERL_NIF_TERM,enif_make_binary,(ErlNifEnv* env, ErlNifBinary* bin)); +ERL_NIF_API_FUNC_DECL(ERL_NIF_TERM,enif_make_badarg,(ErlNifEnv* env)); +ERL_NIF_API_FUNC_DECL(ERL_NIF_TERM,enif_make_int,(ErlNifEnv* env, int i)); +ERL_NIF_API_FUNC_DECL(ERL_NIF_TERM,enif_make_ulong,(ErlNifEnv* env, unsigned long i)); +ERL_NIF_API_FUNC_DECL(ERL_NIF_TERM,enif_make_atom,(ErlNifEnv* env, const char* name)); +ERL_NIF_API_FUNC_DECL(ERL_NIF_TERM,enif_make_tuple,(ErlNifEnv* env, unsigned cnt, ...)); +ERL_NIF_API_FUNC_DECL(ERL_NIF_TERM,enif_make_list,(ErlNifEnv* env, unsigned cnt, ...)); +ERL_NIF_API_FUNC_DECL(ERL_NIF_TERM,enif_make_list_cell,(ErlNifEnv* env, ERL_NIF_TERM car, ERL_NIF_TERM cdr)); +ERL_NIF_API_FUNC_DECL(ERL_NIF_TERM,enif_make_string,(ErlNifEnv* env, const char* string)); +#endif + +#ifdef ERL_NIF_API_FUNC_MACRO +# define enif_get_data ERL_NIF_API_FUNC_MACRO(enif_get_data) +# define enif_alloc ERL_NIF_API_FUNC_MACRO(enif_alloc) +# define enif_free ERL_NIF_API_FUNC_MACRO(enif_free) +# define enif_is_binary ERL_NIF_API_FUNC_MACRO(enif_is_binary) +# define enif_inspect_binary ERL_NIF_API_FUNC_MACRO(enif_inspect_binary) +# define enif_alloc_binary ERL_NIF_API_FUNC_MACRO(enif_alloc_binary) +# define enif_release_binary ERL_NIF_API_FUNC_MACRO(enif_release_binary) +# define enif_get_int ERL_NIF_API_FUNC_MACRO(enif_get_int) +# define enif_get_ulong ERL_NIF_API_FUNC_MACRO(enif_get_ulong) +# define enif_get_list_cell ERL_NIF_API_FUNC_MACRO(enif_get_list_cell) + +# define enif_make_binary ERL_NIF_API_FUNC_MACRO(enif_make_binary) +# define enif_make_badarg ERL_NIF_API_FUNC_MACRO(enif_make_badarg) +# define enif_make_int ERL_NIF_API_FUNC_MACRO(enif_make_int) +# define enif_make_ulong ERL_NIF_API_FUNC_MACRO(enif_make_ulong) +# define enif_make_atom ERL_NIF_API_FUNC_MACRO(enif_make_atom) +# define enif_make_tuple ERL_NIF_API_FUNC_MACRO(enif_make_tuple) +# define enif_make_list ERL_NIF_API_FUNC_MACRO(enif_make_list) +# define enif_make_list_cell ERL_NIF_API_FUNC_MACRO(enif_make_list_cell) +# define enif_make_string ERL_NIF_API_FUNC_MACRO(enif_make_string) +#endif + diff --git a/erts/emulator/beam/erl_nmgc.c b/erts/emulator/beam/erl_nmgc.c new file mode 100644 index 0000000000..626d4e295a --- /dev/null +++ b/erts/emulator/beam/erl_nmgc.c @@ -0,0 +1,1402 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2004-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif +#include "global.h" +#include "erl_gc.h" +#include "erl_binary.h" +#include "erl_nmgc.h" +#include "erl_debug.h" +#if HIPE +#include "hipe_bif0.h" /* for hipe_constants_{start,next} */ +#include "hipe_stack.h" +#endif + + +#ifdef INCREMENTAL +/*************************************************************************** + * * + * Incremental Garbage Collector for the Message Area * + * * + ***************************************************************************/ + +/* + * The heap pointers are declared in erl_init.c + * global_heap is the nursery + * global_old_heap is the old generation + */ +unsigned char *blackmap = NULL; +INC_Page *inc_used_mem = NULL; +INC_MemBlock *inc_free_list = NULL; +Eterm *inc_fromspc; +Eterm *inc_fromend; +Eterm *inc_nursery_scn_ptr; +Eterm **fwdptrs; +Eterm *inc_alloc_limit; +Process *inc_active_proc; +Process *inc_active_last; +int inc_words_to_go; + +static Eterm *inc_last_nursery; +static int inc_pages = INC_NoPAGES; +static INC_Page *inc_bibop = NULL; +static int inc_used_pages; + +/* Used when growing the old generation */ +/* +#define INC_ROOTSAVE 16384 +static Eterm *root_save[INC_ROOTSAVE]; +static int roots_saved = 0; +*/ + +INC_STORAGE_DECLARATION(,gray); + +static void inc_minor_gc(Process *p, int need, Eterm* objv, int nobj); +static void inc_major_gc(Process *p, int need, Eterm* objv, int nobj); + +#ifdef INC_TIME_BASED +#if USE_PERFCTR + +/* + * This uses the Linux perfctr extension to virtualise the + * time-stamp counter. + */ +#include "libperfctr.h" +static struct vperfctr *vperfctr; +static double cpu_khz; +static double tsc_to_cpu_mult; + +static void inc_start_hrvtime(void) +{ + struct perfctr_info info; + struct vperfctr_control control; + + if( vperfctr != NULL ) + return; + vperfctr = vperfctr_open(); + if( vperfctr == NULL ) + return; + if( vperfctr_info(vperfctr, &info) >= 0 ) { + cpu_khz = (double)info.cpu_khz; + tsc_to_cpu_mult = (double)(info.tsc_to_cpu_mult ? : 1); + if( info.cpu_features & PERFCTR_FEATURE_RDTSC ) { + memset(&control, 0, sizeof control); + control.cpu_control.tsc_on = 1; + if( vperfctr_control(vperfctr, &control) >= 0 ) + return; + } + } + vperfctr_close(vperfctr); + vperfctr = NULL; +} + +#define inc_get_hrvtime() (((double)vperfctr_read_tsc(vperfctr) * tsc_to_cpu_mult) / cpu_khz) + +#endif /* USE_PERFCTR */ +#endif /* INC_TIME_BASED */ + +#ifdef INC_TIME_BASED +# define timeslice 1 /* milli seconds */ +# define WORK_MORE (inc_get_hrvtime() < start_time + timeslice) +#else +//# define inc_min_work 100 /* words */ +# define inc_min_work global_heap_sz + inc_pages * INC_FULLPAGE /* words */ +# define WORK_MORE (inc_words_to_go > 0) +#endif + +void erts_init_incgc(void) +{ + int i; + int size = inc_pages * INC_FULLPAGE; + + /* Young generation */ + global_heap = (Eterm *)erts_alloc(ERTS_ALC_T_MESSAGE_AREA, + sizeof(Eterm) * global_heap_sz); + global_hend = global_heap + global_heap_sz; + global_htop = global_heap; + inc_alloc_limit = global_hend; + + /* Fromspace */ + inc_last_nursery = (Eterm *) erts_alloc(ERTS_ALC_T_MESSAGE_AREA, + global_heap_sz * sizeof(Eterm)); + inc_fromspc = inc_fromend = NULL; + + /* Forward-pointers */ + fwdptrs = erts_alloc(ERTS_ALC_T_MESSAGE_AREA, + global_heap_sz * sizeof(Eterm*)); + /* Old generation */ + global_old_heap = (Eterm *)erts_alloc(ERTS_ALC_T_MESSAGE_AREA, + size * sizeof(Eterm)); + global_old_hend = global_old_heap + size; + + /* Pages i BiBOP */ + for (i = 0; i < inc_pages; i++) + { + INC_Page *this = (INC_Page*)(global_old_heap + i * INC_FULLPAGE); + this->next = (INC_Page*)((Eterm*)this + INC_FULLPAGE); + } + + inc_bibop = (INC_Page*)global_old_heap; + ((INC_Page*)(global_old_heap + (inc_pages - 1) * INC_FULLPAGE))->next = + NULL; + + inc_used_mem = inc_bibop; + inc_bibop = inc_bibop->next; + inc_used_mem->next = NULL; + inc_used_pages = 1; + + /* Free-list */ + inc_free_list = (INC_MemBlock*)inc_used_mem->start; + inc_free_list->size = INC_PAGESIZE; + inc_free_list->prev = NULL; + inc_free_list->next = NULL; + + /* Blackmap */ + blackmap = (unsigned char*)erts_alloc(ERTS_ALC_T_MESSAGE_AREA, + INC_FULLPAGE * inc_pages); + /* Gray stack */ + INC_STORAGE_INIT(gray); + + inc_active_proc = NULL; + inc_active_last = NULL; + +#ifdef INC_TIME_BASED + inc_start_hrvtime(); +#endif +} + +void erts_cleanup_incgc(void) +{ + INC_STORAGE_ERASE(gray); + + if (inc_fromspc) + inc_last_nursery = inc_fromspc; + + erts_free(ERTS_ALC_T_MESSAGE_AREA,(void*)global_heap); + erts_free(ERTS_ALC_T_MESSAGE_AREA,(void*)inc_last_nursery); + erts_free(ERTS_ALC_T_MESSAGE_AREA,(void*)global_old_heap); + erts_free(ERTS_ALC_T_MESSAGE_AREA,(void*)blackmap); + erts_free(ERTS_ALC_T_MESSAGE_AREA,(void*)fwdptrs); +} + +void erts_incremental_gc(Process* p, int need, Eterm* objv, int nobj) +{ + int repeat_minor; +#ifdef INC_TIME_BASED + double start_time = inc_get_hrvtime(); + int work_left_before = inc_words_to_go; +#endif + /* Used when growing the fromspace */ + static char inc_growing_nurs = 0; + + BM_STOP_TIMER(system); + //BM_MMU_READ(); + BM_RESET_TIMER(gc); + BM_START_TIMER(gc); + + VERBOSE(DEBUG_HYBRID_GC, + ("INCGC: Incremental GC START Caused by: %T Need: %d\n", + p->id,need)); + + ma_gc_flags |= GC_GLOBAL; + ma_gc_flags &= ~GC_CYCLE_START; + +#ifndef INC_TIME_BASED + /* Decide how much work to do this GC stage. The work is meassured + * in number of words copied from the young generation to the old + * plus number of work marked in the old generation. + */ + if (ma_gc_flags & GC_MAJOR) { + int wm = (need > inc_min_work) ? need : inc_min_work; + inc_words_to_go = (int)((wm * (((inc_used_pages * INC_PAGESIZE) / + (double)global_heap_sz) + 1)) + 0.5); + } + else + inc_words_to_go = (need > inc_min_work) ? need : inc_min_work; +#endif + + do { + if (ma_gc_flags & GC_MAJOR) { + /* This is a major collection cycle. */ + inc_major_gc(p,need,objv,nobj); + } else if (ma_gc_flags & GC_CYCLE) { + /* This is a minor collection cycle. */ + inc_minor_gc(p,need,objv,nobj); + } else { + VERBOSE(DEBUG_HYBRID_GC,("INCGC: Collection cycle START\n")); + ma_gc_flags |= (GC_CYCLE | GC_CYCLE_START); + inc_fromspc = global_heap; + inc_fromend = global_htop; + global_heap = global_htop = inc_last_nursery; + global_hend = global_heap + global_heap_sz; + inc_nursery_scn_ptr = global_heap; +#ifdef INC_TIME_BASED + work_left_before = inc_words_to_go = global_heap_sz; +#endif +#ifdef DEBUG + inc_last_nursery = NULL; +#endif + memset(fwdptrs,0,global_heap_sz * sizeof(Eterm)); + + { + /* TODO: Alla processer ska väl egentligen inte aktiveras här... */ + int i; + for (i = 0; i < erts_num_active_procs; i++) { + Process *cp = erts_active_procs[i]; + INC_ACTIVATE(cp); + cp->scan_top = cp->high_water; + } + } + + if (ma_gc_flags & GC_NEED_MAJOR) { + /* The previous collection cycle caused the old generation to + * overflow. This collection cycle will therefore be a major + * one. + */ + BM_COUNT(major_gc_cycles); + VERBOSE(DEBUG_HYBRID_GC,("INCGC: MAJOR cycle\n")); + inc_major_gc(p,need,objv,nobj); + } else { + BM_COUNT(minor_gc_cycles); + VERBOSE(DEBUG_HYBRID_GC,("INCGC: MINOR cycle\n")); + inc_minor_gc(p,need,objv,nobj); + } + } + + repeat_minor = 0; + if (!(ma_gc_flags & GC_CYCLE)) { + inc_alloc_limit = global_hend; + inc_last_nursery = inc_fromspc; + inc_fromspc = inc_fromend = NULL; + ASSERT(INC_STORAGE_EMPTY(gray)); + + if (inc_growing_nurs) { + /* + * The previous collection cycle caused the nursery to + * grow, now we have to grow the from-space as well. + */ + inc_last_nursery = + (Eterm*) erts_realloc(ERTS_ALC_T_MESSAGE_AREA, + (void*)inc_last_nursery, + sizeof(Eterm) * global_heap_sz); + inc_growing_nurs = 0; + } + + if (global_hend - global_htop <= need) { + /* + * Initiate a new GC cycle immediately and, if necessary, + * enlarge the nursery. + */ + if (global_heap_sz <= need) { + VERBOSE(DEBUG_HYBRID_GC, + ("INCGC: Allocating a larger nursery\n")); + global_heap_sz = erts_next_heap_size(need * 1.5,0); + inc_last_nursery = + (Eterm*) erts_realloc(ERTS_ALC_T_MESSAGE_AREA, + (void*)inc_last_nursery, + sizeof(Eterm) * global_heap_sz); + fwdptrs = erts_realloc(ERTS_ALC_T_MESSAGE_AREA,fwdptrs, + global_heap_sz * sizeof(Eterm*)); + inc_growing_nurs = 1; + } + repeat_minor = 1; + } + +#ifdef DEBUG + /* Fill the from-space with bad things */ + memset(inc_last_nursery,DEBUG_BAD_BYTE, + global_heap_sz * sizeof(Eterm)); +#endif + } + } while (repeat_minor); + + + /* Clean up after garbage collection ********************************/ + + if (inc_alloc_limit != global_hend) { + +#ifdef INC_TIME_BASED + if ((work_left_before - inc_words_to_go) == 0) { + inc_alloc_limit = global_htop + need; + } else { + inc_alloc_limit = (global_hend - global_htop) / + (inc_words_to_go / (work_left_before - inc_words_to_go)) + + global_htop; + if (inc_alloc_limit > global_hend) + inc_alloc_limit = global_hend; + } +#else + inc_alloc_limit = (Eterm*)(global_htop + (need > inc_min_work) ? + need : inc_min_work); + if (inc_alloc_limit > global_hend) + inc_alloc_limit = global_hend; +#endif + } + + ma_gc_flags &= ~GC_GLOBAL; + + /* INC_TIME_BASED: If this fails we have to increase the timeslice! */ + ASSERT(inc_alloc_limit - global_htop > need); + + BM_STOP_TIMER(gc); +#ifdef BM_TIMERS + minor_global_gc_time += gc_time; + if (gc_time > max_global_minor_time) + max_global_minor_time = gc_time; + + pause_times[(((gc_time * 1000) < MAX_PAUSE_TIME) ? + (int)(gc_time * 1000) : + MAX_PAUSE_TIME - 1)]++; +#endif + //BM_MMU_INIT(); + { static long long verif = 0; + //erts_printf("innan verify: %d\n",++verif); + if (verif==168) print_memory(NULL); + verify_everything(); + //erts_printf("efter verify: %d\n",verif); + } + BM_START_TIMER(system); + VERBOSE(DEBUG_HYBRID_GC,("INCGC: Incremental GC END\n")); +} + + +/*************************************************************************** + * * + * Minor collection - Copy live data from young generation to old * + * * + ***************************************************************************/ + +#define MINOR_SCAN(PTR,END) do { \ + ASSERT(PTR <= END); \ + while (WORK_MORE && PTR < END) { \ + Eterm val = *PTR; \ + Eterm *obj_ptr = ptr_val(val); \ + switch (primary_tag(val)) { \ + case TAG_PRIMARY_LIST: \ + if (ptr_within(obj_ptr,inc_fromspc,inc_fromend)) { \ + if (INC_IS_FORWARDED(obj_ptr)) { \ + *PTR = make_list(INC_FORWARD_VALUE(obj_ptr)); \ + } \ + else { \ + Eterm *hp = erts_inc_alloc(2); \ + INC_STORE(gray,hp,2); \ + INC_COPY_CONS(obj_ptr,hp,PTR); \ + } \ + } \ + break; \ + case TAG_PRIMARY_BOXED: \ + if (ptr_within(obj_ptr,inc_fromspc,inc_fromend)) { \ + if (INC_IS_FORWARDED(obj_ptr)) { \ + *PTR = make_boxed(INC_FORWARD_VALUE(obj_ptr)); \ + } \ + else { \ + Eterm *hp = erts_inc_alloc(BOXED_NEED(obj_ptr,*obj_ptr)); \ + INC_STORE(gray,hp,BOXED_NEED(obj_ptr,*obj_ptr)); \ + INC_COPY_BOXED(obj_ptr,hp,PTR); \ + } \ + } \ + break; \ + case TAG_PRIMARY_HEADER: \ + switch (val & _TAG_HEADER_MASK) { \ + case ARITYVAL_SUBTAG: break; \ + default: PTR += thing_arityval(val); break; \ + } \ + break; \ + } \ + PTR++; \ + } \ +} while(0) + + +/* Returns: TRUE (1) if the need is greater than the available space + * and the garbage collector needs to be restarted immediately. FALSE + * (0) otherwise. + */ +static void inc_minor_gc(Process* p, int need, Eterm* objv, int nobj) +{ + BM_COUNT(minor_gc_stages); + + /* Start with looking at gray objects found in earlier collection + * stages. + */ + VERBOSE(DEBUG_HYBRID_GC,("INCGC: Rescue gray found from nursery\n")); + { + INC_Object *obj = NULL; + Eterm *ptr; + + while (WORK_MORE && !INC_STORAGE_EMPTY(gray)) { + obj = INC_STORAGE_GET(gray); + if ((*obj->this & _TAG_HEADER_MASK) == FUN_SUBTAG) { + ptr = obj->this + thing_arityval(*obj->this) + 1; + } else { + ptr = obj->this; + } + MINOR_SCAN(ptr,obj->this + obj->size); + } + /* TODO: Se föregående uppdatering av grå objekt */ + if (!WORK_MORE && obj != NULL) + INC_STORE(gray,obj->this,obj->size); + } + + VERBOSE(DEBUG_HYBRID_GC,("INCGC: Scan root-set\n")); + while (WORK_MORE && inc_active_proc) { + Rootset rootset; + Process *cp = inc_active_proc; + + ASSERT(INC_IS_ACTIVE(cp)); + + /* TODO: Hur dyrt är det att bygga nytt rootset varje gång? */ + + /* TODO: Fundera på ordningen! Rootset, Heap, Old heap... */ + + /* TODO: Scanna stacken från p->send till p->stop! [Brooks84] */ + /* Notera: Vi GC:ar inte de yngsta objekten - de som allokeras + under GC-cykeln. Detta ger ynglingarna en chans att dö innan + GC:n börjar kopiera dem. [StefanovicMcKinleyMoss@OOPSLA99] */ + + /* TODO: När rootset är scannat borde processen inte vara + aktiv mer. Den bör aktiveras i schedule, endast om en + process har kört behöver vi scanna rootset igen. */ + + /* MT: In a multithreaded system the process cp needs to be + * locked here. + */ + + if (cp == p) + rootset.n = setup_rootset(cp, objv, nobj, &rootset); + else + rootset.n = setup_rootset(cp, cp->arg_reg, cp->arity, &rootset); + + //MA_GENSWEEP_NSTACK(cp, old_htop, n_htop, objv, nobj); + + while (WORK_MORE && rootset.n--) { + Eterm *g_ptr = rootset.v[rootset.n]; + Uint g_sz = rootset.sz[rootset.n]; + + while (WORK_MORE && g_sz--) { + Eterm gval = *g_ptr; + switch (primary_tag(gval)) { + case TAG_PRIMARY_LIST: { + Eterm *ptr = list_val(gval); + if (ptr_within(ptr,inc_fromspc,inc_fromend)) { + if (INC_IS_FORWARDED(ptr)) { + *g_ptr++ = make_list(INC_FORWARD_VALUE(ptr)); + } + else { + Eterm *hp = erts_inc_alloc(2); + INC_STORE(gray,hp,2); + INC_COPY_CONS(ptr,hp,g_ptr++); + } + } + else + ++g_ptr; + continue; + } + + case TAG_PRIMARY_BOXED: { + Eterm *ptr = boxed_val(gval); + if (ptr_within(ptr,inc_fromspc,inc_fromend)) { + if (INC_IS_FORWARDED(ptr)) { + *g_ptr++ = make_boxed(INC_FORWARD_VALUE(ptr)); + } + else { + Eterm *hp = erts_inc_alloc(BOXED_NEED(ptr,*ptr)); + INC_STORE(gray,hp,BOXED_NEED(ptr,*ptr)); + INC_COPY_BOXED(ptr,hp,g_ptr++); + } + } + else + ++g_ptr; + continue; + } + + default: + g_ptr++; + continue; + } + } + } + + restore_one_rootset(cp, &rootset); + + /* MT: cp can be unlocked now. */ + + /* VERBOSE(DEBUG_HYBRID_GC,("INCGC: Scan private nursery\n")); */ + if (cp->scan_top != HEAP_TOP(cp)) { + Eterm *ptr = cp->scan_top; + MINOR_SCAN(ptr,HEAP_TOP(cp)); + /* TODO: För att spara scan_top här måste alla ma-pekare + * som hittas läggas till i cp->rrma. + */ + //cp->scan_top = ptr; + } + + /* VERBOSE(DEBUG_HYBRID_GC,("INCGC: Scan heap fragments\n")); */ + { + ErlHeapFragment* bp = MBUF(cp); + + while (WORK_MORE && bp) { + Eterm *ptr = bp->mem; + if ((ARITH_HEAP(cp) >= bp->mem) && + (ARITH_HEAP(cp) < bp->mem + bp->size)) { + MINOR_SCAN(ptr,ARITH_HEAP(cp)); + } else { + MINOR_SCAN(ptr,bp->mem + bp->size); + } + bp = bp->next; + } + } + + /* VERBOSE(DEBUG_HYBRID_GC,("INCGC: Scan gray\n")); */ + { + INC_Object *obj = NULL; + Eterm *ptr; + while (WORK_MORE && !INC_STORAGE_EMPTY(gray)) { + obj = INC_STORAGE_GET(gray); + if ((*obj->this & _TAG_HEADER_MASK) == FUN_SUBTAG) { + ptr = obj->this + thing_arityval(*obj->this) + 1; + } else { + ptr = obj->this; + } + MINOR_SCAN(ptr,obj->this + obj->size); + } + /* TODO: INC_STORE(gray,ptr,obj->size-(ptr-obj->this)); Typ.. */ + if (!WORK_MORE && obj != NULL) + INC_STORE(gray,obj->this,obj->size); + } + + if (WORK_MORE) { + //printf("Rootset after:\r\n"); + //print_one_rootset(&rootset); + INC_DEACTIVATE(cp); + } + } + + /* Update new pointers in the nursery to new copies in old generation. */ + VERBOSE(DEBUG_HYBRID_GC,("INCGC: Update nursery\n")); + { + Eterm *ptr = inc_nursery_scn_ptr; + MINOR_SCAN(ptr,global_htop); + inc_nursery_scn_ptr = ptr; + } + + VERBOSE(DEBUG_HYBRID_GC,("INCGC: Rescue gray found from nursery\n")); + { + INC_Object *obj = NULL; + Eterm *ptr; + + while (WORK_MORE && !INC_STORAGE_EMPTY(gray)) { + obj = INC_STORAGE_GET(gray); + if ((*obj->this & _TAG_HEADER_MASK) == FUN_SUBTAG) { + ptr = obj->this + thing_arityval(*obj->this) + 1; + } else { + ptr = obj->this; + } + MINOR_SCAN(ptr,obj->this + obj->size); + } + /* TODO: Se föregående uppdatering av grå objekt */ + if (!WORK_MORE && obj != NULL) + INC_STORE(gray,obj->this,obj->size); + } + + /* Atomic phase */ + VERBOSE(DEBUG_HYBRID_GC,("INCGC: Update copy stack\n")); + { + Uint i; + for (i = 0; i < ma_dst_top; i++) { + if (ptr_within(ma_dst_stack[i],inc_fromspc,inc_fromend)) { + if (INC_IS_FORWARDED(ma_dst_stack[i])) + ma_dst_stack[i] = INC_FORWARD_VALUE(ma_dst_stack[i]); + } + } + } + + if (WORK_MORE) { + VERBOSE(DEBUG_HYBRID_GC,("INCGC: Update offheap-lists\n")); + { + ExternalThing **prev = &erts_global_offheap.externals; + ExternalThing *ptr = erts_global_offheap.externals; + + /* Atomic phase */ + VERBOSE(DEBUG_HYBRID_GC,("INCGC: Sweep proc externals\n")); + while (ptr) { + Eterm *ppt = (Eterm*) ptr; + + if (ptr_within(ppt,global_old_heap,global_old_hend)) { + prev = &ptr->next; + ptr = ptr->next; + } else if (ptr_within(ppt, inc_fromspc, inc_fromend) && + INC_IS_FORWARDED(ppt)) { + ExternalThing *ro = (ExternalThing*)INC_FORWARD_VALUE(ppt); + *prev = ro; /* Patch to moved pos */ + prev = &ro->next; + ptr = ro->next; + } else { + erts_deref_node_entry(ptr->node); + *prev = ptr = ptr->next; + } + } + ASSERT(*prev == NULL); + } + + { + ProcBin **prev = &erts_global_offheap.mso; + ProcBin *ptr = erts_global_offheap.mso; + + /* Atomic phase */ + VERBOSE(DEBUG_HYBRID_GC,("INCGC: Sweep proc bins\n")); + while (ptr) { + Eterm *ppt = (Eterm*)ptr; + + if (ptr_within(ppt,global_old_heap,global_old_hend)) { + prev = &ptr->next; + ptr = ptr->next; + } else if (ptr_within(ppt, inc_fromspc, inc_fromend) && + INC_IS_FORWARDED(ppt)) { + ProcBin *ro = (ProcBin*)INC_FORWARD_VALUE(ppt); + *prev = ro; /* Patch to moved pos */ + prev = &ro->next; + ptr = ro->next; + } else { + Binary *bptr; + *prev = ptr->next; + bptr = ptr->val; + if (erts_refc_dectest(&bptr->refc, 0) == 0) + erts_bin_free(bptr); + ptr = *prev; + } + } + ASSERT(*prev == NULL); + } + + VERBOSE(DEBUG_HYBRID_GC,("INCGC: Minor collection cycle END\n")); + ma_gc_flags &= ~GC_CYCLE; + } +} + + + + +/*************************************************************************** + * * + * Major collection - CopyMark - Copy young to old, Mark-Sweep old * + * * + ***************************************************************************/ + +#define COPYMARK(PTR,END) do { \ + ASSERT(PTR <= END); \ + while (WORK_MORE && PTR < END) { \ + Eterm val = *PTR; \ + Eterm *obj_ptr = ptr_val(val); \ + switch (primary_tag(val)) { \ + case TAG_PRIMARY_LIST: \ + COPYMARK_CONS(obj_ptr,aging_htop,PTR,aging_end); break; \ + case TAG_PRIMARY_BOXED: \ + COPYMARK_BOXED(obj_ptr,aging_htop,PTR,aging_end); break; \ + case TAG_PRIMARY_HEADER: \ + switch (val & _TAG_HEADER_MASK) { \ + case ARITYVAL_SUBTAG: break; \ + default: \ + PTR += thing_arityval(val); \ + break; \ + } \ + break; \ + default: break; \ + } \ + PTR++; \ + } \ +} while(0); +/* TODO: + if (aging_htop + 10 > aging + INC_FULLPAGE) { + aging->next = inc_used_mem; + inc_used_mem = aging; + } +*/ + +static void inc_major_gc(Process *p, int need, Eterm* objv, int nobj) +{ + Eterm *free_start = NULL; + Uint live = 0; + Uint old_gen_sz = 0; + static INC_Page *aging; + static Eterm *aging_htop; + static Eterm *aging_end; + BM_NEW_TIMER(old_gc); + + BM_SWAP_TIMER(gc,old_gc); + BM_COUNT(major_gc_stages); + + VERBOSE(DEBUG_HYBRID_GC,("INCGC: Major collection START\n")); + + ma_gc_flags |= GC_INCLUDE_ALL; + + if (ma_gc_flags & GC_NEED_MAJOR) + { + INC_Page *page = inc_used_mem; + + ma_gc_flags |= GC_MAJOR; + ma_gc_flags &= ~GC_NEED_MAJOR; + + while (page) + { + memset(blackmap + + ((void*)page - (void*)global_old_heap) / sizeof(void*), + 0, INC_FULLPAGE); + page = page->next; + } + + if (inc_bibop) { + aging = inc_bibop; + inc_bibop = inc_bibop->next; + aging->next = NULL; + memset(blackmap + + ((void*)aging - (void*)global_old_heap) / sizeof(void*), + 1, INC_FULLPAGE); + aging_htop = aging->start; + aging_end = aging->start + INC_PAGESIZE; + } + else { + /* There are no free pages.. Either fragmentation is a + * problem or we are simply out of memory. Allocation in + * the old generation will be done through the free-list + * this GC cycle. + */ + aging = NULL; + aging_htop = aging_end = NULL; + } + } + + /* Start with looking at gray objects found in earlier collection + * stages. + */ + VERBOSE(DEBUG_HYBRID_GC,("INCGC: Copy-Mark gray\n")); + { + INC_Object *obj = NULL; + + while (WORK_MORE && !INC_STORAGE_EMPTY(gray)) { + Eterm *ptr; + + obj = INC_STORAGE_GET(gray); + if ((*obj->this & _TAG_HEADER_MASK) == FUN_SUBTAG) { + ptr = obj->this + thing_arityval(*obj->this) + 1; + } else { + ptr = obj->this; + } + COPYMARK(ptr,obj->this + obj->size); + } + /* TODO: Titta på motsvarande i minor. */ + if (!WORK_MORE && obj != NULL) + INC_STORE(gray,obj->this,obj->size); + } + + VERBOSE(DEBUG_HYBRID_GC,("INCGC: Copy-Mark roots\n")); + while (WORK_MORE && inc_active_proc) + { + /* For each process: Scan all areas containing pointers to the + * message area. When a process is done here, all it's + * message-pointers should be to the old generation. + */ + Rootset rootset; + Process *cp = inc_active_proc; + + ASSERT(INC_IS_ACTIVE(cp)); + + /* MT: In a multithreaded system the process cp needs to be + * locked here. + */ + if (cp == p) + rootset.n = setup_rootset(cp, objv, nobj, &rootset); + else + rootset.n = setup_rootset(cp, cp->arg_reg, cp->arity, &rootset); + + while (WORK_MORE && rootset.n--) + { + Eterm *ptr = rootset.v[rootset.n]; + Eterm *end = ptr + rootset.sz[rootset.n]; + + while (WORK_MORE && ptr < end) { + Eterm val = *ptr; + Eterm *obj_ptr = ptr_val(val); + + switch (primary_tag(val)) { + case TAG_PRIMARY_LIST: + { + COPYMARK_CONS(obj_ptr,aging_htop,ptr,aging_end); + break; + } + + case TAG_PRIMARY_BOXED: + { + COPYMARK_BOXED(obj_ptr,aging_htop,ptr,aging_end); + break; + } + } + ptr++; + } + } + +#ifdef HIPE + /* Atomic phase */ + VERBOSE(DEBUG_HYBRID_GC,("INCGC: Native stack scan: %T\n",cp->id)); + aging_htop = ma_fullsweep_nstack(cp,aging_htop,aging_end); +#endif + restore_one_rootset(cp, &rootset); + + /* MT: cp can be unlocked now. But beware!! The message queue + * might be updated with new pointers to the fromspace while + * we work below. The send operation can not assume that all + * active processes will look through their message queue + * before deactivating as is the case in non-MT incremental + * collection. + */ + + VERBOSE(DEBUG_HYBRID_GC,("INCGC: Copy-Mark process heap\n")); + { + Eterm *ptr = cp->scan_top; + COPYMARK(ptr,cp->htop); + //cp->scan_top = ptr; + } + + VERBOSE(DEBUG_HYBRID_GC,("INCGC: Copy-Mark heap fragments\n")); + { + ErlHeapFragment* bp = MBUF(cp); + + while (WORK_MORE && bp) { + Eterm *ptr = bp->mem; + Eterm *end; + + if ((ARITH_HEAP(cp) >= bp->mem) && + (ARITH_HEAP(cp) < bp->mem + bp->size)) { + end = ARITH_HEAP(cp); + } else { + end = bp->mem + bp->size; + } + + COPYMARK(ptr,end); + bp = bp->next; + } + } + + VERBOSE(DEBUG_HYBRID_GC,("INCGC: Copy-Mark gray stack\n")); + { + INC_Object *obj = NULL; + + while (WORK_MORE && !INC_STORAGE_EMPTY(gray)) { + Eterm *ptr; + + obj = INC_STORAGE_GET(gray); + if ((*obj->this & _TAG_HEADER_MASK) == FUN_SUBTAG) { + ptr = obj->this + thing_arityval(*obj->this) + 1; + } else { + ptr = obj->this; + } + COPYMARK(ptr,obj->this + obj->size); + } + /* TODO: Titta på motsvarande i minor. */ + if (!WORK_MORE && obj != NULL) + INC_STORE(gray,obj->this,obj->size); + } + + if (WORK_MORE) { + INC_DEACTIVATE(cp); + } + } + + VERBOSE(DEBUG_HYBRID_GC,("INCGC: Copy-Mark nursery\n")); + { + Eterm *ptr = inc_nursery_scn_ptr; + COPYMARK(ptr,global_htop); + inc_nursery_scn_ptr = ptr; + } + + VERBOSE(DEBUG_HYBRID_GC,("INCGC: Copy-Mark gray found in nursery\n")); + { + INC_Object *obj = NULL; + + while (WORK_MORE && !INC_STORAGE_EMPTY(gray)) { + Eterm *ptr; + + obj = INC_STORAGE_GET(gray); + if ((*obj->this & _TAG_HEADER_MASK) == FUN_SUBTAG) { + ptr = obj->this + thing_arityval(*obj->this) + 1; + } else { + ptr = obj->this; + } + COPYMARK(ptr,obj->this + obj->size); + } + /* TODO: Titta på motsvarande i minor. */ + if (!WORK_MORE && obj != NULL) + INC_STORE(gray,obj->this,obj->size); + } + + + /**********************************************************************/ + if (WORK_MORE) { + VERBOSE(DEBUG_HYBRID_GC,("INCGC: Sweep phase\n")); + + /* Atomic phase */ + VERBOSE(DEBUG_HYBRID_GC,("INCGC: Sweep externals in old generation\n")); + { + ExternalThing** prev = &erts_global_offheap.externals; + ExternalThing* ptr = erts_global_offheap.externals; + + while (ptr) { + Eterm* ppt = (Eterm *) ptr; + + if ((ptr_within(ppt, global_old_heap, global_old_hend) && + blackmap[ppt - global_old_heap] == 0) || + (ptr_within(ppt, inc_fromspc, inc_fromend) && + !INC_IS_FORWARDED(ppt))) + { + erts_deref_node_entry(ptr->node); + *prev = ptr = ptr->next; + } else if (ptr_within(ppt, inc_fromspc, inc_fromend)) { + ExternalThing* ro = (ExternalThing*)INC_FORWARD_VALUE(ppt); + *prev = ro; /* Patch to moved pos */ + prev = &ro->next; + ptr = ro->next; + } else { + prev = &ptr->next; + ptr = ptr->next; + } + } + ASSERT(*prev == NULL); + } + + /* Atomic phase */ + VERBOSE(DEBUG_HYBRID_GC,("INCGC: Sweep refc bins in old generation\n")); + { + ProcBin** prev = &erts_global_offheap.mso; + ProcBin* ptr = erts_global_offheap.mso; + + while (ptr) { + Eterm *ppt = (Eterm*)ptr; + + if ((ptr_within(ppt, global_old_heap, global_old_hend) && + blackmap[ppt - global_old_heap] == 0) || + (ptr_within(ppt, inc_fromspc, inc_fromend) && + !INC_IS_FORWARDED(ppt))) + { + Binary* bptr; + *prev = ptr->next; + bptr = ptr->val; + if (erts_refc_dectest(&bptr->refc, 0) == 0) + erts_bin_free(bptr); + ptr = *prev; + } else if (ptr_within(ppt, inc_fromspc, inc_fromend)) { + ProcBin* ro = (ProcBin*)INC_FORWARD_VALUE(ppt); + *prev = ro; /* Patch to moved pos */ + prev = &ro->next; + ptr = ro->next; + } else { + prev = &ptr->next; + ptr = ptr->next; + } + } + ASSERT(*prev == NULL); + } + + /* TODO: Currently atomic phase - Can not be later of course. */ + VERBOSE(DEBUG_HYBRID_GC,("INCGC: Sweep old generation\n")); + { + INC_Page *page = inc_used_mem; + INC_Page *prev = NULL; + inc_free_list = NULL; + + while (page) { + int scavenging = 0; + int n = page->start - global_old_heap; + int stop = n + INC_PAGESIZE; + + old_gen_sz += INC_PAGESIZE; + while (n < stop) { + if (blackmap[n] != 0) { + if (scavenging) { + Eterm *ptr = global_old_heap + n; + scavenging = 0; + if ((ptr - free_start) * sizeof(Eterm) >= + sizeof(INC_MemBlock)) + { + INC_MemBlock *new = (INC_MemBlock*)free_start; + new->size = ptr - free_start; + new->prev = NULL; + new->next = inc_free_list; + if (inc_free_list) + inc_free_list->prev = new; + inc_free_list = new; + } + } + if (blackmap[n] == 255) { + unsigned int size = + *(unsigned int*)(((long)&blackmap[n]+4) & ~3); + live += size; + n += size; + } + else { + live += blackmap[n]; + n += blackmap[n]; + } + } + else if (!scavenging) { + free_start = global_old_heap + n; + scavenging = 1; + n++; + } + else { + n++; + } + } + + if (scavenging) { + if ((global_old_heap + n - free_start) * sizeof(Eterm) > + sizeof(INC_MemBlock)) + { + INC_MemBlock *new = (INC_MemBlock*)free_start; + new->size = global_old_heap + n - free_start; + new->prev = NULL; + new->next = inc_free_list; + if (inc_free_list) + inc_free_list->prev = new; + inc_free_list = new; + } + else if (free_start == page->start) { + INC_Page *next = page->next; + + if (prev) + prev->next = page->next; + else + inc_used_mem = page->next; + + page->next = inc_bibop; + inc_bibop = page; + inc_used_pages--; + page = next; + continue; + } + } + prev = page; + page = page->next; + } + } + } + + ASSERT(inc_bibop); + /* + This code is not expected to work right now. + if (!inc_bibop) { + int i; + int new_pages = inc_pages * 2; + int size = sizeof(Eterm) * new_pages * INC_FULLPAGE; + Eterm *new_heap = erts_alloc(ERTS_ALC_T_MESSAGE_AREA,size); + Eterm *new_hend = new_heap + size; + Eterm *new_htop; + Eterm *last_page_end; + INC_Page *new_used_mem; + INC_Page *page; + + erts_printf("The last page has been allocated..\n"); + erts_printf("We need to copy things!\n"); + + / * Create new, bigger bag of pages * / + for (i = 0; i < new_pages; i++) + { + INC_Page *this = + (INC_Page*)(new_heap + i * INC_FULLPAGE); + this->next = (INC_Page*)((Eterm*)this + INC_FULLPAGE); + } + inc_bibop = (INC_Page*)new_heap; + ((INC_Page*)(new_heap + (new_pages - 1) * + INC_FULLPAGE))->next = NULL; + + new_used_mem = inc_bibop; + inc_bibop = inc_bibop->next; + new_used_mem->next = NULL; + + / * Move stuff from old bag to new * / + inc_free_list = NULL; + new_htop = new_used_mem->start; + last_page_end = new_htop + INC_PAGESIZE; + page = inc_used_mem; + while (page) + { + Eterm *ptr = page->start; + Eterm *page_end = ptr + INC_PAGESIZE; + int n = offsetof(INC_Page,start) / sizeof(void*) + + ((Eterm*)page - global_old_heap); + while (ptr < page_end) + { + if (blackmap[n] > 0) + { + if (last_page_end - new_htop < blackmap[n]) + { + INC_Page *new_page = inc_bibop; + inc_bibop = inc_bibop->next; + new_page->next = new_used_mem; + new_used_mem = new_page; + new_htop = new_page->start; + last_page_end = new_htop + INC_PAGESIZE; + } + + memcpy(new_htop,ptr,blackmap[n] * sizeof(Eterm)); + for (i = 0; i < blackmap[n]; i++) + { + *ptr++ = (Eterm)new_htop++; + } + //new_htop += blackmap[n]; + //ptr += blackmap[n]; + / * + if (blackmap[n] == 255) Do the right thing... + * / + n += blackmap[n]; + } + else + { + n++; ptr++; + } + } + page = page->next; + } + + page = inc_used_mem; + while (page) + { + Eterm *ptr = page->start; + Eterm *page_end = ptr + INC_PAGESIZE; + + / * TODO: If inc_used_mem is sorted in address order, this + * pass can be done at the same time as copying. * / + while (ptr < page_end) + { + if (ptr_within(ptr_val(*ptr),global_old_heap,global_old_hend)) + { + *ptr = *((Eterm*)ptr_val(*ptr)); + } + ptr++; + } + page = page->next; + } + + printf("Restore rootset after heap move. Roots: %d\r\n",roots_saved); + while (roots_saved--) + { + Eterm *ptr = root_save[roots_saved]; + *ptr = *((Eterm*)ptr_val(*ptr)); + } + + erts_free(ERTS_ALC_T_MESSAGE_AREA,(void*)global_old_heap); + + global_old_heap = new_heap; + global_old_hend = new_hend; + inc_used_mem = new_used_mem; + inc_pages = new_pages; + + if ((last_page_end - new_htop) * sizeof(Eterm) >= + sizeof(INC_MemBlock)) + { + inc_free_list = (INC_MemBlock*)(new_htop); + inc_free_list->size = last_page_end - new_htop; + inc_free_list->prev = NULL; + inc_free_list->next = NULL; + } + } + */ + + /* I vilka lägen kan vi vilja slänga på en extra sida.. ( < 25% kvar?) + if () + { + INC_Page *new_page = inc_bibop; + INC_MemBlock *new_free = + (INC_MemBlock*)new_page->start; + + VERBOSE(DEBUG_HYBRID_GC,("INCGC: Fetching new page\n")); + inc_bibop = inc_bibop->next; + + new_page->next = inc_used_mem; + if (inc_used_mem) + inc_used_mem->prev = new_page; + inc_used_mem = new_page; + + // kolla detta med normal sidstorlek! old_gen_sz += INC_PAGESIZE; + //BM_SWAP_TIMER(gc,misc1); + memset(blackmap + + ((void*)new_page - (void*)global_old_heap) / sizeof(void*), + 0, INC_FULLPAGE); + //BM_SWAP_TIMER(misc1,gc); + + new_free->prev = NULL; + new_free->next = inc_free_list; + new_free->size = INC_PAGESIZE; + if (inc_free_list) + inc_free_list->prev = new_free; + inc_free_list = new_free; + //printf("Snatched a new page @ 0x%08x\r\n",(int)new_page); + //print_free_list(); + found = new_free; + } + */ + + VERBOSE(DEBUG_HYBRID_GC,("INCGC: Update copy stack\n")); + { + Uint i; + for (i = 0; i < ma_dst_top; i++) { + if (ptr_within(ma_dst_stack[i],inc_fromspc,inc_fromend)) { + if (INC_IS_FORWARDED(ma_dst_stack[i])) + ma_dst_stack[i] = INC_FORWARD_VALUE(ma_dst_stack[i]); + } + } + } + + if (WORK_MORE) + { + int size_left = INC_PAGESIZE - (aging_htop - aging->start); + + if (size_left > sizeof(INC_MemBlock)) + { + ((INC_MemBlock*)aging_htop)->size = size_left; + ((INC_MemBlock*)aging_htop)->prev = NULL; + ((INC_MemBlock*)aging_htop)->next = inc_free_list; + if (inc_free_list) + inc_free_list->prev = (INC_MemBlock*)aging_htop; + inc_free_list = (INC_MemBlock*)aging_htop; + } + aging->next = inc_used_mem; + inc_used_mem = aging; + inc_used_pages++; + + ma_gc_flags &= ~GC_MAJOR; + ma_gc_flags &= ~GC_CYCLE; + + VERBOSE(DEBUG_HYBRID_GC,("INCGC: Major collection cycle END\n")); + } + + ma_gc_flags &= ~GC_INCLUDE_ALL; + + BM_STOP_TIMER(old_gc); +#ifdef BM_TIMER + major_global_gc_time += old_gc_time; + if (old_gc_time > max_global_major_time) + max_global_major_time = old_gc_time; + + if ((old_gc_time * 1000) < MAX_PAUSE_TIME) + pause_times_old[(int)(old_gc_time * 1000)]++; + else + pause_times_old[MAX_PAUSE_TIME - 1]++; +#endif + BM_START_TIMER(gc); +} + + + +/*************************************************************************** + * * + * Allocation in the old generation. Used in minor colection and when * + * copying the rest of a message after a GC. * + * * + ***************************************************************************/ + + +Eterm *erts_inc_alloc(int need) +{ + INC_MemBlock *this = inc_free_list; + + ASSERT(need < INC_PAGESIZE); + while (this && (this->size) < need) + { + this = this->next; + } + + if (!this) + { + /* If a free block large enough is not found, a new page is + * allocated. GC_NEED_MAJOR is set so that the next garbage + * collection cycle will be a major one, that is, both + * generations will be garbage collected. + */ + INC_Page *new_page = inc_bibop; + INC_MemBlock *new_free = (INC_MemBlock*)new_page->start; + + if (new_page) + { + VERBOSE(DEBUG_HYBRID_GC, + ("INCGC: Allocation grabs a new page\n")); + inc_bibop = inc_bibop->next; + new_page->next = inc_used_mem; + inc_used_mem = new_page; + inc_used_pages++; + + new_free->prev = NULL; + new_free->next = inc_free_list; + new_free->size = INC_PAGESIZE; + if (inc_free_list) + inc_free_list->prev = new_free; + inc_free_list = new_free; + + this = new_free; + if (!(ma_gc_flags & GC_MAJOR)) + ma_gc_flags |= GC_NEED_MAJOR; + } + else + { + erl_exit(-1, "inc_alloc ran out of pages!\n"); + } + } + + if (((this->size) - need) * sizeof(Eterm) >= sizeof(INC_MemBlock)) + { + INC_MemBlock *rest = (INC_MemBlock*)((Eterm*)this + need); + + /* The order here IS important! */ + rest->next = this->next; + + if (rest->next) + rest->next->prev = rest; + + rest->prev = this->prev; + + if (rest->prev) + rest->prev->next = rest; + else + inc_free_list = rest; + + rest->size = this->size - need; + } + else + { + if (this->prev) + this->prev->next = this->next; + else + inc_free_list = this->next; + + if (this->next) + this->next->prev = this->prev; + } + + if (ma_gc_flags & GC_MAJOR) { + if (need > 254) { + blackmap[(Eterm*)this - global_old_heap] = 255; + *(int*)((long)(&blackmap[(Eterm*)this - global_old_heap]+4) & ~3) = + need; + } else + blackmap[(Eterm*)this - global_old_heap] = need; + } + return (Eterm*)this; +} +#endif /* INCREMENTAL */ diff --git a/erts/emulator/beam/erl_nmgc.h b/erts/emulator/beam/erl_nmgc.h new file mode 100644 index 0000000000..b207dd37fa --- /dev/null +++ b/erts/emulator/beam/erl_nmgc.h @@ -0,0 +1,364 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2004-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifndef __ERL_NMGC_H__ +#define __ERL_NMGC_H__ + +#ifdef INCREMENTAL +#include /* offsetof() */ +#include "erl_process.h" + +#define INC_FULLPAGE (INC_PAGESIZE + offsetof(INC_Page,start) / sizeof(void*)) + +#define BOXED_NEED(PTR,HDR) \ + (((HDR) & _HEADER_SUBTAG_MASK) == SUB_BINARY_SUBTAG ? \ + header_arity(HDR) + 2 : \ + ((HDR) & _HEADER_SUBTAG_MASK) == FUN_SUBTAG ? \ + header_arity(HDR) + ((ErlFunThing*)(PTR))->num_free + 2 : \ + header_arity(HDR) + 1) + + +#define INC_DECREASE_WORK(n) inc_words_to_go -= (n); + +#define INC_COPY_CONS(FROM,TO,PTR) \ +do { \ + TO[0] = FROM[0]; \ + TO[1] = FROM[1]; \ + INC_MARK_FORWARD(FROM,TO); \ + *(PTR) = make_list(TO); \ + INC_DECREASE_WORK(2); \ + (TO) += 2; \ +} while(0) + +#define INC_COPY_BOXED(FROM,TO,PTR) \ +do { \ + Sint nelts; \ + Eterm hdr = *(FROM); \ + \ + ASSERT(is_header(hdr)); \ + INC_MARK_FORWARD(FROM,TO); \ + *(PTR) = make_boxed(TO); \ + *(TO)++ = *(FROM)++; \ + nelts = header_arity(hdr); \ + switch ((hdr) & _HEADER_SUBTAG_MASK) { \ + case SUB_BINARY_SUBTAG: nelts++; break; \ + case FUN_SUBTAG: nelts+=((ErlFunThing*)(FROM-1))->num_free+1; break;\ + } \ + INC_DECREASE_WORK(nelts + 1); \ + while (nelts--) \ + *(TO)++ = *(FROM)++; \ +} while(0) + + +/* Things copied to the old generation are not marked in the blackmap. + * This is ok since the page they are copied to (aging) is not part of + * the sweep. + */ +#define COPYMARK_CONS(FROM,TO,PTR,LIMIT) \ +do { \ + if (ptr_within(FROM,inc_fromspc,inc_fromend)) { \ + if (INC_IS_FORWARDED(FROM)) { \ + *PTR = make_list(INC_FORWARD_VALUE(FROM)); \ + } else if (TO + 2 <= LIMIT) { \ + INC_STORE(gray,TO,2); \ + INC_COPY_CONS(FROM,TO,PTR); \ + } else { \ + Eterm *hp = erts_inc_alloc(2); \ + INC_STORE(gray,hp,2); \ + INC_COPY_CONS(FROM,hp,PTR); \ + } \ + } else if (ptr_within(FROM,global_old_heap,global_old_hend) && \ + (blackmap[FROM - global_old_heap] == 0)) { \ + blackmap[FROM - global_old_heap] = 2; \ + INC_DECREASE_WORK(2); \ + INC_STORE(gray,FROM,2); \ + } \ +} while(0) + +#define COPYMARK_BOXED(FROM,TO,PTR,LIMIT) \ +do { \ + if (ptr_within(FROM,inc_fromspc,inc_fromend)) { \ + int size = BOXED_NEED(FROM,*FROM); \ + if (INC_IS_FORWARDED(FROM)) { \ + *PTR = make_boxed(INC_FORWARD_VALUE(FROM)); \ + } else if (TO + size <= LIMIT) { \ + INC_STORE(gray,TO,size); \ + INC_COPY_BOXED(FROM,TO,PTR); \ + } else { \ + Eterm *hp = erts_inc_alloc(size); \ + INC_STORE(gray,hp,size); \ + INC_COPY_BOXED(FROM,hp,PTR); \ + } \ + } else if (ptr_within(FROM,global_old_heap,global_old_hend) && \ + (blackmap[FROM - global_old_heap] == 0)) { \ + int size = BOXED_NEED(FROM,*FROM); \ + if (size > 254) { \ + blackmap[FROM - global_old_heap] = 255; \ + *(int*)((long)(&blackmap[FROM - \ + global_old_heap] + 4) & ~3) = size; \ + } else \ + blackmap[FROM - global_old_heap] = size; \ + INC_DECREASE_WORK(size); \ + INC_STORE(gray,FROM,size); \ + } \ +} while(0) + +#define INC_MARK_FORWARD(ptr,dst) fwdptrs[(ptr) - inc_fromspc] = (dst); +#define INC_IS_FORWARDED(ptr) (fwdptrs[(ptr) - inc_fromspc] != 0) +#define INC_FORWARD_VALUE(ptr) fwdptrs[(ptr) - inc_fromspc] + +/* Note for BM_TIMER: Active timer should always be 'system' when IncAlloc + * is called! + */ +#define IncAlloc(p, sz, objv, nobj) \ + (ASSERT_EXPR((sz) >= 0), \ + (((inc_alloc_limit - global_htop) <= (sz)) ? \ + erts_incremental_gc((p),(sz),(objv),(nobj)) : 0), \ + ASSERT_EXPR(global_hend - global_htop > (sz)), \ + global_htop += (sz), global_htop - (sz)) + + +/************************************************************************ + * INC_STORAGE, a dynamic circular storage for objects (INC_Object). * + * Use INC_STORE to add objects to the storage. The storage can then * + * be used either as a queue, using INC_STORAGE_GET to retreive * + * values, or as a stack, using INC_STORAGE_POP. It is OK to mix calls * + * to GET and POP if that is desired. * + * An iterator can be declared to traverse the storage without removing * + * any elements, and INC_STORAGE_STEP will then return each element in * + * turn, oldest first. * + ***********************************************************************/ + +/* Declare a new storage; must be in the beginning of a block. Give + * the storage a name that is used in all later calls to the storage. + * If this is an external declaration of the storage, pass the keyword + * external as the first argument, otherwise leave it empty. + */ +#define INC_STORAGE_DECLARATION(ext,name) \ + ext INC_Storage *name##head; \ + ext INC_Storage *name##tail; \ + ext INC_Object *name##free; \ + ext INC_Object *name##last_free; \ + ext int name##size; + + +/* Initialize the storage. Note that memory allocation is involved - + * don't forget to erase the storage when you are done. + */ +#define INC_STORAGE_INIT(name) do { \ + name##head = (INC_Storage*)erts_alloc(ERTS_ALC_T_OBJECT_STACK, \ + sizeof(INC_Storage)); \ + name##head->next = name##head; \ + name##head->prev = name##head; \ + name##tail = name##head; \ + name##free = name##head->data; \ + name##last_free = name##free + INC_STORAGE_SIZE - 1; \ + name##size = 0; \ +} while(0) + + +/* +#define INC_STORAGE_SWAP(s1,s2) do { \ + INC_Storage *tmphead = s1##head; \ + INC_Storage *tmptail = s1##tail; \ + INC_Object *tmpfree = s1##free; \ + INC_Object *tmplast = s1##last_free; \ + int tmpsize = s1##size; \ + s1##head = s2##head; \ + s1##tail = s2##tail; \ + s1##free = s2##free; \ + s1##last_free = s2##last_free; \ + s1##size = s2##size; \ + s2##head = tmphead; \ + s2##tail = tmptail; \ + s2##free = tmpfree; \ + s2##last_free = tmplast; \ + s2##size = tmpsize; \ +} while(0) +*/ + + +/* Return and remove the youngest element - treat the storage as a + * stack. Always check that there are elements in the queue before + * using INC_STORAGE_POP! + */ +#define INC_STORAGE_POP(name) (ASSERT_EXPR(name##size != 0), \ + name##size--, \ + (--name##free != name##head->data - 1) ? \ + name##free : (name##head = name##head->prev, \ + name##free = name##head->data + INC_STORAGE_SIZE - 1)) + + +/* Return and remove the oldest element - treat the storage as a + * queue. Always check that there are elements in the queue before + * using INC_STORAGE_GET! + */ +#define INC_STORAGE_GET(name) (ASSERT_EXPR(name##size != 0), \ + name##size--, \ + (++name##last_free != name##tail->data + INC_STORAGE_SIZE) ? \ + name##last_free : (name##tail = name##tail->next, \ + name##last_free = name##tail->data)) + + +/* Advance the head to the next free location. If the storage is full, + * a new storage is allocated and linked into the list. + */ +#define INC_STORAGE_NEXT(name) do { \ + if (name##free == name##last_free) { \ + name##tail = (INC_Storage*)erts_alloc(ERTS_ALC_T_OBJECT_STACK, \ + sizeof(INC_Storage)); \ + memcpy(name##tail->data,name##head->data, \ + INC_STORAGE_SIZE * sizeof(INC_Object)); \ + name##tail->next = name##head->next; \ + name##head->next = name##tail; \ + name##tail->prev = name##tail->next->prev; \ + name##tail->next->prev = name##tail; \ + name##last_free = ((void*)name##tail + \ + ((void*)name##last_free - (void*)name##head)); \ + } \ + name##free++; \ + name##size++; \ + if (name##free == name##head->data + INC_STORAGE_SIZE) { \ + name##head = name##head->next; \ + name##free = name##head->data; \ + } \ +} while(0) + + +/* The head of this storage is the next free location. This is where + * the next element will be stored. + */ +#define INC_STORAGE_HEAD(name) (name##free) + + +/* Return the top - the youngest element in the storage. */ +/* #define INC_STORAGE_TOP(name) (name##free - 1 with some magic..) */ + + +/* True if the storage is empty, false otherwise */ +#define INC_STORAGE_EMPTY(name) (name##size == 0) + + +/* Store a new element in the head of the storage and advance the head + * to the next free location. + */ +#define INC_STORE(name,ptr,sz) do { \ + INC_STORAGE_HEAD(name)->this = ptr; \ + INC_STORAGE_HEAD(name)->size = sz; \ + INC_STORAGE_NEXT(name); \ +} while(0) + + +/* An iterator. Use it together with INC_STORAGE_STEP to browse throuh + * the storage. Please note that it is not possible to remove an entry + * in the middle of the storage, use GET or POP to remove enties. + */ +#define INC_STORAGE_ITERATOR(name) \ + INC_Storage *name##iterator_head = name##tail; \ + INC_Object *name##iterator_current = name##last_free; \ + int name##iterator_left = name##size; + + +/* Return the next element in the storage (sorted by age, oldest + * first) or NULL if the storage is empty or the last element has been + * returned already. + */ +#define INC_STORAGE_STEP(name) (name##iterator_left == 0 ? NULL : \ + (name##iterator_left--, \ + (++name##iterator_current != name##iterator_head->data + \ + INC_STORAGE_SIZE) ? name##iterator_current : \ + (name##iterator_head = name##iterator_head->next, \ + name##iterator_current = name##iterator_head->data))) + + +/* Erase the storage. */ +#define INC_STORAGE_ERASE(name)do { \ + name##head->prev->next = NULL; \ + while (name##head != NULL) { \ + name##tail = name##head; \ + name##head = name##head->next; \ + erts_free(ERTS_ALC_T_OBJECT_STACK,(void*)name##tail); \ + } \ + name##tail = NULL; \ + name##free = NULL; \ + name##last_free = NULL; \ + name##size = 0; \ +} while(0) + +/* + * Structures used by the non-moving memory manager + */ + +typedef struct +{ + Eterm *this; + unsigned long size; +} INC_Object; + +typedef struct inc_storage { + struct inc_storage *next; + struct inc_storage *prev; + INC_Object data[INC_STORAGE_SIZE]; +} INC_Storage; + +typedef struct inc_mem_block +{ + unsigned long size; + struct inc_mem_block *prev; + struct inc_mem_block *next; +} INC_MemBlock; + +typedef struct inc_page +{ + struct inc_page *next; + Eterm start[1]; /* Has to be last in struct, this is where the data start */ +} INC_Page; + + +/* + * Heap pointers for the non-moving memory area. + */ +extern INC_Page *inc_used_mem; +extern INC_MemBlock *inc_free_list; +extern unsigned char *blackmap; + +extern Eterm **fwdptrs; +extern Eterm *inc_fromspc; +extern Eterm *inc_fromend; +extern Process *inc_active_proc; +extern Process *inc_active_last; +extern Eterm *inc_alloc_limit; +extern int inc_words_to_go; + +INC_STORAGE_DECLARATION(extern,gray); +INC_STORAGE_DECLARATION(extern,root); + +void erts_init_incgc(void); +void erts_cleanup_incgc(void); +void erts_incremental_gc(Process *p, int sz, Eterm* objv, int nobj); +Eterm *erts_inc_alloc(int need); + +#else +# define INC_STORE(lst,ptr,sz) +# define INC_MARK_FORWARD(ptr) +# define INC_IS_FORWARDED(ptr) +# define INC_FORWARD_VALUE(ptr) +#endif /* INCREMENTAL */ + +#endif /* _ERL_NMGC_H_ */ diff --git a/erts/emulator/beam/erl_node_container_utils.h b/erts/emulator/beam/erl_node_container_utils.h new file mode 100644 index 0000000000..87dbfc2a04 --- /dev/null +++ b/erts/emulator/beam/erl_node_container_utils.h @@ -0,0 +1,318 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2001-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifndef ERL_NODE_CONTAINER_UTILS_H__ +#define ERL_NODE_CONTAINER_UTILS_H__ + +#include "erl_term.h" + +/* + * Note regarding node containers: + * + * The term "node container" is used as a group name (internally in + * the emulator) for the Erlang data types that contain a reference + * to a node, i.e. pids, ports, and references. + * + * Observe! The layouts of the node container data types have been + * changed in R9. + * + * Node containers are divided into internal and external node containers. + * An internal node container refer to the current incarnation of the + * node which it reside on. An external node container refer to + * either a remote node (i.e. a node with another node name than the + * node name of the node on which the node container resides on) or another + * incarnation of the node which the node container resides on (i.e + * another node with the same node name but another creation). + * + * External node containers are boxed data types. The data of an + * external node container is stored on the heap together with a pointer + * to an element in the node table (see erl_term.h and erl_node_tables.h). + * The elements of the node table are garbage collected by reference + * counting (much like refc binaries, and funs in the separate heap case). + * + * Internal node containers are stored as they previously were (in R8) + * with the exception of changed internal layouts (see erl_term.h), i.e. + * internal pid, and internal port are immediate data types and internal + * reference is a boxed data type. An internal node container have an + * implicit reference to the 'erts_this_node' element in the node table. + * + * Due to the R9 changes in layouts of node containers there are room to + * store more data than previously. Today (R9) this extra space is unused, + * but it is planned to be used in the future. For example only 18 bits + * are used for data in a pid but there is room for 28 bits of data (on a + * 32-bit machine). Some preparations have been made in the emulator for + * usage of this extra space. + * + * OBSERVE! Pids doesn't use fixed size 'serial' and 'number' fields any + * more. Previously the 15 bit 'number' field of a pid was used as index + * into the process table, and the 3 bit 'serial' field was used as a + * "wrap counter". The needed number of bits for index into the process + * table is now calculated at startup and the rest (of the 18 bits used) + * are used as 'serial'. In the "emulator interface" (external format, + * list_to_pid, etc) the least significant 15 bits are presented as + * 'number' and the most significant 3 bits are presented as 'serial', + * though. The makro internal_pid_index() can be used for retrieving + * index into the process table. Do *not* use the result from + * pid_number() as an index into the process table. The pid_number() and + * pid_serial() (and friends) fetch the old fixed size 'number' and + * 'serial' fields. + */ + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *\ + * Node containers * +\* */ + +#define node_container_node_name(x) (is_external(x) \ + ? external_node_name((x)) \ + : internal_node_name((x))) +#define node_container_creation(x) (is_external(x) \ + ? external_creation((x)) \ + : internal_creation((x))) +#define node_container_dist_entry(x) (is_external(x) \ + ? external_dist_entry((x)) \ + : internal_dist_entry((x))) +#define node_container_channel_no(x) (is_external((x)) \ + ? external_channel_no((x)) \ + : internal_channel_no((x))) +#define is_node_container(x) (is_external((x)) || is_internal((x))) +#define is_not_node_container(x) (!is_node_container((x))) + +#define is_internal(x) (is_internal_pid((x)) \ + || is_internal_port((x)) \ + || is_internal_ref((x))) +#define is_not_internal(x) (!is_internal((x))) +#define internal_node_name(x) (erts_this_node->sysname) +#define external_node_name(x) external_node((x))->sysname +#define internal_creation(x) (erts_this_node->creation) +#define external_creation(x) (external_node((x))->creation) +#define internal_dist_entry(x) (erts_this_node->dist_entry) +#define external_dist_entry(x) (external_node((x))->dist_entry) + +extern int erts_use_r9_pids_ports; + +/* + * For this node (and previous incarnations of this node), 0 is used as + * channel no. For other nodes, the atom index of the atom corresponding + * to the node name is used as channel no. + * + * (We used to assert for correct node names, but we removed that assertion + * as it is possible to sneak in incorrect node names for instance using + * the external format.) + */ +#define dist_entry_channel_no(x) \ + ((x) == erts_this_dist_entry \ + ? ((Uint) 0) \ + : (ASSERT_EXPR(is_atom((x)->sysname)), \ + (Uint) atom_val((x)->sysname))) +#define internal_channel_no(x) ((Uint) ERST_INTERNAL_CHANNEL_NO) +#define external_channel_no(x) \ + (dist_entry_channel_no(external_dist_entry((x)))) + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *\ + * Pids * +\* */ + +#define internal_pid_index(x) (internal_pid_data((x)) \ + & erts_process_tab_index_mask) + +#define internal_pid_node_name(x) (internal_pid_node((x))->sysname) +#define external_pid_node_name(x) (external_pid_node((x))->sysname) +#define internal_pid_creation(x) (internal_pid_node((x))->creation) +#define external_pid_creation(x) (external_pid_node((x))->creation) +#define internal_pid_dist_entry(x) (internal_pid_node((x))->dist_entry) +#define external_pid_dist_entry(x) (external_pid_node((x))->dist_entry) + +#define internal_pid_channel_no(x) (internal_channel_no((x))) +#define external_pid_channel_no(x) (external_channel_no((x))) + +#define pid_data_words(x) (is_internal_pid((x)) \ + ? internal_pid_data_words((x)) \ + : external_pid_data_words((x))) +#define pid_number(x) (is_internal_pid((x)) \ + ? internal_pid_number((x)) \ + : external_pid_number((x))) +#define pid_serial(x) (is_internal_pid((x)) \ + ? internal_pid_serial((x)) \ + : external_pid_serial((x))) +#define pid_node(x) (is_internal_pid((x)) \ + ? internal_pid_node((x)) \ + : external_pid_node((x))) +#define pid_node_name(x) (is_internal_pid((x)) \ + ? internal_pid_node_name((x)) \ + : external_pid_node_name((x))) +#define pid_creation(x) (is_internal_pid((x)) \ + ? internal_pid_creation((x)) \ + : external_pid_creation((x))) +#define pid_dist_entry(x) (is_internal_pid((x)) \ + ? internal_pid_dist_entry((x)) \ + : external_pid_dist_entry((x))) +#define pid_channel_no(x) (is_internal_pid((x)) \ + ? internal_pid_channel_no((x)) \ + : external_pid_channel_no((x))) +#define is_pid(x) (is_internal_pid((x)) \ + || is_external_pid((x))) +#define is_not_pid(x) (!is_pid(x)) + +#define ERTS_MAX_R9_PROCESSES (1 << ERTS_R9_PROC_BITS) + +/* + * Maximum number of processes. We want the number to fit in a SMALL on + * 32-bit CPU. + */ + +#define ERTS_MAX_PROCESSES ((1L << 27)-1) +#if (ERTS_MAX_PROCESSES > MAX_SMALL) +# error "The maximum number of processes must fit in a SMALL." +#endif + +#define ERTS_MAX_PID_DATA ((1 << _PID_DATA_SIZE) - 1) +#define ERTS_MAX_PID_NUMBER ((1 << _PID_NUM_SIZE) - 1) +#define ERTS_MAX_PID_SERIAL ((1 << _PID_SER_SIZE) - 1) +#define ERTS_MAX_PID_R9_SERIAL ((1 << _PID_R9_SER_SIZE) - 1) + +#define ERTS_R9_PROC_BITS (_PID_R9_SER_SIZE + _PID_NUM_SIZE) +#define ERTS_PROC_BITS (_PID_SER_SIZE + _PID_NUM_SIZE) + +#define ERTS_INVALID_PID make_internal_pid(ERTS_MAX_PID_DATA) + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *\ + * Ports * +\* */ + +#define internal_port_index(x) (internal_port_data((x)) \ + & erts_port_tab_index_mask) + +#define internal_port_node_name(x) (internal_port_node((x))->sysname) +#define external_port_node_name(x) (external_port_node((x))->sysname) +#define internal_port_creation(x) (internal_port_node((x))->creation) +#define external_port_creation(x) (external_port_node((x))->creation) +#define internal_port_dist_entry(x) (internal_port_node((x))->dist_entry) +#define external_port_dist_entry(x) (external_port_node((x))->dist_entry) + +#define internal_port_channel_no(x) (internal_channel_no((x))) +#define external_port_channel_no(x) (external_channel_no((x))) + +#define port_data_words(x) (is_internal_port((x)) \ + ? internal_port_data_words((x))\ + : external_port_data_words((x))) +#define port_number(x) (is_internal_port((x)) \ + ? internal_port_number((x)) \ + : external_port_number((x))) +#define port_node(x) (is_internal_port((x)) \ + ? internal_port_node((x)) \ + : external_port_node((x))) +#define port_node_name(x) (is_internal_port((x)) \ + ? internal_port_node_name((x)) \ + : external_port_node_name((x))) +#define port_creation(x) (is_internal_port((x)) \ + ? internal_port_creation((x)) \ + : external_port_creation((x))) +#define port_dist_entry(x) (is_internal_port((x)) \ + ? internal_port_dist_entry((x))\ + : external_port_dist_entry((x))) +#define port_channel_no(x) (is_internal_port((x)) \ + ? internal_port_channel_no((x))\ + : external_port_channel_no((x))) + +#define is_port(x) (is_internal_port((x)) \ + || is_external_port((x))) +#define is_not_port(x) (!is_port(x)) + +/* Highest port-ID part in a term of type Port + Not necessarily the same as the variable erts_max_ports + which defines the maximum number of simultaneous Ports + in the Erlang node. ERTS_MAX_PORTS is a hard upper limit. +*/ +#define ERTS_MAX_R9_PORTS (1 << ERTS_R9_PORTS_BITS) +#define ERTS_MAX_PORTS (1 << ERTS_PORTS_BITS) + +#define ERTS_MAX_PORT_DATA ((1 << _PORT_DATA_SIZE) - 1) +#define ERTS_MAX_PORT_NUMBER ((1 << _PORT_NUM_SIZE) - 1) + +#define ERTS_R9_PORTS_BITS (_PORT_R9_NUM_SIZE) +#define ERTS_PORTS_BITS (_PORT_NUM_SIZE) +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *\ + * Refs * +\* */ + +#ifdef ARCH_64 + +#define internal_ref_no_of_numbers(x) \ + (internal_ref_data((x))[0]) +#define internal_ref_numbers(x) \ + (&internal_ref_data((x))[1]) +#define external_ref_no_of_numbers(x) \ + (external_ref_data((x))[0]) +#define external_ref_numbers(x) \ + (&external_ref_data((x))[1]) + +#else + +#define internal_ref_no_of_numbers(x) (internal_ref_data_words((x))) +#define internal_ref_numbers(x) (internal_ref_data((x))) +#define external_ref_no_of_numbers(x) (external_ref_data_words((x))) +#define external_ref_numbers(x) (external_ref_data((x))) + +#endif + +#define internal_ref_node_name(x) (internal_ref_node((x))->sysname) +#define external_ref_node_name(x) (external_ref_node((x))->sysname) +#define internal_ref_creation(x) (internal_ref_node((x))->creation) +#define external_ref_creation(x) (external_ref_node((x))->creation) +#define internal_ref_dist_entry(x) (internal_ref_node((x))->dist_entry) +#define external_ref_dist_entry(x) (external_ref_node((x))->dist_entry) + + +#define internal_ref_channel_no(x) (internal_channel_no((x))) +#define external_ref_channel_no(x) (external_channel_no((x))) + +#define ref_data_words(x) (is_internal_ref((x)) \ + ? internal_ref_data_words((x)) \ + : external_ref_data_words((x))) +#define ref_data(x) (is_internal_ref((x)) \ + ? internal_ref_data((x)) \ + : external_ref_data((x))) +#define ref_no_of_numbers(x) (is_internal_ref((x)) \ + ? internal_ref_no_of_numbers((x))\ + : external_ref_no_of_numbers((x))) +#define ref_numbers(x) (is_internal_ref((x)) \ + ? internal_ref_numbers((x)) \ + : external_ref_numbers((x))) +#define ref_node(x) (is_internal_ref((x)) \ + ? internal_ref_node(x) \ + : external_ref_node((x))) +#define ref_node_name(x) (is_internal_ref((x)) \ + ? internal_ref_node_name((x)) \ + : external_ref_node_name((x))) +#define ref_creation(x) (is_internal_ref((x)) \ + ? internal_ref_creation((x)) \ + : external_ref_creation((x))) +#define ref_dist_entry(x) (is_internal_ref((x)) \ + ? internal_ref_dist_entry((x)) \ + : external_ref_dist_entry((x))) +#define ref_channel_no(x) (is_internal_ref((x)) \ + ? internal_ref_channel_no((x)) \ + : external_ref_channel_no((x))) +#define is_ref(x) (is_internal_ref((x)) \ + || is_external_ref((x))) +#define is_not_ref(x) (!is_ref(x)) + +#endif + + diff --git a/erts/emulator/beam/erl_node_tables.c b/erts/emulator/beam/erl_node_tables.c new file mode 100644 index 0000000000..42b28d987c --- /dev/null +++ b/erts/emulator/beam/erl_node_tables.c @@ -0,0 +1,1660 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2001-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "global.h" +#include "erl_node_tables.h" +#include "dist.h" +#include "big.h" +#include "error.h" + +Hash erts_dist_table; +Hash erts_node_table; +erts_smp_rwmtx_t erts_dist_table_rwmtx; +erts_smp_rwmtx_t erts_node_table_rwmtx; + +DistEntry *erts_hidden_dist_entries; +DistEntry *erts_visible_dist_entries; +DistEntry *erts_not_connected_dist_entries; +Sint erts_no_of_hidden_dist_entries; +Sint erts_no_of_visible_dist_entries; +Sint erts_no_of_not_connected_dist_entries; + +DistEntry *erts_this_dist_entry; +ErlNode *erts_this_node; + +static Uint node_entries; +static Uint dist_entries; + +static int references_atoms_need_init = 1; + +/* -- The distribution table ---------------------------------------------- */ + +#ifdef DEBUG +static int +is_in_de_list(DistEntry *dep, DistEntry *dep_list) +{ + DistEntry *tdep; + for(tdep = dep_list; tdep; tdep = tdep->next) + if(tdep == dep) + return 1; + return 0; +} +#endif + +static HashValue +dist_table_hash(void *dep) +{ + return atom_tab(atom_val(((DistEntry *) dep)->sysname))->slot.bucket.hvalue; +} + +static int +dist_table_cmp(void *dep1, void *dep2) +{ + return (((DistEntry *) dep1)->sysname == ((DistEntry *) dep2)->sysname + ? 0 : 1); +} + +static void* +dist_table_alloc(void *dep_tmpl) +{ + Eterm chnl_nr; + Eterm sysname; + DistEntry *dep; + + if(((DistEntry *) dep_tmpl) == erts_this_dist_entry) + return dep_tmpl; + + sysname = ((DistEntry *) dep_tmpl)->sysname; + chnl_nr = make_small((Uint) atom_val(sysname)); + dep = (DistEntry *) erts_alloc(ERTS_ALC_T_DIST_ENTRY, sizeof(DistEntry)); + + dist_entries++; + + dep->prev = NULL; + erts_refc_init(&dep->refc, -1); + erts_smp_rwmtx_init_x(&dep->rwmtx, "dist_entry", chnl_nr); + dep->sysname = sysname; + dep->cid = NIL; + dep->connection_id = 0; + dep->status = 0; + dep->flags = 0; + dep->version = 0; + + erts_smp_mtx_init_x(&dep->lnk_mtx, "dist_entry_links", chnl_nr); + dep->node_links = NULL; + dep->nlinks = NULL; + dep->monitors = NULL; + + erts_smp_spinlock_init_x(&dep->qlock, "dist_entry_out_queue", chnl_nr); + dep->qflgs = 0; + dep->qsize = 0; + dep->out_queue.first = NULL; + dep->out_queue.last = NULL; + dep->suspended.first = NULL; + dep->suspended.last = NULL; + + dep->finalized_out_queue.first = NULL; + dep->finalized_out_queue.last = NULL; + + erts_smp_atomic_init(&dep->dist_cmd_scheduled, 0); + erts_port_task_handle_init(&dep->dist_cmd); + dep->send = NULL; + dep->cache = NULL; + + /* Link in */ + + /* All new dist entries are "not connected" */ + dep->next = erts_not_connected_dist_entries; + if(erts_not_connected_dist_entries) { + ASSERT(erts_not_connected_dist_entries->prev == NULL); + erts_not_connected_dist_entries->prev = dep; + } + erts_not_connected_dist_entries = dep; + erts_no_of_not_connected_dist_entries++; + + return (void *) dep; +} + +static void +dist_table_free(void *vdep) +{ + DistEntry *dep = (DistEntry *) vdep; + + if(dep == erts_this_dist_entry) + return; + + ASSERT(is_nil(dep->cid)); + ASSERT(dep->nlinks == NULL); + ASSERT(dep->node_links == NULL); + ASSERT(dep->monitors == NULL); + + /* Link out */ + + /* All dist entries about to be removed are "not connected" */ + + if(dep->prev) { + ASSERT(is_in_de_list(dep, erts_not_connected_dist_entries)); + dep->prev->next = dep->next; + } + else { + ASSERT(erts_not_connected_dist_entries == dep); + erts_not_connected_dist_entries = dep->next; + } + + if(dep->next) + dep->next->prev = dep->prev; + + ASSERT(erts_no_of_not_connected_dist_entries > 0); + erts_no_of_not_connected_dist_entries--; + + ASSERT(!dep->cache); + erts_smp_rwmtx_destroy(&dep->rwmtx); + erts_smp_mtx_destroy(&dep->lnk_mtx); + erts_smp_spinlock_destroy(&dep->qlock); + +#ifdef DEBUG + sys_memset(vdep, 0x77, sizeof(DistEntry)); +#endif + erts_free(ERTS_ALC_T_DIST_ENTRY, (void *) dep); + + ASSERT(dist_entries > 1); + dist_entries--; +} + + +void +erts_dist_table_info(int to, void *to_arg) +{ + int lock = !ERTS_IS_CRASH_DUMPING; + if (lock) + erts_smp_rwmtx_rlock(&erts_dist_table_rwmtx); + hash_info(to, to_arg, &erts_dist_table); + if (lock) + erts_smp_rwmtx_runlock(&erts_dist_table_rwmtx); +} + +DistEntry * +erts_channel_no_to_dist_entry(Uint cno) +{ +/* + * For this node (and previous incarnations of this node), + * ERST_INTERNAL_CHANNEL_NO (will always be 0 I guess) is used as + * channel no. For other nodes, the atom index of the atom corresponding + * to the node name is used as channel no. + */ + if(cno == ERST_INTERNAL_CHANNEL_NO) { + erts_refc_inc(&erts_this_dist_entry->refc, 2); + return erts_this_dist_entry; + } + + if((cno > MAX_ATOM_INDEX) + || (cno >= atom_table_size()) + || (atom_tab(cno) == NULL)) + return NULL; + + /* cno is a valid atom index; find corresponding dist entry (if there + is one) */ + return erts_find_dist_entry(make_atom(cno)); +} + + +DistEntry * +erts_sysname_to_connected_dist_entry(Eterm sysname) +{ + DistEntry de; + DistEntry *res_dep; + de.sysname = sysname; + + if(erts_this_dist_entry->sysname == sysname) { + erts_refc_inc(&erts_this_dist_entry->refc, 2); + return erts_this_dist_entry; + } + + erts_smp_rwmtx_rlock(&erts_dist_table_rwmtx); + res_dep = (DistEntry *) hash_get(&erts_dist_table, (void *) &de); + if (res_dep) { + long refc = erts_refc_inctest(&res_dep->refc, 1); + if (refc < 2) /* Pending delete */ + erts_refc_inc(&res_dep->refc, 1); + } + erts_smp_rwmtx_runlock(&erts_dist_table_rwmtx); + if (res_dep) { + int deref; + erts_smp_rwmtx_rlock(&res_dep->rwmtx); + deref = is_nil(res_dep->cid); + erts_smp_rwmtx_runlock(&res_dep->rwmtx); + if (deref) { + erts_deref_dist_entry(res_dep); + res_dep = NULL; + } + } + return res_dep; +} + +DistEntry *erts_find_or_insert_dist_entry(Eterm sysname) +{ + DistEntry *res; + DistEntry de; + long refc; + res = erts_find_dist_entry(sysname); + if (res) + return res; + de.sysname = sysname; + erts_smp_rwmtx_rwlock(&erts_dist_table_rwmtx); + res = hash_put(&erts_dist_table, (void *) &de); + refc = erts_refc_inctest(&res->refc, 0); + if (refc < 2) /* New or pending delete */ + erts_refc_inc(&res->refc, 1); + erts_smp_rwmtx_rwunlock(&erts_dist_table_rwmtx); + return res; +} + +DistEntry *erts_find_dist_entry(Eterm sysname) +{ + DistEntry *res; + DistEntry de; + de.sysname = sysname; + erts_smp_rwmtx_rlock(&erts_dist_table_rwmtx); + res = hash_get(&erts_dist_table, (void *) &de); + if (res) { + long refc = erts_refc_inctest(&res->refc, 1); + if (refc < 2) /* Pending delete */ + erts_refc_inc(&res->refc, 1); + } + erts_smp_rwmtx_runlock(&erts_dist_table_rwmtx); + return res; +} + +void erts_delete_dist_entry(DistEntry *dep) +{ + ASSERT(dep != erts_this_dist_entry); + if(dep != erts_this_dist_entry) { + erts_smp_rwmtx_rwlock(&erts_dist_table_rwmtx); + /* + * Another thread might have looked up this dist entry after + * we decided to delete it (refc became zero). If so, the other + * thread incremented refc twice. Once for the new reference + * and once for this thread. Therefore, delete dist entry if + * refc is 0 or -1 after a decrement. + */ + if (erts_refc_dectest(&dep->refc, -1) <= 0) + (void) hash_erase(&erts_dist_table, (void *) dep); + erts_smp_rwmtx_rwunlock(&erts_dist_table_rwmtx); + } +} + +Uint +erts_dist_table_size(void) +{ + Uint res; +#ifdef DEBUG + HashInfo hi; + DistEntry *dep; + int i; +#endif + int lock = !ERTS_IS_CRASH_DUMPING; + + if (lock) + erts_smp_rwmtx_rlock(&erts_dist_table_rwmtx); +#ifdef DEBUG + hash_get_info(&hi, &erts_dist_table); + ASSERT(dist_entries == hi.objs); + + i = 0; + for(dep = erts_visible_dist_entries; dep; dep = dep->next) + i++; + ASSERT(i == erts_no_of_visible_dist_entries); + i = 0; + for(dep = erts_hidden_dist_entries; dep; dep = dep->next) + i++; + ASSERT(i == erts_no_of_hidden_dist_entries); + i = 0; + for(dep = erts_not_connected_dist_entries; dep; dep = dep->next) + i++; + ASSERT(i == erts_no_of_not_connected_dist_entries); + + ASSERT(dist_entries == (erts_no_of_visible_dist_entries + + erts_no_of_hidden_dist_entries + + erts_no_of_not_connected_dist_entries + + 1 /* erts_this_dist_entry */)); +#endif + + res = (hash_table_sz(&erts_dist_table) + + dist_entries*sizeof(DistEntry) + + erts_dist_cache_size()); + if (lock) + erts_smp_rwmtx_runlock(&erts_dist_table_rwmtx); + return res; +} + +void +erts_set_dist_entry_not_connected(DistEntry *dep) +{ + ERTS_SMP_LC_ASSERT(erts_lc_is_de_rwlocked(dep)); + erts_smp_rwmtx_rwlock(&erts_dist_table_rwmtx); + + ASSERT(dep != erts_this_dist_entry); + ASSERT(is_internal_port(dep->cid)); + + if(dep->flags & DFLAG_PUBLISHED) { + if(dep->prev) { + ASSERT(is_in_de_list(dep, erts_visible_dist_entries)); + dep->prev->next = dep->next; + } + else { + ASSERT(erts_visible_dist_entries == dep); + erts_visible_dist_entries = dep->next; + } + + ASSERT(erts_no_of_visible_dist_entries > 0); + erts_no_of_visible_dist_entries--; + } + else { + if(dep->prev) { + ASSERT(is_in_de_list(dep, erts_hidden_dist_entries)); + dep->prev->next = dep->next; + } + else { + ASSERT(erts_hidden_dist_entries == dep); + erts_hidden_dist_entries = dep->next; + } + + ASSERT(erts_no_of_hidden_dist_entries > 0); + erts_no_of_hidden_dist_entries--; + } + + if(dep->next) + dep->next->prev = dep->prev; + + dep->status &= ~ERTS_DE_SFLG_CONNECTED; + dep->flags = 0; + dep->prev = NULL; + dep->cid = NIL; + + dep->next = erts_not_connected_dist_entries; + if(erts_not_connected_dist_entries) { + ASSERT(erts_not_connected_dist_entries->prev == NULL); + erts_not_connected_dist_entries->prev = dep; + } + erts_not_connected_dist_entries = dep; + erts_no_of_not_connected_dist_entries++; + erts_smp_rwmtx_rwunlock(&erts_dist_table_rwmtx); +} + +void +erts_set_dist_entry_connected(DistEntry *dep, Eterm cid, Uint flags) +{ + ERTS_SMP_LC_ASSERT(erts_lc_is_de_rwlocked(dep)); + erts_smp_rwmtx_rwlock(&erts_dist_table_rwmtx); + + ASSERT(dep != erts_this_dist_entry); + ASSERT(is_nil(dep->cid)); + ASSERT(is_internal_port(cid)); + + if(dep->prev) { + ASSERT(is_in_de_list(dep, erts_not_connected_dist_entries)); + dep->prev->next = dep->next; + } + else { + ASSERT(erts_not_connected_dist_entries == dep); + erts_not_connected_dist_entries = dep->next; + } + + if(dep->next) + dep->next->prev = dep->prev; + + ASSERT(erts_no_of_not_connected_dist_entries > 0); + erts_no_of_not_connected_dist_entries--; + + dep->status |= ERTS_DE_SFLG_CONNECTED; + dep->flags = flags; + dep->cid = cid; + dep->connection_id++; + dep->connection_id &= ERTS_DIST_EXT_CON_ID_MASK; + dep->prev = NULL; + + if(flags & DFLAG_PUBLISHED) { + dep->next = erts_visible_dist_entries; + if(erts_visible_dist_entries) { + ASSERT(erts_visible_dist_entries->prev == NULL); + erts_visible_dist_entries->prev = dep; + } + erts_visible_dist_entries = dep; + erts_no_of_visible_dist_entries++; + } + else { + dep->next = erts_hidden_dist_entries; + if(erts_hidden_dist_entries) { + ASSERT(erts_hidden_dist_entries->prev == NULL); + erts_hidden_dist_entries->prev = dep; + } + erts_hidden_dist_entries = dep; + erts_no_of_hidden_dist_entries++; + } + erts_smp_rwmtx_rwunlock(&erts_dist_table_rwmtx); +} + +/* -- Node table --------------------------------------------------------- */ + +/* Some large primes */ +#define PRIME0 ((HashValue) 268438039) +#define PRIME1 ((HashValue) 268440479) +#define PRIME2 ((HashValue) 268439161) +#define PRIME3 ((HashValue) 268437017) + +static HashValue +node_table_hash(void *venp) +{ + Uint32 cre = ((ErlNode *) venp)->creation; + HashValue h = atom_tab(atom_val(((ErlNode *) venp)->sysname))->slot.bucket.hvalue; + + h *= PRIME0; + h += cre & 0xff; + +#if MAX_CREATION >= (1 << 8) + h *= PRIME1; + h += (cre >> 8) & 0xff; +#endif + +#if MAX_CREATION >= (1 << 16) + h *= PRIME2; + h += (cre >> 16) & 0xff; +#endif + +#if MAX_CREATION >= (1 << 24) + h *= PRIME3; + h += (cre >> 24) & 0xff; +#endif + +#if 0 +/* XXX Problems in older versions of GCC */ + #if MAX_CREATION >= (1UL << 32) + #error "MAX_CREATION larger than size of expected creation storage (Uint32)" + #endif +#endif + return h; +} + +static int +node_table_cmp(void *venp1, void *venp2) +{ + return ((((ErlNode *) venp1)->sysname == ((ErlNode *) venp2)->sysname + && ((ErlNode *) venp1)->creation == ((ErlNode *) venp2)->creation) + ? 0 + : 1); +} + +static void* +node_table_alloc(void *venp_tmpl) +{ + ErlNode *enp; + + if(((ErlNode *) venp_tmpl) == erts_this_node) + return venp_tmpl; + + enp = (ErlNode *) erts_alloc(ERTS_ALC_T_NODE_ENTRY, sizeof(ErlNode)); + + node_entries++; + + erts_refc_init(&enp->refc, -1); + enp->creation = ((ErlNode *) venp_tmpl)->creation; + enp->sysname = ((ErlNode *) venp_tmpl)->sysname; + enp->dist_entry = erts_find_or_insert_dist_entry(((ErlNode *) venp_tmpl)->sysname); + + return (void *) enp; +} + +static void +node_table_free(void *venp) +{ + ErlNode *enp = (ErlNode *) venp; + + if(enp == erts_this_node) + return; + + erts_deref_dist_entry(enp->dist_entry); +#ifdef DEBUG + sys_memset(venp, 0x55, sizeof(ErlNode)); +#endif + erts_free(ERTS_ALC_T_NODE_ENTRY, venp); + + ASSERT(node_entries > 1); + node_entries--; +} + +Uint +erts_node_table_size(void) +{ + Uint res; +#ifdef DEBUG + HashInfo hi; +#endif + int lock = !ERTS_IS_CRASH_DUMPING; + if (lock) + erts_smp_rwmtx_rwlock(&erts_node_table_rwmtx); +#ifdef DEBUG + hash_get_info(&hi, &erts_node_table); + ASSERT(node_entries == hi.objs); +#endif + res = hash_table_sz(&erts_node_table) + node_entries*sizeof(ErlNode); + if (lock) + erts_smp_rwmtx_rwunlock(&erts_node_table_rwmtx); + return res; +} + +void +erts_node_table_info(int to, void *to_arg) +{ + int lock = !ERTS_IS_CRASH_DUMPING; + if (lock) + erts_smp_rwmtx_rwlock(&erts_node_table_rwmtx); + hash_info(to, to_arg, &erts_node_table); + if (lock) + erts_smp_rwmtx_rwunlock(&erts_node_table_rwmtx); +} + + +ErlNode *erts_find_or_insert_node(Eterm sysname, Uint creation) +{ + ErlNode *res; + ErlNode ne; + ne.sysname = sysname; + ne.creation = creation; + erts_smp_rwmtx_rwlock(&erts_node_table_rwmtx); + res = hash_put(&erts_node_table, (void *) &ne); + ASSERT(res); + if (res != erts_this_node) { + long refc = erts_refc_inctest(&res->refc, 0); + if (refc < 2) /* New or pending delete */ + erts_refc_inc(&res->refc, 1); + } + erts_smp_rwmtx_rwunlock(&erts_node_table_rwmtx); + return res; +} + +void erts_delete_node(ErlNode *enp) +{ + ASSERT(enp != erts_this_node); + if(enp != erts_this_node) { + erts_smp_rwmtx_rwlock(&erts_node_table_rwmtx); + /* + * Another thread might have looked up this node after we + * decided to delete it (refc became zero). If so, the other + * thread incremented refc twice. Once for the new reference + * and once for this thread. Therefore, delete node if refc + * is 0 or -1 after a decrement. + */ + if (erts_refc_dectest(&enp->refc, -1) <= 0) + (void) hash_erase(&erts_node_table, (void *) enp); + erts_smp_rwmtx_rwunlock(&erts_node_table_rwmtx); + } +} + +struct pn_data { + int to; + void *to_arg; + Eterm sysname; + int no_sysname; + int no_total; +}; + +static void print_node(void *venp, void *vpndp) +{ + struct pn_data *pndp = ((struct pn_data *) vpndp); + ErlNode *enp = ((ErlNode *) venp); + + if(pndp->sysname == NIL + || enp->sysname == pndp->sysname) { + if (pndp->no_sysname == 0) { + erts_print(pndp->to, pndp->to_arg, "Creation:"); + } + if(pndp->sysname == NIL) { + erts_print(pndp->to, pndp->to_arg, "Name: %T ", enp->sysname); + } + erts_print(pndp->to, pndp->to_arg, " %d", enp->creation); +#ifdef DEBUG + erts_print(pndp->to, pndp->to_arg, " (refc=%ld)", + erts_refc_read(&enp->refc, 1)); +#endif + pndp->no_sysname++; + } + pndp->no_total++; +} + +void erts_print_node_info(int to, + void *to_arg, + Eterm sysname, + int *no_sysname, + int *no_total) +{ + int lock = !ERTS_IS_CRASH_DUMPING; + struct pn_data pnd; + + pnd.to = to; + pnd.to_arg = to_arg; + pnd.sysname = sysname; + pnd.no_sysname = 0; + pnd.no_total = 0; + + if (lock) + erts_smp_rwmtx_rwlock(&erts_node_table_rwmtx); + hash_foreach(&erts_node_table, print_node, (void *) &pnd); + if (pnd.no_sysname != 0) { + erts_print(to, to_arg, "\n"); + } + if (lock) + erts_smp_rwmtx_rwunlock(&erts_node_table_rwmtx); + + if(no_sysname) + *no_sysname = pnd.no_sysname; + if(no_total) + *no_total = pnd.no_total; +} + +/* ----------------------------------------------------------------------- */ + +void +erts_set_this_node(Eterm sysname, Uint creation) +{ + erts_smp_rwmtx_rwlock(&erts_node_table_rwmtx); + erts_smp_rwmtx_rwlock(&erts_dist_table_rwmtx); + + (void) hash_erase(&erts_dist_table, (void *) erts_this_dist_entry); + erts_this_dist_entry->sysname = sysname; + erts_this_dist_entry->creation = creation; + (void) hash_put(&erts_dist_table, (void *) erts_this_dist_entry); + + (void) hash_erase(&erts_node_table, (void *) erts_this_node); + erts_this_node->sysname = sysname; + erts_this_node->creation = creation; + (void) hash_put(&erts_node_table, (void *) erts_this_node); + + erts_smp_rwmtx_rwunlock(&erts_dist_table_rwmtx); + erts_smp_rwmtx_rwunlock(&erts_node_table_rwmtx); + +} + +void erts_init_node_tables(void) +{ + HashFunctions f; + + f.hash = (H_FUN) dist_table_hash; + f.cmp = (HCMP_FUN) dist_table_cmp; + f.alloc = (HALLOC_FUN) dist_table_alloc; + f.free = (HFREE_FUN) dist_table_free; + + erts_this_dist_entry = erts_alloc(ERTS_ALC_T_DIST_ENTRY, sizeof(DistEntry)); + dist_entries = 1; + + hash_init(ERTS_ALC_T_DIST_TABLE, &erts_dist_table, "dist_table", 11, f); + + erts_hidden_dist_entries = NULL; + erts_visible_dist_entries = NULL; + erts_not_connected_dist_entries = NULL; + erts_no_of_hidden_dist_entries = 0; + erts_no_of_visible_dist_entries = 0; + erts_no_of_not_connected_dist_entries = 0; + + erts_this_dist_entry->next = NULL; + erts_this_dist_entry->prev = NULL; + erts_refc_init(&erts_this_dist_entry->refc, 1); /* erts_this_node */ + + erts_smp_rwmtx_init_x(&erts_this_dist_entry->rwmtx, + "dist_entry", + make_small(ERST_INTERNAL_CHANNEL_NO)); + erts_this_dist_entry->sysname = am_Noname; + erts_this_dist_entry->cid = NIL; + erts_this_dist_entry->connection_id = 0; + erts_this_dist_entry->status = 0; + erts_this_dist_entry->flags = 0; + erts_this_dist_entry->version = 0; + + erts_smp_mtx_init_x(&erts_this_dist_entry->lnk_mtx, + "dist_entry_links", + make_small(ERST_INTERNAL_CHANNEL_NO)); + erts_this_dist_entry->node_links = NULL; + erts_this_dist_entry->nlinks = NULL; + erts_this_dist_entry->monitors = NULL; + + erts_smp_spinlock_init_x(&erts_this_dist_entry->qlock, + "dist_entry_out_queue", + make_small(ERST_INTERNAL_CHANNEL_NO)); + erts_this_dist_entry->qflgs = 0; + erts_this_dist_entry->qsize = 0; + erts_this_dist_entry->out_queue.first = NULL; + erts_this_dist_entry->out_queue.last = NULL; + erts_this_dist_entry->suspended.first = NULL; + erts_this_dist_entry->suspended.last = NULL; + + erts_this_dist_entry->finalized_out_queue.first = NULL; + erts_this_dist_entry->finalized_out_queue.last = NULL; + erts_smp_atomic_init(&erts_this_dist_entry->dist_cmd_scheduled, 0); + erts_port_task_handle_init(&erts_this_dist_entry->dist_cmd); + erts_this_dist_entry->send = NULL; + erts_this_dist_entry->cache = NULL; + + (void) hash_put(&erts_dist_table, (void *) erts_this_dist_entry); + + f.hash = (H_FUN) node_table_hash; + f.cmp = (HCMP_FUN) node_table_cmp; + f.alloc = (HALLOC_FUN) node_table_alloc; + f.free = (HFREE_FUN) node_table_free; + + hash_init(ERTS_ALC_T_NODE_TABLE, &erts_node_table, "node_table", 11, f); + + erts_this_node = erts_alloc(ERTS_ALC_T_NODE_ENTRY, sizeof(ErlNode)); + node_entries = 1; + + erts_refc_init(&erts_this_node->refc, 1); /* The system itself */ + erts_this_node->sysname = am_Noname; + erts_this_node->creation = 0; + erts_this_node->dist_entry = erts_this_dist_entry; + + (void) hash_put(&erts_node_table, (void *) erts_this_node); + + erts_smp_rwmtx_init(&erts_node_table_rwmtx, "node_table"); + erts_smp_rwmtx_init(&erts_dist_table_rwmtx, "dist_table"); + + references_atoms_need_init = 1; +} + +#ifdef ERTS_SMP +#ifdef ERTS_ENABLE_LOCK_CHECK +int erts_lc_is_de_rwlocked(DistEntry *dep) +{ + return erts_smp_lc_rwmtx_is_rwlocked(&dep->rwmtx); +} +int erts_lc_is_de_rlocked(DistEntry *dep) +{ + return erts_smp_lc_rwmtx_is_rlocked(&dep->rwmtx); +} +#endif +#endif + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *\ + * The following is only supposed to be used for testing, and debugging. * + * * + * erts_get_node_and_dist_references() returns a table of all references to * + * all entries in the node and dist tables. The hole system will be searched * + * at once. This will give a consistent view over the references, but can * + * can damage the real-time properties of the system. * +\* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +#include "erl_db.h" + +#undef INIT_AM +#define INIT_AM(S) AM_ ## S = am_atom_put(#S, sizeof(#S) - 1) + +static Eterm AM_heap; +static Eterm AM_link; +static Eterm AM_monitor; +static Eterm AM_process; +static Eterm AM_port; +static Eterm AM_ets; +static Eterm AM_binary; +static Eterm AM_match_spec; +static Eterm AM_control; +static Eterm AM_dist; +static Eterm AM_node; +static Eterm AM_dist_references; +static Eterm AM_node_references; +static Eterm AM_system; +static Eterm AM_timer; +#ifdef HYBRID +static Eterm AM_processes; +#endif + +static void setup_reference_table(void); +static Eterm reference_table_term(Uint **hpp, Uint *szp); +static void delete_reference_table(void); + +#if BIG_UINT_HEAP_SIZE > 3 /* 2-tuple */ +#define ID_HEAP_SIZE BIG_UINT_HEAP_SIZE +#else +#define ID_HEAP_SIZE 3 /* 2-tuple */ +#endif + +typedef struct node_referrer_ { + struct node_referrer_ *next; + int heap_ref; + int link_ref; + int monitor_ref; + int ets_ref; + int bin_ref; + int timer_ref; + int system_ref; + Eterm id; + Uint id_heap[ID_HEAP_SIZE]; +} NodeReferrer; + +typedef struct { + ErlNode *node; + NodeReferrer *referrers; +} ReferredNode; + +typedef struct dist_referrer_ { + struct dist_referrer_ *next; + int heap_ref; + int node_ref; + int ctrl_ref; + Eterm id; + Uint creation; +} DistReferrer; + +typedef struct { + DistEntry *dist; + DistReferrer *referrers; +} ReferredDist; + +typedef struct inserted_bin_ { + struct inserted_bin_ *next; + Binary *bin_val; +} InsertedBin; + +static ReferredNode *referred_nodes; +static int no_referred_nodes; +static ReferredDist *referred_dists; +static int no_referred_dists; +static InsertedBin *inserted_bins; + +Eterm +erts_get_node_and_dist_references(struct process *proc) +{ + Uint *hp; + Uint size; + Eterm res; +#ifdef DEBUG + Uint *endp; +#endif + + erts_smp_proc_unlock(proc, ERTS_PROC_LOCK_MAIN); + erts_smp_block_system(0); + /* No need to lock any thing since we are alone... */ + + if (references_atoms_need_init) { + INIT_AM(heap); + INIT_AM(link); + INIT_AM(monitor); + INIT_AM(process); + INIT_AM(port); + INIT_AM(ets); + INIT_AM(binary); + INIT_AM(match_spec); + INIT_AM(control); + INIT_AM(dist); + INIT_AM(node); + INIT_AM(dist_references); + INIT_AM(node_references); + INIT_AM(timer); + INIT_AM(system); +#ifdef HYBRID + INIT_AM(processes); +#endif + references_atoms_need_init = 0; + } + + setup_reference_table(); + + /* Get term size */ + size = 0; + (void) reference_table_term(NULL, &size); + + hp = HAlloc(proc, size); +#ifdef DEBUG + ASSERT(size > 0); + endp = hp + size; +#endif + + /* Write term */ + res = reference_table_term(&hp, NULL); + + ASSERT(endp == hp); + + delete_reference_table(); + + erts_smp_release_system(); + erts_smp_proc_lock(proc, ERTS_PROC_LOCK_MAIN); + return res; +} + +#define HEAP_REF 1 +#define LINK_REF 2 +#define ETS_REF 3 +#define BIN_REF 4 +#define NODE_REF 5 +#define CTRL_REF 6 +#define MONITOR_REF 7 +#define TIMER_REF 8 +#define SYSTEM_REF 9 + +#define INC_TAB_SZ 10 + +static void +insert_dist_referrer(ReferredDist *referred_dist, + int type, + Eterm id, + Uint creation) +{ + DistReferrer *drp; + + for(drp = referred_dist->referrers; drp; drp = drp->next) + if(id == drp->id && (type == CTRL_REF + || creation == drp->creation)) + break; + + if(!drp) { + drp = (DistReferrer *) erts_alloc(ERTS_ALC_T_NC_TMP, + sizeof(DistReferrer)); + drp->next = referred_dist->referrers; + referred_dist->referrers = drp; + drp->id = id; + drp->creation = creation; + drp->heap_ref = 0; + drp->node_ref = 0; + drp->ctrl_ref = 0; + } + + switch (type) { + case NODE_REF: drp->node_ref++; break; + case CTRL_REF: drp->ctrl_ref++; break; + case HEAP_REF: drp->heap_ref++; break; + default: ASSERT(0); + } +} + +static void +insert_dist_entry(DistEntry *dist, int type, Eterm id, Uint creation) +{ + ReferredDist *rdp = NULL; + int i; + + for(i = 0; i < no_referred_dists; i++) { + if(dist == referred_dists[i].dist) { + rdp = &referred_dists[i]; + break; + } + } + + if(!rdp) + erl_exit(1, + "Reference to non-existing distribution table entry found!\n"); + + insert_dist_referrer(rdp, type, id, creation); +} + +static void +insert_node_referrer(ReferredNode *referred_node, int type, Eterm id) +{ + NodeReferrer *nrp; + + for(nrp = referred_node->referrers; nrp; nrp = nrp->next) + if(EQ(id, nrp->id)) + break; + + if(!nrp) { + nrp = (NodeReferrer *) erts_alloc(ERTS_ALC_T_NC_TMP, + sizeof(NodeReferrer)); + nrp->next = referred_node->referrers; + referred_node->referrers = nrp; + if(IS_CONST(id)) + nrp->id = id; + else { + Uint *hp = &nrp->id_heap[0]; + ASSERT(is_big(id) || is_tuple(id)); + nrp->id = copy_struct(id, size_object(id), &hp, NULL); + } + nrp->heap_ref = 0; + nrp->link_ref = 0; + nrp->monitor_ref = 0; + nrp->ets_ref = 0; + nrp->bin_ref = 0; + nrp->timer_ref = 0; + nrp->system_ref = 0; + } + + switch (type) { + case HEAP_REF: nrp->heap_ref++; break; + case LINK_REF: nrp->link_ref++; break; + case ETS_REF: nrp->ets_ref++; break; + case BIN_REF: nrp->bin_ref++; break; + case MONITOR_REF: nrp->monitor_ref++; break; + case TIMER_REF: nrp->timer_ref++; break; + case SYSTEM_REF: nrp->system_ref++; break; + default: ASSERT(0); + } +} + +static void +insert_node(ErlNode *node, int type, Eterm id) +{ + int i; + ReferredNode *rnp = NULL; + for(i = 0; i < no_referred_nodes; i++) { + if(node == referred_nodes[i].node) { + rnp = &referred_nodes[i]; + break; + } + } + + if (!rnp) + erl_exit(1, "Reference to non-existing node table entry found!\n"); + + insert_node_referrer(rnp, type, id); +} + +static void +insert_erl_node(void *venp, void *unused) +{ + ErlNode *enp = (ErlNode *) venp; + + insert_dist_entry(enp->dist_entry, NODE_REF, enp->sysname, enp->creation); +} + +struct insert_offheap2_arg { + int type; + Eterm id; +}; + +static void insert_offheap(ErlOffHeap *, int, Eterm); + +static void +insert_offheap2(ErlOffHeap *oh, void *arg) +{ + struct insert_offheap2_arg *a = (struct insert_offheap2_arg *) arg; + insert_offheap(oh, a->type, a->id); +} + +static void +insert_offheap(ErlOffHeap *oh, int type, Eterm id) +{ + if(oh->externals) { + ExternalThing *etp = oh->externals; + while (etp) { + insert_node(etp->node, type, id); + etp = etp->next; + } + } + + if(oh->mso) { + ProcBin *pb; + struct insert_offheap2_arg a; + a.type = BIN_REF; + for(pb = oh->mso; pb; pb = pb->next) { + if(IsMatchProgBinary(pb->val)) { + InsertedBin *ib; + int insert_bin = 1; + for (ib = inserted_bins; ib; ib = ib->next) + if(ib->bin_val == pb->val) { + insert_bin = 0; + break; + } + if (insert_bin) { + Uint id_heap[BIG_UINT_HEAP_SIZE]; + Uint *hp = &id_heap[0]; + InsertedBin *nib; + a.id = erts_bld_uint(&hp, NULL, (Uint) pb->val); + erts_match_prog_foreach_offheap(pb->val, + insert_offheap2, + (void *) &a); + nib = erts_alloc(ERTS_ALC_T_NC_TMP, sizeof(InsertedBin)); + nib->bin_val = pb->val; + nib->next = inserted_bins; + inserted_bins = nib; + } + } + } + } + +#if 0 + if(oh->funs) { + /* No need to */ + } +#endif +} + +static void doit_insert_monitor(ErtsMonitor *monitor, void *p) +{ + Eterm *idp = p; + if(is_external(monitor->pid)) + insert_node(external_thing_ptr(monitor->pid)->node, MONITOR_REF, *idp); + if(is_external(monitor->ref)) + insert_node(external_thing_ptr(monitor->ref)->node, MONITOR_REF, *idp); +} + +static void doit_insert_link(ErtsLink *lnk, void *p) +{ + Eterm *idp = p; + if(is_external(lnk->pid)) + insert_node(external_thing_ptr(lnk->pid)->node, LINK_REF, + *idp); +} + + +static void +insert_monitors(ErtsMonitor *monitors, Eterm id) +{ + erts_doforall_monitors(monitors,&doit_insert_monitor,&id); +} + +static void +insert_links(ErtsLink *lnk, Eterm id) +{ + erts_doforall_links(lnk,&doit_insert_link,&id); +} + +static void doit_insert_link2(ErtsLink *lnk, void *p) +{ + Eterm *idp = p; + if(is_external(lnk->pid)) + insert_node(external_thing_ptr(lnk->pid)->node, LINK_REF, + *idp); + insert_links(ERTS_LINK_ROOT(lnk), *idp); +} + +static void +insert_links2(ErtsLink *lnk, Eterm id) +{ + erts_doforall_links(lnk,&doit_insert_link2,&id); +} + +static void +insert_ets_table(DbTable *tab, void *unused) +{ + struct insert_offheap2_arg a; + a.type = ETS_REF; + a.id = tab->common.id; + erts_db_foreach_offheap(tab, insert_offheap2, (void *) &a); +} + +static void +insert_bif_timer(Eterm receiver, Eterm msg, ErlHeapFragment *bp, void *arg) +{ + if (bp) { + Eterm heap[3]; + insert_offheap(&bp->off_heap, + TIMER_REF, + (is_internal_pid(receiver) + ? receiver + : TUPLE2(&heap[0], AM_process, receiver))); + } +} + +static void +init_referred_node(void *node, void *unused) +{ + referred_nodes[no_referred_nodes].node = (ErlNode *) node; + referred_nodes[no_referred_nodes].referrers = NULL; + no_referred_nodes++; +} + +static void +init_referred_dist(void *dist, void *unused) +{ + referred_dists[no_referred_dists].dist = (DistEntry *) dist; + referred_dists[no_referred_dists].referrers = NULL; + no_referred_dists++; +} + +#ifdef ERTS_SMP +static void +insert_sys_msg(Eterm from, Eterm to, Eterm msg, ErlHeapFragment *bp) +{ + insert_offheap(&bp->off_heap, HEAP_REF, to); +} +#endif + +static void +setup_reference_table(void) +{ + ErlHeapFragment *hfp; + DistEntry *dep; + HashInfo hi; + int i; + Eterm heap[3]; + + inserted_bins = NULL; + + hash_get_info(&hi, &erts_node_table); + referred_nodes = erts_alloc(ERTS_ALC_T_NC_TMP, + hi.objs*sizeof(ReferredNode)); + no_referred_nodes = 0; + hash_foreach(&erts_node_table, init_referred_node, NULL); + ASSERT(no_referred_nodes == hi.objs); + + hash_get_info(&hi, &erts_dist_table); + referred_dists = erts_alloc(ERTS_ALC_T_NC_TMP, + hi.objs*sizeof(ReferredDist)); + no_referred_dists = 0; + hash_foreach(&erts_dist_table, init_referred_dist, NULL); + ASSERT(no_referred_dists == hi.objs); + + /* Go through the hole system, and build a table of all references + to ErlNode and DistEntry structures */ + + insert_node(erts_this_node, + SYSTEM_REF, + TUPLE2(&heap[0], AM_system, am_undefined)); + +#ifdef HYBRID + /* Insert Heap */ + insert_offheap(&erts_global_offheap, + HEAP_REF, + TUPLE2(&heap[0], AM_processes, am_undefined)); +#endif + + /* Insert all processes */ + for (i = 0; i < erts_max_processes; i++) + if (process_tab[i]) { + ErlMessage *msg; + /* Insert Heap */ + insert_offheap(&(process_tab[i]->off_heap), + HEAP_REF, + process_tab[i]->id); + /* Insert message buffers */ + for(hfp = process_tab[i]->mbuf; hfp; hfp = hfp->next) + insert_offheap(&(hfp->off_heap), + HEAP_REF, + process_tab[i]->id); + /* Insert msg msg buffers */ + for (msg = process_tab[i]->msg.first; msg; msg = msg->next) { + ErlHeapFragment *heap_frag = NULL; + if (msg->data.attached) { + if (is_value(ERL_MESSAGE_TERM(msg))) + heap_frag = msg->data.heap_frag; + else { + if (msg->data.dist_ext->dep) + insert_dist_entry(msg->data.dist_ext->dep, + HEAP_REF, process_tab[i]->id, 0); + if (is_not_nil(ERL_MESSAGE_TOKEN(msg))) + heap_frag = erts_dist_ext_trailer(msg->data.dist_ext); + } + } + if (heap_frag) + insert_offheap(&(heap_frag->off_heap), + HEAP_REF, + process_tab[i]->id); + } +#ifdef ERTS_SMP + for (msg = process_tab[i]->msg_inq.first; msg; msg = msg->next) { + ErlHeapFragment *heap_frag = NULL; + if (msg->data.attached) { + if (is_value(ERL_MESSAGE_TERM(msg))) + heap_frag = msg->data.heap_frag; + else { + if (msg->data.dist_ext->dep) + insert_dist_entry(msg->data.dist_ext->dep, + HEAP_REF, process_tab[i]->id, 0); + if (is_not_nil(ERL_MESSAGE_TOKEN(msg))) + heap_frag = erts_dist_ext_trailer(msg->data.dist_ext); + } + } + if (heap_frag) + insert_offheap(&(heap_frag->off_heap), + HEAP_REF, + process_tab[i]->id); + } +#endif + /* Insert links */ + if(process_tab[i]->nlinks) + insert_links(process_tab[i]->nlinks, process_tab[i]->id); + if(process_tab[i]->monitors) + insert_monitors(process_tab[i]->monitors, process_tab[i]->id); + /* Insert controller */ + { + DistEntry *dep = ERTS_PROC_GET_DIST_ENTRY(process_tab[i]); + if (dep) + insert_dist_entry(dep, CTRL_REF, process_tab[i]->id, 0); + } + } + +#ifdef ERTS_SMP + erts_foreach_sys_msg_in_q(insert_sys_msg); +#endif + + /* Insert all ports */ + for (i = 0; i < erts_max_ports; i++) { + if (erts_port[i].status & ERTS_PORT_SFLGS_DEAD) + continue; + + /* Insert links */ + if(erts_port[i].nlinks) + insert_links(erts_port[i].nlinks, erts_port[i].id); + /* Insert port data */ + for(hfp = erts_port[i].bp; hfp; hfp = hfp->next) + insert_offheap(&(hfp->off_heap), HEAP_REF, erts_port[i].id); + /* Insert controller */ + if (erts_port[i].dist_entry) + insert_dist_entry(erts_port[i].dist_entry, + CTRL_REF, + erts_port[i].id, + 0); + } + + { /* Add binaries stored elsewhere ... */ + ErlOffHeap oh; + ProcBin pb[2] = {{0},{0}}; + ProcBin *mso = NULL; + int i = 0; + Binary *default_match_spec; + Binary *default_meta_match_spec; + + /* Only the ProcBin members val and next will be inspected + (by insert_offheap()) */ +#undef ADD_BINARY +#define ADD_BINARY(Bin) \ + if ((Bin)) { \ + pb[i].val = (Bin); \ + pb[i].next = mso; \ + mso = &pb[i]; \ + i++; \ + } + + erts_get_default_trace_pattern(NULL, + &default_match_spec, + &default_meta_match_spec, + NULL, + NULL); + + ADD_BINARY(default_match_spec); + ADD_BINARY(default_meta_match_spec); + + oh.mso = mso; + oh.externals = NULL; +#ifndef HYBRID /* FIND ME! */ + oh.funs = NULL; +#endif + insert_offheap(&oh, BIN_REF, AM_match_spec); +#undef ADD_BINARY + } + + /* Insert all dist links */ + + for(dep = erts_visible_dist_entries; dep; dep = dep->next) { + if(dep->nlinks) + insert_links2(dep->nlinks, dep->sysname); + if(dep->node_links) + insert_links(dep->node_links, dep->sysname); + if(dep->monitors) + insert_monitors(dep->monitors, dep->sysname); + } + + for(dep = erts_hidden_dist_entries; dep; dep = dep->next) { + if(dep->nlinks) + insert_links2(dep->nlinks, dep->sysname); + if(dep->node_links) + insert_links(dep->node_links, dep->sysname); + if(dep->monitors) + insert_monitors(dep->monitors, dep->sysname); + } + + /* Not connected dist entries should not have any links, + but inspect them anyway */ + for(dep = erts_not_connected_dist_entries; dep; dep = dep->next) { + if(dep->nlinks) + insert_links2(dep->nlinks, dep->sysname); + if(dep->node_links) + insert_links(dep->node_links, dep->sysname); + if(dep->monitors) + insert_monitors(dep->monitors, dep->sysname); + } + + /* Insert all ets tables */ + erts_db_foreach_table(insert_ets_table, NULL); + + /* Insert all bif timers */ + erts_bif_timer_foreach(insert_bif_timer, NULL); + + /* Insert node table (references to dist) */ + hash_foreach(&erts_node_table, insert_erl_node, NULL); +} + +/* + Returns an erlang term on this format: + + {{node_references, + [{{Node, Creation}, Refc, + [{{ReferrerType, ID}, + [{ReferenceType,References}, + '...']}, + '...']}, + '...']}, + {dist_references, + [{Node, Refc, + [{{ReferrerType, ID}, + [{ReferenceType,References}, + '...']}, + '...']}, + '...']}} + */ + +static Eterm +reference_table_term(Uint **hpp, Uint *szp) +{ +#undef MK_2TUP +#undef MK_3TUP +#undef MK_CONS +#undef MK_UINT +#define MK_2TUP(E1, E2) erts_bld_tuple(hpp, szp, 2, (E1), (E2)) +#define MK_3TUP(E1, E2, E3) erts_bld_tuple(hpp, szp, 3, (E1), (E2), (E3)) +#define MK_CONS(CAR, CDR) erts_bld_cons(hpp, szp, (CAR), (CDR)) +#define MK_UINT(UI) erts_bld_uint(hpp, szp, (UI)) + int i; + Eterm tup; + Eterm tup2; + Eterm nl = NIL; + Eterm dl = NIL; + Eterm nrid; + + for(i = 0; i < no_referred_nodes; i++) { + NodeReferrer *nrp; + Eterm nril = NIL; + + for(nrp = referred_nodes[i].referrers; nrp; nrp = nrp->next) { + Eterm nrl = NIL; + /* NodeReferenceList = [{ReferenceType,References}] */ + if(nrp->heap_ref) { + tup = MK_2TUP(AM_heap, MK_UINT(nrp->heap_ref)); + nrl = MK_CONS(tup, nrl); + } + if(nrp->link_ref) { + tup = MK_2TUP(AM_link, MK_UINT(nrp->link_ref)); + nrl = MK_CONS(tup, nrl); + } + if(nrp->monitor_ref) { + tup = MK_2TUP(AM_monitor, MK_UINT(nrp->monitor_ref)); + nrl = MK_CONS(tup, nrl); + } + if(nrp->ets_ref) { + tup = MK_2TUP(AM_ets, MK_UINT(nrp->ets_ref)); + nrl = MK_CONS(tup, nrl); + } + if(nrp->bin_ref) { + tup = MK_2TUP(AM_binary, MK_UINT(nrp->bin_ref)); + nrl = MK_CONS(tup, nrl); + } + if(nrp->timer_ref) { + tup = MK_2TUP(AM_timer, MK_UINT(nrp->timer_ref)); + nrl = MK_CONS(tup, nrl); + } + if(nrp->system_ref) { + tup = MK_2TUP(AM_system, MK_UINT(nrp->system_ref)); + nrl = MK_CONS(tup, nrl); + } + + nrid = nrp->id; + if (!IS_CONST(nrp->id)) { + + Uint nrid_sz = size_object(nrp->id); + if (szp) + *szp += nrid_sz; + if (hpp) + nrid = copy_struct(nrp->id, nrid_sz, hpp, NULL); + } + + if (is_internal_pid(nrid) || nrid == am_error_logger) { + ASSERT(!nrp->ets_ref && !nrp->bin_ref && !nrp->system_ref); + tup = MK_2TUP(AM_process, nrid); + } + else if (is_tuple(nrid)) { + Eterm *t; + ASSERT(!nrp->ets_ref && !nrp->bin_ref); + t = tuple_val(nrid); + ASSERT(2 == arityval(t[0])); + tup = MK_2TUP(t[1], t[2]); + } + else if(is_internal_port(nrid)) { + ASSERT(!nrp->heap_ref && !nrp->ets_ref && !nrp->bin_ref + && !nrp->timer_ref && !nrp->system_ref); + tup = MK_2TUP(AM_port, nrid); + } + else if(nrp->ets_ref) { + ASSERT(!nrp->heap_ref && !nrp->link_ref && + !nrp->monitor_ref && !nrp->bin_ref + && !nrp->timer_ref && !nrp->system_ref); + tup = MK_2TUP(AM_ets, nrid); + } + else if(nrp->bin_ref) { + ASSERT(is_small(nrid) || is_big(nrid)); + ASSERT(!nrp->heap_ref && !nrp->ets_ref && !nrp->link_ref && + !nrp->monitor_ref && !nrp->timer_ref + && !nrp->system_ref); + tup = MK_2TUP(AM_match_spec, nrid); + } + else { + ASSERT(!nrp->heap_ref && !nrp->ets_ref && !nrp->bin_ref); + ASSERT(is_atom(nrid)); + tup = MK_2TUP(AM_dist, nrid); + } + tup = MK_2TUP(tup, nrl); + /* NodeReferenceIdList = [{{ReferrerType, ID}, NodeReferenceList}] */ + nril = MK_CONS(tup, nril); + } + + /* NodeList = [{{Node, Creation}, Refc, NodeReferenceIdList}] */ + + tup = MK_2TUP(referred_nodes[i].node->sysname, + MK_UINT(referred_nodes[i].node->creation)); + tup = MK_3TUP(tup, MK_UINT(erts_refc_read(&referred_nodes[i].node->refc, 1)), nril); + nl = MK_CONS(tup, nl); + } + + for(i = 0; i < no_referred_dists; i++) { + DistReferrer *drp; + Eterm dril = NIL; + for(drp = referred_dists[i].referrers; drp; drp = drp->next) { + Eterm drl = NIL; + + /* DistReferenceList = [{ReferenceType,References}] */ + if(drp->node_ref) { + tup = MK_2TUP(AM_node, MK_UINT(drp->node_ref)); + drl = MK_CONS(tup, drl); + } + if(drp->ctrl_ref) { + tup = MK_2TUP(AM_control, MK_UINT(drp->ctrl_ref)); + drl = MK_CONS(tup, drl); + } + if(drp->heap_ref) { + tup = MK_2TUP(AM_heap, MK_UINT(drp->heap_ref)); + drl = MK_CONS(tup, drl); + } + + if (is_internal_pid(drp->id)) { + ASSERT(!drp->node_ref); + tup = MK_2TUP(AM_process, drp->id); + } + else if(is_internal_port(drp->id)) { + ASSERT(drp->ctrl_ref && !drp->node_ref); + tup = MK_2TUP(AM_port, drp->id); + } + else { + ASSERT(!drp->ctrl_ref && drp->node_ref); + ASSERT(is_atom(drp->id)); + tup = MK_2TUP(drp->id, MK_UINT(drp->creation)); + tup = MK_2TUP(AM_node, tup); + } + + tup = MK_2TUP(tup, drl); + + /* DistReferenceIdList = + [{{ReferrerType, ID}, DistReferenceList}] */ + dril = MK_CONS(tup, dril); + + } + + /* DistList = [{Dist, Refc, ReferenceIdList}] */ + tup = MK_3TUP(referred_dists[i].dist->sysname, + MK_UINT(erts_refc_read(&referred_dists[i].dist->refc, 1)), + dril); + dl = MK_CONS(tup, dl); + } + + /* {{node_references, NodeList}, {dist_references, DistList}} */ + + tup = MK_2TUP(AM_node_references, nl); + tup2 = MK_2TUP(AM_dist_references, dl); + tup = MK_2TUP(tup, tup2); + + return tup; +#undef MK_2TUP +#undef MK_3TUP +#undef MK_CONS +#undef MK_UINT + +} + +static void +delete_reference_table(void) +{ + Uint i; + for(i = 0; i < no_referred_nodes; i++) { + NodeReferrer *nrp; + NodeReferrer *tnrp; + nrp = referred_nodes[i].referrers; + while(nrp) { + tnrp = nrp; + nrp = nrp->next; + erts_free(ERTS_ALC_T_NC_TMP, (void *) tnrp); + } + } + if (referred_nodes) + erts_free(ERTS_ALC_T_NC_TMP, (void *) referred_nodes); + + for(i = 0; i < no_referred_dists; i++) { + DistReferrer *drp; + DistReferrer *tdrp; + drp = referred_dists[i].referrers; + while(drp) { + tdrp = drp; + drp = drp->next; + erts_free(ERTS_ALC_T_NC_TMP, (void *) tdrp); + } + } + if (referred_dists) + erts_free(ERTS_ALC_T_NC_TMP, (void *) referred_dists); + while(inserted_bins) { + InsertedBin *ib = inserted_bins; + inserted_bins = inserted_bins->next; + erts_free(ERTS_ALC_T_NC_TMP, (void *)ib); + } +} + diff --git a/erts/emulator/beam/erl_node_tables.h b/erts/emulator/beam/erl_node_tables.h new file mode 100644 index 0000000000..c48dac6219 --- /dev/null +++ b/erts/emulator/beam/erl_node_tables.h @@ -0,0 +1,261 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2001-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifndef ERL_NODE_TABLES_H__ +#define ERL_NODE_TABLES_H__ + +/* + * The "node_tables module" contain two (hash) tables: the node_table + * and the dist_table. + * + * The elements of the node_table represents a specific incarnation of + * an Erlang node and has {Nodename, Creation} pairs as keys. Elements + * in the node_table are referred to from node containers (see + * node_container_utils.h). + * + * The elements of the dist_table represents a (potential) connection + * to an Erlang node and has Nodename as key. Elements in the + * dist_table are either referred to from elements in the node_table + * or from the process or port structure of the entity controlling + * the connection. + * + * Both tables are garbage collected by reference counting. + */ + +#include "sys.h" +#include "hash.h" +#include "erl_process.h" +#include "erl_monitors.h" +#include "erl_smp.h" +#define ERTS_PORT_TASK_ONLY_BASIC_TYPES__ +#include "erl_port_task.h" +#undef ERTS_PORT_TASK_ONLY_BASIC_TYPES__ + +#define ERST_INTERNAL_CHANNEL_NO 0 + +#define ERTS_DE_SFLG_CONNECTED (((Uint32) 1) << 0) +#define ERTS_DE_SFLG_EXITING (((Uint32) 1) << 1) + +#define ERTS_DE_SFLGS_ALL (ERTS_DE_SFLG_CONNECTED \ + | ERTS_DE_SFLG_EXITING) + +#define ERTS_DE_QFLG_BUSY (((Uint32) 1) << 0) +#define ERTS_DE_QFLG_EXIT (((Uint32) 1) << 1) + +#define ERTS_DE_QFLGS_ALL (ERTS_DE_QFLG_BUSY \ + | ERTS_DE_QFLG_EXIT) + +#ifdef ARCH_64 +#define ERTS_DIST_OUTPUT_BUF_DBG_PATTERN ((Uint) 0xf713f713f713f713UL) +#else +#define ERTS_DIST_OUTPUT_BUF_DBG_PATTERN ((Uint) 0xf713f713) +#endif + +typedef struct ErtsDistOutputBuf_ ErtsDistOutputBuf; +struct ErtsDistOutputBuf_ { +#ifdef DEBUG + Uint dbg_pattern; +#endif + ErtsDistOutputBuf *next; + byte *extp; + byte *ext_endp; + byte data[1]; +}; + +typedef struct { + ErtsDistOutputBuf *first; + ErtsDistOutputBuf *last; +} ErtsDistOutputQueue; + +struct ErtsProcList_; +typedef struct { + struct ErtsProcList_ *first; + struct ErtsProcList_ *last; +} ErtsDistSuspended; + +/* + * Lock order: + * 1. dist_entry->rwmtx + * 2. erts_node_table_rwmtx + * 3. erts_dist_table_rwmtx + * + * Lock mutexes with lower numbers before mutexes with higher numbers and + * unlock mutexes with higher numbers before mutexes with higher numbers. + */ + +struct erl_link; +struct port; + +typedef struct dist_entry_ { + HashBucket hash_bucket; /* Hash bucket */ + struct dist_entry_ *next; /* Next entry in dist_table (not sorted) */ + struct dist_entry_ *prev; /* Previous entry in dist_table (not sorted) */ + erts_refc_t refc; /* Reference count */ + + erts_smp_rwmtx_t rwmtx; /* Protects all fields below until lck_mtx. */ + Eterm sysname; /* name@host atom for efficiency */ + Uint32 creation; /* creation of connected node */ + Eterm cid; /* connection handler (pid or port), NIL == free */ + Uint32 connection_id; /* Connection id incremented on connect */ + Uint32 status; /* Slot status, like exiting reserved etc */ + Uint32 flags; /* Distribution flags, like hidden, + atom cache etc. */ + unsigned long version; /* Protocol version */ + + + erts_smp_mtx_t lnk_mtx; /* Protects node_links, nlinks, and + monitors. */ + ErtsLink *node_links; /* In a dist entry, node links are kept + in a separate tree, while they are + colocted with the ordinary link tree + for processes. It's not due to confusion, + it's because the link tree for the dist + entry is in two levels, see erl_monitors.h + */ + ErtsLink *nlinks; /* Link tree with subtrees */ + ErtsMonitor *monitors; /* Monitor tree */ + + erts_smp_spinlock_t qlock; /* Protects qflgs and out_queue */ + Uint32 qflgs; + Sint qsize; + ErtsDistOutputQueue out_queue; + ErtsDistSuspended suspended; + + ErtsDistOutputQueue finalized_out_queue; + erts_smp_atomic_t dist_cmd_scheduled; + ErtsPortTaskHandle dist_cmd; + + Uint (*send)(struct port *prt, ErtsDistOutputBuf *obuf); + + struct cache* cache; /* The atom cache */ +} DistEntry; + +typedef struct erl_node_ { + HashBucket hash_bucket; /* Hash bucket */ + erts_refc_t refc; /* Reference count */ + Eterm sysname; /* name@host atom for efficiency */ + Uint32 creation; /* Creation */ + DistEntry *dist_entry; /* Corresponding dist entry */ +} ErlNode; + + +extern Hash erts_dist_table; +extern Hash erts_node_table; +extern erts_smp_rwmtx_t erts_dist_table_rwmtx; +extern erts_smp_rwmtx_t erts_node_table_rwmtx; + +extern DistEntry *erts_hidden_dist_entries; +extern DistEntry *erts_visible_dist_entries; +extern DistEntry *erts_not_connected_dist_entries; +extern Sint erts_no_of_hidden_dist_entries; +extern Sint erts_no_of_visible_dist_entries; +extern Sint erts_no_of_not_connected_dist_entries; + +extern DistEntry *erts_this_dist_entry; +extern ErlNode *erts_this_node; + +DistEntry *erts_channel_no_to_dist_entry(Uint); +DistEntry *erts_sysname_to_connected_dist_entry(Eterm); +DistEntry *erts_find_or_insert_dist_entry(Eterm); +DistEntry *erts_find_dist_entry(Eterm); +void erts_delete_dist_entry(DistEntry *); +Uint erts_dist_table_size(void); +void erts_dist_table_info(int, void *); +void erts_set_dist_entry_not_connected(DistEntry *); +void erts_set_dist_entry_connected(DistEntry *, Eterm, Uint); +ErlNode *erts_find_or_insert_node(Eterm, Uint); +void erts_delete_node(ErlNode *); +void erts_set_this_node(Eterm, Uint); +Uint erts_node_table_size(void); +void erts_init_node_tables(void); +void erts_node_table_info(int, void *); +void erts_print_node_info(int, void *, Eterm, int*, int*); +Eterm erts_get_node_and_dist_references(struct process *); +#if defined(ERTS_SMP) && defined(ERTS_ENABLE_LOCK_CHECK) +int erts_lc_is_de_rwlocked(DistEntry *); +int erts_lc_is_de_rlocked(DistEntry *); +#endif + +ERTS_GLB_INLINE void erts_deref_dist_entry(DistEntry *dep); +ERTS_GLB_INLINE void erts_deref_node_entry(ErlNode *np); +ERTS_GLB_INLINE void erts_smp_de_rlock(DistEntry *dep); +ERTS_GLB_INLINE void erts_smp_de_runlock(DistEntry *dep); +ERTS_GLB_INLINE void erts_smp_de_rwlock(DistEntry *dep); +ERTS_GLB_INLINE void erts_smp_de_rwunlock(DistEntry *dep); +ERTS_GLB_INLINE void erts_smp_de_links_lock(DistEntry *dep); +ERTS_GLB_INLINE void erts_smp_de_links_unlock(DistEntry *dep); + +#if ERTS_GLB_INLINE_INCL_FUNC_DEF + +ERTS_GLB_INLINE void +erts_deref_dist_entry(DistEntry *dep) +{ + ASSERT(dep); + if (erts_refc_dectest(&dep->refc, 0) == 0) + erts_delete_dist_entry(dep); +} + +ERTS_GLB_INLINE void +erts_deref_node_entry(ErlNode *np) +{ + ASSERT(np); + if (erts_refc_dectest(&np->refc, 0) == 0) + erts_delete_node(np); +} + +ERTS_GLB_INLINE void +erts_smp_de_rlock(DistEntry *dep) +{ + erts_smp_rwmtx_rlock(&dep->rwmtx); +} + +ERTS_GLB_INLINE void +erts_smp_de_runlock(DistEntry *dep) +{ + erts_smp_rwmtx_runlock(&dep->rwmtx); +} + +ERTS_GLB_INLINE void +erts_smp_de_rwlock(DistEntry *dep) +{ + erts_smp_rwmtx_rwlock(&dep->rwmtx); +} + +ERTS_GLB_INLINE void +erts_smp_de_rwunlock(DistEntry *dep) +{ + erts_smp_rwmtx_rwunlock(&dep->rwmtx); +} + +ERTS_GLB_INLINE void +erts_smp_de_links_lock(DistEntry *dep) +{ + erts_smp_mtx_lock(&dep->lnk_mtx); +} + +ERTS_GLB_INLINE void +erts_smp_de_links_unlock(DistEntry *dep) +{ + erts_smp_mtx_unlock(&dep->lnk_mtx); +} + +#endif /* #if ERTS_GLB_INLINE_INCL_FUNC_DEF */ + + +#endif diff --git a/erts/emulator/beam/erl_obsolete.c b/erts/emulator/beam/erl_obsolete.c new file mode 100644 index 0000000000..9c5a7c7ff9 --- /dev/null +++ b/erts/emulator/beam/erl_obsolete.c @@ -0,0 +1,186 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2004-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_driver.h" + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *\ + * * + * ------------------------- OBSOLETE! DO NOT USE! ------------------------- * + * * +\* */ + +/* cut from ../obsolete/driver.h (since it doesn't mix well with other + * headers from the emulator). + */ +#ifdef __WIN32__ +#ifdef CONST +# undef CONST +#endif +#endif + +#if ((defined(__STDC__) || defined(SABER)) && !defined(NO_PROTOTYPE)) || defined(__cplusplus) || defined(USE_PROTOTYPE) +# define _USING_PROTOTYPES_ 1 +# define _ANSI_ARGS_(x) x +# define CONST const +#else +# define _ANSI_ARGS_(x) () +# define CONST +#endif + +typedef void* erl_mutex_t; +typedef void* erl_cond_t; +typedef void* erl_thread_t; + +EXTERN erl_mutex_t erts_mutex_create _ANSI_ARGS_((void)); +EXTERN int erts_mutex_destroy _ANSI_ARGS_((erl_mutex_t)); +EXTERN int erts_mutex_lock _ANSI_ARGS_((erl_mutex_t)); +EXTERN int erts_mutex_unlock _ANSI_ARGS_((erl_mutex_t)); + +EXTERN erl_cond_t erts_cond_create _ANSI_ARGS_((void)); +EXTERN int erts_cond_destroy _ANSI_ARGS_((erl_cond_t)); +EXTERN int erts_cond_signal _ANSI_ARGS_((erl_cond_t)); +EXTERN int erts_cond_broadcast _ANSI_ARGS_((erl_cond_t)); +EXTERN int erts_cond_wait _ANSI_ARGS_((erl_cond_t, erl_mutex_t)); +EXTERN int erts_cond_timedwait _ANSI_ARGS_((erl_cond_t, erl_mutex_t, long)); + +EXTERN int erts_thread_create _ANSI_ARGS_((erl_thread_t*, + void* (*func)(void*), + void* arg, + int detached)); +EXTERN erl_thread_t erts_thread_self _ANSI_ARGS_((void)); +EXTERN void erts_thread_exit _ANSI_ARGS_((void*)); +EXTERN int erts_thread_join _ANSI_ARGS_((erl_thread_t, void**)); +EXTERN int erts_thread_kill _ANSI_ARGS_((erl_thread_t)); + +/* + * These functions implement the thread interface in ../obsolete/driver.h. + * Do *not* use this interface! Within the emulator, use the erl_threads.h, + * erl_smp.h, or ethread.h interface. From a driver use the thread interface + * in erl_driver.h. + */ + +erl_mutex_t +erts_mutex_create(void) +{ + return (erl_mutex_t) erl_drv_mutex_create(NULL); +} + +int +erts_mutex_destroy(erl_mutex_t mtx) +{ + erl_drv_mutex_destroy((ErlDrvMutex *) mtx); + return 0; +} + +int +erts_mutex_lock(erl_mutex_t mtx) +{ + erl_drv_mutex_lock((ErlDrvMutex *) mtx); + return 0; +} + +int +erts_mutex_unlock(erl_mutex_t mtx) +{ + erl_drv_mutex_unlock((ErlDrvMutex *) mtx); + return 0; +} + +erl_cond_t +erts_cond_create(void) +{ + return (erl_cond_t) erl_drv_cond_create(NULL); +} + +int +erts_cond_destroy(erl_cond_t cnd) +{ + erl_drv_cond_destroy((ErlDrvCond *) cnd); + return 0; +} + + +int +erts_cond_signal(erl_cond_t cnd) +{ + erl_drv_cond_signal((ErlDrvCond *) cnd); + return 0; +} + +int +erts_cond_broadcast(erl_cond_t cnd) +{ + erl_drv_cond_broadcast((ErlDrvCond *) cnd); + return 0; +} + + +int +erts_cond_wait(erl_cond_t cnd, erl_mutex_t mtx) +{ + erl_drv_cond_wait((ErlDrvCond *) cnd, (ErlDrvMutex *) mtx); + return 0; +} + +int +erts_cond_timedwait(erl_cond_t cnd, erl_mutex_t mtx, long ms) +{ + return ENOTSUP; +} + +int +erts_thread_create(erl_thread_t *tid, + void* (*func)(void*), + void* arg, + int detached) +{ + if (detached) + return ENOTSUP; + return erl_drv_thread_create(NULL, (ErlDrvTid *) tid, func, arg, NULL); +} + +erl_thread_t +erts_thread_self(void) +{ + return (erl_thread_t) erl_drv_thread_self(); +} + +void +erts_thread_exit(void *res) +{ + erl_drv_thread_exit(res); +} + +int +erts_thread_join(erl_thread_t tid, void **respp) +{ + return erl_drv_thread_join((ErlDrvTid) tid, respp); +} + +int +erts_thread_kill(erl_thread_t tid) +{ + return ENOTSUP; +} + diff --git a/erts/emulator/beam/erl_port_task.c b/erts/emulator/beam/erl_port_task.c new file mode 100644 index 0000000000..0fb264a53c --- /dev/null +++ b/erts/emulator/beam/erl_port_task.c @@ -0,0 +1,1100 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2006-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* + * Description: Scheduling of port tasks + * + * Author: Rickard Green + */ + +#define ERL_PORT_TASK_C__ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "global.h" +#include "erl_port_task.h" +#include "dist.h" + +#if defined(DEBUG) && 0 +#define HARD_DEBUG +#endif + +/* + * Costs in reductions for some port operations. + */ +#define ERTS_PORT_REDS_EXECUTE 0 +#define ERTS_PORT_REDS_FREE 50 +#define ERTS_PORT_REDS_TIMEOUT 200 +#define ERTS_PORT_REDS_INPUT 200 +#define ERTS_PORT_REDS_OUTPUT 200 +#define ERTS_PORT_REDS_EVENT 200 +#define ERTS_PORT_REDS_TERMINATE 100 + + +#define ERTS_PORT_TASK_INVALID_PORT(P, ID) \ + ((erts_port_status_get((P)) & ERTS_PORT_SFLGS_DEAD) || (P)->id != (ID)) + +#define ERTS_PORT_IS_IN_RUNQ(RQ, P) \ + ((P)->sched.next || (P)->sched.prev || (RQ)->ports.start == (P)) + +#define ERTS_PORT_NOT_IN_RUNQ(P) \ +do { \ + (P)->sched.prev = NULL; \ + (P)->sched.next = NULL; \ +} while (0) + +erts_smp_atomic_t erts_port_task_outstanding_io_tasks; + +struct ErtsPortTaskQueue_ { + ErtsPortTask *first; + ErtsPortTask *last; + Port *port; +}; + +struct ErtsPortTask_ { + ErtsPortTask *prev; + ErtsPortTask *next; + ErtsPortTaskQueue *queue; + ErtsPortTaskHandle *handle; + ErtsPortTaskType type; + ErlDrvEvent event; + ErlDrvEventData event_data; +}; + +#ifdef HARD_DEBUG +#define ERTS_PT_CHK_PORTQ(RQ) check_port_queue((RQ), NULL, 0) +#define ERTS_PT_CHK_PRES_PORTQ(RQ, PP) check_port_queue((RQ), (PP), -1) +#define ERTS_PT_CHK_IN_PORTQ(RQ, PP) check_port_queue((RQ), (PP), 1) +#define ERTS_PT_CHK_NOT_IN_PORTQ(RQ, PP) check_port_queue((RQ), (PP), 0) +#define ERTS_PT_CHK_TASKQ(Q) check_task_queue((Q), NULL, 0) +#define ERTS_PT_CHK_IN_TASKQ(Q, T) check_task_queue((Q), (T), 1) +#define ERTS_PT_CHK_NOT_IN_TASKQ(Q, T) check_task_queue((Q), (T), 0) +static void +check_port_queue(Port *chk_pp, int inq); +static void +check_task_queue(ErtsPortTaskQueue *ptqp, + ErtsPortTask *chk_ptp, + int inq); +#else +#define ERTS_PT_CHK_PORTQ(RQ) +#define ERTS_PT_CHK_PRES_PORTQ(RQ, PP) +#define ERTS_PT_CHK_IN_PORTQ(RQ, PP) +#define ERTS_PT_CHK_NOT_IN_PORTQ(RQ, PP) +#define ERTS_PT_CHK_TASKQ(Q) +#define ERTS_PT_CHK_IN_TASKQ(Q, T) +#define ERTS_PT_CHK_NOT_IN_TASKQ(Q, T) +#endif + +static void handle_remaining_tasks(ErtsRunQueue *runq, Port *pp); + +ERTS_SCHED_PREF_QUICK_ALLOC_IMPL(port_task, + ErtsPortTask, + 200, + ERTS_ALC_T_PORT_TASK) +ERTS_SCHED_PREF_QUICK_ALLOC_IMPL(port_taskq, + ErtsPortTaskQueue, + 50, + ERTS_ALC_T_PORT_TASKQ) + +/* + * Task handle manipulation. + */ + +static ERTS_INLINE ErtsPortTask * +handle2task(ErtsPortTaskHandle *pthp) +{ + return (ErtsPortTask *) erts_smp_atomic_read(pthp); +} + +static ERTS_INLINE void +reset_handle(ErtsPortTask *ptp) +{ + if (ptp->handle) { + ASSERT(ptp == handle2task(ptp->handle)); + erts_smp_atomic_set(ptp->handle, (long) NULL); + } +} + +static ERTS_INLINE void +set_handle(ErtsPortTask *ptp, ErtsPortTaskHandle *pthp) +{ + ptp->handle = pthp; + if (pthp) { + erts_smp_atomic_set(pthp, (long) ptp); + ASSERT(ptp == handle2task(ptp->handle)); + } +} + +/* + * Port queue operations + */ + +static ERTS_INLINE void +enqueue_port(ErtsRunQueue *runq, Port *pp) +{ + ERTS_SMP_LC_ASSERT(erts_smp_lc_runq_is_locked(runq)); + pp->sched.next = NULL; + pp->sched.prev = runq->ports.end; + if (runq->ports.end) { + ASSERT(runq->ports.start); + runq->ports.end->sched.next = pp; + } + else { + ASSERT(!runq->ports.start); + runq->ports.start = pp; + } + + runq->ports.info.len++; + if (runq->ports.info.max_len < runq->ports.info.len) + runq->ports.info.max_len = runq->ports.info.len; + runq->len++; + if (runq->max_len < runq->len) + runq->max_len = runq->len; + runq->ports.end = pp; + ASSERT(runq->ports.start && runq->ports.end); +} + +static ERTS_INLINE void +dequeue_port(ErtsRunQueue *runq, Port *pp) +{ + ERTS_SMP_LC_ASSERT(erts_smp_lc_runq_is_locked(runq)); + if (pp->sched.next) + pp->sched.next->sched.prev = pp->sched.prev; + else { + ASSERT(runq->ports.end == pp); + runq->ports.end = pp->sched.prev; + } + if (pp->sched.prev) + pp->sched.prev->sched.next = pp->sched.next; + else { + ASSERT(runq->ports.start == pp); + runq->ports.start = pp->sched.next; + } + + ASSERT(runq->ports.info.len > 0); + runq->ports.info.len--; + ASSERT(runq->len > 0); + runq->len--; + ASSERT(runq->ports.start || !runq->ports.end); + ASSERT(runq->ports.end || !runq->ports.start); +} + +static ERTS_INLINE Port * +pop_port(ErtsRunQueue *runq) +{ + Port *pp = runq->ports.start; + ERTS_SMP_LC_ASSERT(erts_smp_lc_runq_is_locked(runq)); + if (!pp) { + ASSERT(!runq->ports.end); + } + else { + runq->ports.start = runq->ports.start->sched.next; + if (runq->ports.start) + runq->ports.start->sched.prev = NULL; + else { + ASSERT(runq->ports.end == pp); + runq->ports.end = NULL; + } + ASSERT(runq->ports.info.len > 0); + runq->ports.info.len--; + ASSERT(runq->len > 0); + runq->len--; + } + + ASSERT(runq->ports.start || !runq->ports.end); + ASSERT(runq->ports.end || !runq->ports.start); + return pp; +} + + +#ifdef HARD_DEBUG + +static void +check_port_queue(ErtsRunQueue *runq, Port *chk_pp, int inq) +{ + Port *pp; + Port *last_pp; + Port *first_pp = runq->ports.start; + int no_forward = 0, no_backward = 0; + int found_forward = 0, found_backward = 0; + if (!first_pp) { + ASSERT(!runq->ports.end); + } + else { + ASSERT(!first_pp->sched.prev); + for (pp = first_pp; pp; pp = pp->sched.next) { + ASSERT(pp->sched.taskq); + if (pp->sched.taskq->first) + no_forward++; + if (chk_pp == pp) + found_forward = 1; + if (!pp->sched.prev) { + ASSERT(first_pp == pp); + } + if (!pp->sched.next) { + ASSERT(runq->ports.end == pp); + last_pp = pp; + } + } + for (pp = last_pp; pp; pp = pp->sched.prev) { + ASSERT(pp->sched.taskq); + if (pp->sched.taskq->last) + no_backward++; + if (chk_pp == pp) + found_backward = 1; + if (!pp->sched.prev) { + ASSERT(first_pp == pp); + } + if (!pp->sched.next) { + ASSERT(runq->ports.end == pp); + } + check_task_queue(pp->sched.taskq, NULL, 0); + } + ASSERT(no_forward == no_backward); + } + ASSERT(no_forward == runq->ports.info.len); + if (chk_pp) { + if (chk_pp->sched.taskq || chk_pp->sched.exe_taskq) { + ASSERT(chk_pp->sched.taskq != chk_pp->sched.exe_taskq); + } + ASSERT(!chk_pp->sched.taskq || chk_pp->sched.taskq->first); + if (inq < 0) + inq = chk_pp->sched.taskq && !chk_pp->sched.exe_taskq; + if (inq) { + ASSERT(found_forward && found_backward); + } + else { + ASSERT(!found_forward && !found_backward); + } + } +} + +#endif + +/* + * Task queue operations + */ + +static ERTS_INLINE ErtsPortTaskQueue * +port_taskq_init(ErtsPortTaskQueue *ptqp, Port *pp) +{ + if (ptqp) { + ptqp->first = NULL; + ptqp->last = NULL; + ptqp->port = pp; + } + return ptqp; +} + +static ERTS_INLINE void +enqueue_task(ErtsPortTaskQueue *ptqp, ErtsPortTask *ptp) +{ + ERTS_PT_CHK_NOT_IN_TASKQ(ptqp, ptp); + ptp->next = NULL; + ptp->prev = ptqp->last; + ptp->queue = ptqp; + if (ptqp->last) { + ASSERT(ptqp->first); + ptqp->last->next = ptp; + } + else { + ASSERT(!ptqp->first); + ptqp->first = ptp; + } + ptqp->last = ptp; + ERTS_PT_CHK_IN_TASKQ(ptqp, ptp); +} + +static ERTS_INLINE void +push_task(ErtsPortTaskQueue *ptqp, ErtsPortTask *ptp) +{ + ERTS_PT_CHK_NOT_IN_TASKQ(ptqp, ptp); + ptp->next = ptqp->first; + ptp->prev = NULL; + ptp->queue = ptqp; + if (ptqp->first) { + ASSERT(ptqp->last); + ptqp->first->prev = ptp; + } + else { + ASSERT(!ptqp->last); + ptqp->last = ptp; + } + ptqp->first = ptp; + ERTS_PT_CHK_IN_TASKQ(ptqp, ptp); +} + +static ERTS_INLINE void +dequeue_task(ErtsPortTask *ptp) +{ + ASSERT(ptp); + ASSERT(ptp->queue); + ERTS_PT_CHK_IN_TASKQ(ptp->queue, ptp); + if (ptp->next) + ptp->next->prev = ptp->prev; + else { + ASSERT(ptp->queue->last == ptp); + ptp->queue->last = ptp->prev; + } + if (ptp->prev) + ptp->prev->next = ptp->next; + else { + ASSERT(ptp->queue->first == ptp); + ptp->queue->first = ptp->next; + } + + ASSERT(ptp->queue->first || !ptp->queue->last); + ASSERT(ptp->queue->last || !ptp->queue->first); + ERTS_PT_CHK_NOT_IN_TASKQ(ptp->queue, ptp); +} + +static ERTS_INLINE ErtsPortTask * +pop_task(ErtsPortTaskQueue *ptqp) +{ + ErtsPortTask *ptp = ptqp->first; + if (!ptp) { + ASSERT(!ptqp->last); + } + else { + ERTS_PT_CHK_IN_TASKQ(ptqp, ptp); + ASSERT(!ptp->prev); + ptqp->first = ptp->next; + if (ptqp->first) + ptqp->first->prev = NULL; + else { + ASSERT(ptqp->last == ptp); + ptqp->last = NULL; + } + ASSERT(ptp->queue->first || !ptp->queue->last); + ASSERT(ptp->queue->last || !ptp->queue->first); + } + ERTS_PT_CHK_NOT_IN_TASKQ(ptqp, ptp); + return ptp; +} + +#ifdef HARD_DEBUG + +static void +check_task_queue(ErtsPortTaskQueue *ptqp, + ErtsPortTask *chk_ptp, + int inq) +{ + ErtsPortTask *ptp; + ErtsPortTask *last_ptp; + ErtsPortTask *first_ptp = ptqp->first; + int found_forward = 0, found_backward = 0; + if (!first_ptp) { + ASSERT(!ptqp->last); + } + else { + ASSERT(!first_ptp->prev); + for (ptp = first_ptp; ptp; ptp = ptp->next) { + ASSERT(ptp->queue == ptqp); + if (chk_ptp == ptp) + found_forward = 1; + if (!ptp->prev) { + ASSERT(first_ptp == ptp); + } + if (!ptp->next) { + ASSERT(ptqp->last == ptp); + last_ptp = ptp; + } + } + for (ptp = last_ptp; ptp; ptp = ptp->prev) { + ASSERT(ptp->queue == ptqp); + if (chk_ptp == ptp) + found_backward = 1; + if (!ptp->prev) { + ASSERT(first_ptp == ptp); + } + if (!ptp->next) { + ASSERT(ptqp->last == ptp); + } + } + } + if (chk_ptp) { + if (inq) { + ASSERT(found_forward && found_backward); + } + else { + ASSERT(!found_forward && !found_backward); + } + } +} +#endif + +/* + * Abort a scheduled task. + */ + +int +erts_port_task_abort(Eterm id, ErtsPortTaskHandle *pthp) +{ + ErtsRunQueue *runq; + ErtsPortTaskQueue *ptqp; + ErtsPortTask *ptp; + Port *pp; + int port_is_dequeued = 0; + + pp = &erts_port[internal_port_index(id)]; + runq = erts_port_runq(pp); + + ptp = handle2task(pthp); + + if (!ptp) { + erts_smp_runq_unlock(runq); + return 1; + } + + ASSERT(ptp->handle == pthp); + ptqp = ptp->queue; + ASSERT(pp == ptqp->port); + + ERTS_PT_CHK_PRES_PORTQ(runq, pp); + ASSERT(ptqp); + ASSERT(ptqp->first); + + dequeue_task(ptp); + reset_handle(ptp); + + switch (ptp->type) { + case ERTS_PORT_TASK_INPUT: + case ERTS_PORT_TASK_OUTPUT: + case ERTS_PORT_TASK_EVENT: + ASSERT(erts_smp_atomic_read(&erts_port_task_outstanding_io_tasks) > 0); + erts_smp_atomic_dec(&erts_port_task_outstanding_io_tasks); + break; + default: + break; + } + + ASSERT(ptqp == pp->sched.taskq || ptqp == pp->sched.exe_taskq); + + if (ptqp->first || pp->sched.taskq != ptqp) + ptqp = NULL; + else { + pp->sched.taskq = NULL; + if (!pp->sched.exe_taskq) { + dequeue_port(runq, pp); + ERTS_PORT_NOT_IN_RUNQ(pp); + port_is_dequeued = 1; + } + } + + ERTS_PT_CHK_PRES_PORTQ(runq, pp); + + erts_smp_runq_unlock(runq); + + if (erts_system_profile_flags.runnable_ports && port_is_dequeued) { + profile_runnable_port(pp, am_inactive); + } + + port_task_free(ptp); + if (ptqp) + port_taskq_free(ptqp); + + return 0; +} + +/* + * Schedule a task. + */ + +int +erts_port_task_schedule(Eterm id, + ErtsPortTaskHandle *pthp, + ErtsPortTaskType type, + ErlDrvEvent event, + ErlDrvEventData event_data) +{ + ErtsRunQueue *runq; + Port *pp; + ErtsPortTask *ptp; + int enq_port = 0; + + /* + * NOTE: We might not have the port lock here. We are only + * allowed to access the 'sched', 'tab_status', + * and 'id' fields of the port struct while + * tasks_lock is held. + */ + + if (pthp && erts_port_task_is_scheduled(pthp)) { + ASSERT(0); + erts_port_task_abort(id, pthp); + } + + ptp = port_task_alloc(); + + ASSERT(is_internal_port(id)); + pp = &erts_port[internal_port_index(id)]; + runq = erts_port_runq(pp); + + if (!runq || ERTS_PORT_TASK_INVALID_PORT(pp, id)) { + if (runq) + erts_smp_runq_unlock(runq); + return -1; + } + + ASSERT(!erts_port_task_is_scheduled(pthp)); + + ERTS_PT_CHK_PRES_PORTQ(runq, pp); + + if (!pp->sched.taskq) { + pp->sched.taskq = port_taskq_init(port_taskq_alloc(), pp); + enq_port = !pp->sched.exe_taskq; + } + +#ifdef ERTS_SMP + if (enq_port) { + ErtsRunQueue *xrunq = erts_check_emigration_need(runq, ERTS_PORT_PRIO_LEVEL); + if (xrunq) { + /* Port emigrated ... */ + erts_smp_atomic_set(&pp->run_queue, (long) xrunq); + erts_smp_runq_unlock(runq); + runq = xrunq; + } + } +#endif + + ASSERT(!(runq->flags & ERTS_RUNQ_FLG_SUSPENDED)); + + ASSERT(pp->sched.taskq); + ASSERT(ptp); + + ptp->type = type; + ptp->event = event; + ptp->event_data = event_data; + + set_handle(ptp, pthp); + + switch (type) { + case ERTS_PORT_TASK_FREE: + erl_exit(ERTS_ABORT_EXIT, + "erts_port_task_schedule(): Cannot schedule free task\n"); + break; + case ERTS_PORT_TASK_INPUT: + case ERTS_PORT_TASK_OUTPUT: + case ERTS_PORT_TASK_EVENT: + erts_smp_atomic_inc(&erts_port_task_outstanding_io_tasks); + /* Fall through... */ + default: + enqueue_task(pp->sched.taskq, ptp); + break; + } + +#if defined(HARD_DEBUG) + if (pp->sched.exe_taskq || enq_port) + ERTS_PT_CHK_NOT_IN_PORTQ(runq, pp); + else + ERTS_PT_CHK_IN_PORTQ(runq, pp); +#elif defined(DEBUG) + if (!enq_port && !pp->sched.exe_taskq) { + /* We should be in port run q */ + ASSERT(pp->sched.prev || runq->ports.start == pp); + } +#endif + + if (!enq_port) { + ERTS_PT_CHK_PRES_PORTQ(runq, pp); + } + else { + enqueue_port(runq, pp); + ERTS_PT_CHK_PRES_PORTQ(runq, pp); + + if (erts_system_profile_flags.runnable_ports) { + profile_runnable_port(pp, am_active); + } + + erts_smp_notify_inc_runq(runq); + } + erts_smp_runq_unlock(runq); + return 0; +} + +void +erts_port_task_free_port(Port *pp) +{ + ErtsRunQueue *runq; + int port_is_dequeued = 0; + + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(pp)); + ASSERT(!(pp->status & ERTS_PORT_SFLGS_DEAD)); + runq = erts_port_runq(pp); + ASSERT(runq); + ERTS_PT_CHK_PRES_PORTQ(runq, pp); + if (pp->sched.exe_taskq) { + /* I (this thread) am currently executing this port, free it + when scheduled out... */ + ErtsPortTask *ptp = port_task_alloc(); + erts_smp_port_state_lock(pp); + ASSERT(erts_smp_atomic_read(&erts_ports_alive) > 0); + erts_smp_atomic_dec(&erts_ports_alive); + pp->status &= ~ERTS_PORT_SFLG_CLOSING; + pp->status |= ERTS_PORT_SFLG_FREE_SCHEDULED; + erts_may_save_closed_port(pp); + erts_smp_port_state_unlock(pp); + ERTS_SMP_LC_ASSERT(erts_smp_atomic_read(&pp->refc) > 1); + ptp->type = ERTS_PORT_TASK_FREE; + ptp->event = (ErlDrvEvent) -1; + ptp->event_data = NULL; + set_handle(ptp, NULL); + push_task(pp->sched.exe_taskq, ptp); + ERTS_PT_CHK_PRES_PORTQ(runq, pp); + erts_smp_runq_unlock(runq); + } + else { + ErtsPortTaskQueue *ptqp = pp->sched.taskq; + if (ptqp) { + dequeue_port(runq, pp); + ERTS_PORT_NOT_IN_RUNQ(pp); + port_is_dequeued = 1; + } + erts_smp_port_state_lock(pp); + erts_smp_atomic_dec(&erts_ports_alive); + pp->status &= ~ERTS_PORT_SFLG_CLOSING; + pp->status |= ERTS_PORT_SFLG_FREE_SCHEDULED; + erts_may_save_closed_port(pp); + erts_smp_port_state_unlock(pp); +#ifdef ERTS_SMP + erts_smp_atomic_dec(&pp->refc); /* Not alive */ +#endif + ERTS_SMP_LC_ASSERT(erts_smp_atomic_read(&pp->refc) > 0); /* Lock */ + handle_remaining_tasks(runq, pp); /* May release runq lock */ + ASSERT(!pp->sched.exe_taskq && (!ptqp || !ptqp->first)); + pp->sched.taskq = NULL; + ERTS_PT_CHK_PRES_PORTQ(runq, pp); +#ifndef ERTS_SMP + ASSERT(pp->status & ERTS_PORT_SFLG_PORT_DEBUG); + erts_port_status_set(pp, ERTS_PORT_SFLG_FREE); +#endif + erts_smp_runq_unlock(runq); + + if (erts_system_profile_flags.runnable_ports && port_is_dequeued) { + profile_runnable_port(pp, am_inactive); + } + + if (ptqp) + port_taskq_free(ptqp); + } +} + +typedef struct { + ErtsRunQueue *runq; + int *resp; +} ErtsPortTaskExeBlockData; + +static void +prepare_for_block(void *vd) +{ + ErtsPortTaskExeBlockData *d = (ErtsPortTaskExeBlockData *) vd; + erts_smp_runq_unlock(d->runq); +} + +static void +resume_after_block(void *vd) +{ + ErtsPortTaskExeBlockData *d = (ErtsPortTaskExeBlockData *) vd; + erts_smp_runq_lock(d->runq); + if (d->resp) + *d->resp = erts_smp_atomic_read(&erts_port_task_outstanding_io_tasks) != (long) 0; +} + +/* + * Run all scheduled tasks for the first port in run queue. If + * new tasks appear while running reschedule port (free task is + * an exception; it is always handled instantly). + * + * erts_port_task_execute() is called by scheduler threads between + * scheduleing of processes. Sched lock should be held by caller. + */ + +int +erts_port_task_execute(ErtsRunQueue *runq, Port **curr_port_pp) +{ + int port_was_enqueued = 0; + Port *pp; + ErtsPortTaskQueue *ptqp; + ErtsPortTask *ptp; + int res = 0; + int reds = ERTS_PORT_REDS_EXECUTE; + long io_tasks_executed = 0; + int fpe_was_unmasked; + ErtsPortTaskExeBlockData blk_data = {runq, NULL}; + + ERTS_SMP_LC_ASSERT(erts_smp_lc_runq_is_locked(runq)); + + erts_smp_activity_begin(ERTS_ACTIVITY_IO, + prepare_for_block, + resume_after_block, + (void *) &blk_data); + + ERTS_PT_CHK_PORTQ(runq); + + pp = pop_port(runq); + if (!pp) { + res = 0; + goto done; + } + + ERTS_PORT_NOT_IN_RUNQ(pp); + + *curr_port_pp = pp; + + ASSERT(pp->sched.taskq); + ASSERT(pp->sched.taskq->first); + ptqp = pp->sched.taskq; + pp->sched.taskq = NULL; + + ASSERT(!pp->sched.exe_taskq); + pp->sched.exe_taskq = ptqp; + + if (erts_smp_port_trylock(pp) == EBUSY) { + erts_smp_runq_unlock(runq); + erts_smp_port_lock(pp); + erts_smp_runq_lock(runq); + } + + if (erts_sched_stat.enabled) { + ErtsSchedulerData *esdp = erts_get_scheduler_data(); + Uint old = ERTS_PORT_SCHED_ID(pp, esdp->no); + int migrated = old && old != esdp->no; + + erts_smp_spin_lock(&erts_sched_stat.lock); + erts_sched_stat.prio[ERTS_PORT_PRIO_LEVEL].total_executed++; + erts_sched_stat.prio[ERTS_PORT_PRIO_LEVEL].executed++; + if (migrated) { + erts_sched_stat.prio[ERTS_PORT_PRIO_LEVEL].total_migrated++; + erts_sched_stat.prio[ERTS_PORT_PRIO_LEVEL].migrated++; + } + erts_smp_spin_unlock(&erts_sched_stat.lock); + } + + /* trace port scheduling, in */ + if (IS_TRACED_FL(pp, F_TRACE_SCHED_PORTS)) { + trace_sched_ports(pp, am_in); + } + + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(pp)); + + ERTS_PT_CHK_PRES_PORTQ(runq, pp); + ptp = pop_task(ptqp); + + fpe_was_unmasked = erts_block_fpe(); + + while (ptp) { + ASSERT(pp->sched.taskq != pp->sched.exe_taskq); + + reset_handle(ptp); + erts_smp_runq_unlock(runq); + + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(pp)); + ERTS_SMP_CHK_NO_PROC_LOCKS; + ASSERT(pp->drv_ptr); + + switch (ptp->type) { + case ERTS_PORT_TASK_FREE: /* May be pushed in q at any time */ + reds += ERTS_PORT_REDS_FREE; + erts_smp_runq_lock(runq); + + erts_unblock_fpe(fpe_was_unmasked); + ASSERT(pp->status & ERTS_PORT_SFLG_FREE_SCHEDULED); + if (ptqp->first || (pp->sched.taskq && pp->sched.taskq->first)) + handle_remaining_tasks(runq, pp); + ASSERT(!ptqp->first + && (!pp->sched.taskq || !pp->sched.taskq->first)); +#ifdef ERTS_SMP + erts_smp_atomic_dec(&pp->refc); /* Not alive */ + ERTS_SMP_LC_ASSERT(erts_smp_atomic_read(&pp->refc) > 0); /* Lock */ +#else + erts_port_status_bor_set(pp, ERTS_PORT_SFLG_FREE); +#endif + + port_task_free(ptp); + if (pp->sched.taskq) + port_taskq_free(pp->sched.taskq); + pp->sched.taskq = NULL; + + goto tasks_done; + case ERTS_PORT_TASK_TIMEOUT: + reds += ERTS_PORT_REDS_TIMEOUT; + if (!(pp->status & ERTS_PORT_SFLGS_DEAD)) + (*pp->drv_ptr->timeout)((ErlDrvData) pp->drv_data); + break; + case ERTS_PORT_TASK_INPUT: + reds += ERTS_PORT_REDS_INPUT; + ASSERT((pp->status & ERTS_PORT_SFLGS_DEAD) == 0); + /* NOTE some windows drivers use ->ready_input for input and output */ + (*pp->drv_ptr->ready_input)((ErlDrvData) pp->drv_data, ptp->event); + io_tasks_executed++; + break; + case ERTS_PORT_TASK_OUTPUT: + reds += ERTS_PORT_REDS_OUTPUT; + ASSERT((pp->status & ERTS_PORT_SFLGS_DEAD) == 0); + (*pp->drv_ptr->ready_output)((ErlDrvData) pp->drv_data, ptp->event); + io_tasks_executed++; + break; + case ERTS_PORT_TASK_EVENT: + reds += ERTS_PORT_REDS_EVENT; + ASSERT((pp->status & ERTS_PORT_SFLGS_DEAD) == 0); + (*pp->drv_ptr->event)((ErlDrvData) pp->drv_data, ptp->event, ptp->event_data); + io_tasks_executed++; + break; + case ERTS_PORT_TASK_DIST_CMD: + reds += erts_dist_command(pp, CONTEXT_REDS-reds); + break; + default: + erl_exit(ERTS_ABORT_EXIT, + "Invalid port task type: %d\n", + (int) ptp->type); + break; + } + + if ((pp->status & ERTS_PORT_SFLG_CLOSING) + && erts_is_port_ioq_empty(pp)) { + reds += ERTS_PORT_REDS_TERMINATE; + erts_terminate_port(pp); + } + + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(pp)); + +#ifdef ERTS_SMP + if (pp->xports) + erts_smp_xports_unlock(pp); + ASSERT(!pp->xports); +#endif + + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(pp)); + + port_task_free(ptp); + + erts_smp_runq_lock(runq); + + ptp = pop_task(ptqp); + } + + tasks_done: + + erts_unblock_fpe(fpe_was_unmasked); + + if (io_tasks_executed) { + ASSERT(erts_smp_atomic_read(&erts_port_task_outstanding_io_tasks) >= io_tasks_executed); + erts_smp_atomic_add(&erts_port_task_outstanding_io_tasks, -1*io_tasks_executed); + } + + *curr_port_pp = NULL; + + if (pp->sched.taskq) { + ASSERT(!(pp->status & ERTS_PORT_SFLGS_DEAD)); + ASSERT(pp->sched.taskq->first); + enqueue_port(runq, pp); + port_was_enqueued = 1; + + /* + erts_smp_notify_inc_runq(); + + * No need to notify schedulers about the increase in run + * queue length since at least this thread, which is a + * scheduler, will discover that the port run queue isn't + * empty before trying to go to sleep. + */ + } + + ASSERT(pp->sched.exe_taskq); + pp->sched.exe_taskq = NULL; + + res = erts_smp_atomic_read(&erts_port_task_outstanding_io_tasks) != (long) 0; + + ERTS_PT_CHK_PRES_PORTQ(runq, pp); + + port_taskq_free(ptqp); + + if (erts_system_profile_flags.runnable_ports && (port_was_enqueued != 1)) { + profile_runnable_port(pp, am_inactive); + } + + /* trace port scheduling, out */ + if (IS_TRACED_FL(pp, F_TRACE_SCHED_PORTS)) { + trace_sched_ports(pp, am_out); + } +#ifndef ERTS_SMP + erts_port_release(pp); +#else + { + long refc = erts_smp_atomic_dectest(&pp->refc); + ASSERT(refc >= 0); + if (refc > 0) + erts_smp_mtx_unlock(pp->lock); + else { + erts_smp_runq_unlock(runq); + erts_port_cleanup(pp); /* Might aquire runq lock */ + erts_smp_runq_lock(runq); + res = erts_smp_atomic_read(&erts_port_task_outstanding_io_tasks) != (long) 0; + } + } +#endif + + done: + blk_data.resp = &res; + erts_smp_activity_end(ERTS_ACTIVITY_IO, + prepare_for_block, + resume_after_block, + (void *) &blk_data); + + ERTS_SMP_LC_ASSERT(erts_smp_lc_runq_is_locked(runq)); + + ERTS_PORT_REDUCTIONS_EXECUTED(runq, reds); + + return res; +} + +/* + * Handle remaining tasks after a free task. + */ + +static void +handle_remaining_tasks(ErtsRunQueue *runq, Port *pp) +{ + int i; + ErtsPortTask *ptp; + ErtsPortTaskQueue *ptqps[] = {pp->sched.exe_taskq, pp->sched.taskq}; + + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(pp)); + + for (i = 0; i < sizeof(ptqps)/sizeof(ErtsPortTaskQueue *); i++) { + if (!ptqps[i]) + continue; + + ptp = pop_task(ptqps[i]); + while (ptp) { + reset_handle(ptp); + erts_smp_runq_unlock(runq); + + switch (ptp->type) { + case ERTS_PORT_TASK_FREE: + case ERTS_PORT_TASK_TIMEOUT: + break; + case ERTS_PORT_TASK_INPUT: + erts_stale_drv_select(pp->id, ptp->event, DO_READ, 1); + break; + case ERTS_PORT_TASK_OUTPUT: + erts_stale_drv_select(pp->id, ptp->event, DO_WRITE, 1); + break; + case ERTS_PORT_TASK_EVENT: + erts_stale_drv_select(pp->id, ptp->event, 0, 1); + break; + case ERTS_PORT_TASK_DIST_CMD: + break; + default: + erl_exit(ERTS_ABORT_EXIT, + "Invalid port task type: %d\n", + (int) ptp->type); + } + + port_task_free(ptp); + + erts_smp_runq_lock(runq); + ptp = pop_task(ptqps[i]); + } + } + + ASSERT(!pp->sched.taskq || !pp->sched.taskq->first); +} + +int +erts_port_is_scheduled(Port *pp) +{ + int res; + ErtsRunQueue *runq = erts_port_runq(pp); + res = pp->sched.taskq || pp->sched.exe_taskq; + erts_smp_runq_unlock(runq); + return res; +} + +#ifdef ERTS_SMP + +ErtsMigrateResult +erts_port_migrate(Port *prt, int *prt_locked, + ErtsRunQueue *from_rq, int *from_locked, + ErtsRunQueue *to_rq, int *to_locked) +{ + ERTS_SMP_LC_ASSERT(*from_locked); + ERTS_SMP_LC_CHK_RUNQ_LOCK(from_rq, *from_locked); + ERTS_SMP_LC_CHK_RUNQ_LOCK(to_rq, *to_locked); + + ASSERT(!erts_common_run_queue); + + if (!*from_locked || !*to_locked) { + if (from_rq < to_rq) { + if (!*to_locked) { + if (!*from_locked) + erts_smp_runq_lock(from_rq); + erts_smp_runq_lock(to_rq); + } + else if (erts_smp_runq_trylock(from_rq) == EBUSY) { + erts_smp_runq_unlock(to_rq); + erts_smp_runq_lock(from_rq); + erts_smp_runq_lock(to_rq); + } + } + else { + if (!*from_locked) { + if (!*to_locked) + erts_smp_runq_lock(to_rq); + erts_smp_runq_lock(from_rq); + } + else if (erts_smp_runq_trylock(to_rq) == EBUSY) { + erts_smp_runq_unlock(from_rq); + erts_smp_runq_lock(to_rq); + erts_smp_runq_lock(from_rq); + } + } + *to_locked = *from_locked = 1; + } + ERTS_SMP_LC_CHK_RUNQ_LOCK(from_rq, *from_locked); + ERTS_SMP_LC_CHK_RUNQ_LOCK(to_rq, *to_locked); + + /* Refuse to migrate to a suspended run queue */ + if (to_rq->flags & ERTS_RUNQ_FLG_SUSPENDED) + return ERTS_MIGRATE_FAILED_RUNQ_SUSPENDED; + if (from_rq != (ErtsRunQueue *) erts_smp_atomic_read(&prt->run_queue)) + return ERTS_MIGRATE_FAILED_RUNQ_CHANGED; + if (!ERTS_PORT_IS_IN_RUNQ(from_rq, prt)) + return ERTS_MIGRATE_FAILED_NOT_IN_RUNQ; + dequeue_port(from_rq, prt); + erts_smp_atomic_set(&prt->run_queue, (long) to_rq); + enqueue_port(to_rq, prt); + erts_smp_notify_inc_runq(to_rq); + return ERTS_MIGRATE_SUCCESS; +} + +#endif + +/* + * Initialize the module. + */ +void +erts_port_task_init(void) +{ + erts_smp_atomic_init(&erts_port_task_outstanding_io_tasks, (long) 0); + init_port_task_alloc(); + init_port_taskq_alloc(); +} diff --git a/erts/emulator/beam/erl_port_task.h b/erts/emulator/beam/erl_port_task.h new file mode 100644 index 0000000000..f12d02da0c --- /dev/null +++ b/erts/emulator/beam/erl_port_task.h @@ -0,0 +1,135 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2006-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* + * Description: Scheduling of port tasks + * + * Author: Rickard Green + */ + +#ifndef ERTS_PORT_TASK_H_BASIC_TYPES__ +#define ERTS_PORT_TASK_H_BASIC_TYPES__ +#include "erl_sys_driver.h" +#include "erl_smp.h" +typedef erts_smp_atomic_t ErtsPortTaskHandle; +#endif + +#ifndef ERTS_PORT_TASK_ONLY_BASIC_TYPES__ +#ifndef ERL_PORT_TASK_H__ +#define ERL_PORT_TASK_H__ + +#undef ERTS_INCLUDE_SCHEDULER_INTERNALS +#if (defined(ERL_PROCESS_C__) \ + || defined(ERL_PORT_TASK_C__) \ + || defined(ERL_IO_C__) \ + || (ERTS_GLB_INLINE_INCL_FUNC_DEF \ + && defined(ERTS_DO_INCL_GLB_INLINE_FUNC_DEF))) +#define ERTS_INCLUDE_SCHEDULER_INTERNALS +#endif + +typedef enum { + ERTS_PORT_TASK_FREE, + ERTS_PORT_TASK_INPUT, + ERTS_PORT_TASK_OUTPUT, + ERTS_PORT_TASK_EVENT, + ERTS_PORT_TASK_TIMEOUT, + ERTS_PORT_TASK_DIST_CMD +} ErtsPortTaskType; + +#ifdef ERTS_INCLUDE_SCHEDULER_INTERNALS +/* NOTE: Do not access any of the exported variables directly */ +extern erts_smp_atomic_t erts_port_task_outstanding_io_tasks; +#endif + +typedef struct ErtsPortTask_ ErtsPortTask; +typedef struct ErtsPortTaskQueue_ ErtsPortTaskQueue; + +typedef struct { + Port *next; + Port *prev; + ErtsPortTaskQueue *taskq; + ErtsPortTaskQueue *exe_taskq; +} ErtsPortTaskSched; + +ERTS_GLB_INLINE void erts_port_task_handle_init(ErtsPortTaskHandle *pthp); +ERTS_GLB_INLINE int erts_port_task_is_scheduled(ErtsPortTaskHandle *pthp); +ERTS_GLB_INLINE void erts_port_task_init_sched(ErtsPortTaskSched *ptsp); +#ifdef ERTS_INCLUDE_SCHEDULER_INTERNALS +ERTS_GLB_INLINE int erts_port_task_have_outstanding_io_tasks(void); +#endif + +#if ERTS_GLB_INLINE_INCL_FUNC_DEF + +ERTS_GLB_INLINE void +erts_port_task_handle_init(ErtsPortTaskHandle *pthp) +{ + erts_smp_atomic_init(pthp, (long) NULL); +} + +ERTS_GLB_INLINE int +erts_port_task_is_scheduled(ErtsPortTaskHandle *pthp) +{ + return ((void *) erts_smp_atomic_read(pthp)) != NULL; +} + +ERTS_GLB_INLINE void +erts_port_task_init_sched(ErtsPortTaskSched *ptsp) +{ + ptsp->next = NULL; + ptsp->prev = NULL; + ptsp->taskq = NULL; + ptsp->exe_taskq = NULL; +} + +#ifdef ERTS_INCLUDE_SCHEDULER_INTERNALS + +ERTS_GLB_INLINE int +erts_port_task_have_outstanding_io_tasks(void) +{ + return erts_smp_atomic_read(&erts_port_task_outstanding_io_tasks) != 0; +} + +#endif /* ERTS_INCLUDE_SCHEDULER_INTERNALS */ + +#endif + +#ifdef ERTS_INCLUDE_SCHEDULER_INTERNALS +int erts_port_task_execute(ErtsRunQueue *, Port **); +void erts_port_task_init(void); +#endif + +int erts_port_task_abort(Eterm id, ErtsPortTaskHandle *); +int erts_port_task_schedule(Eterm, + ErtsPortTaskHandle *, + ErtsPortTaskType, + ErlDrvEvent, + ErlDrvEventData); +void erts_port_task_free_port(Port *); +int erts_port_is_scheduled(Port *); +#ifdef ERTS_SMP +ErtsMigrateResult erts_port_migrate(Port *, + int *, + ErtsRunQueue *, + int *, + ErtsRunQueue *, + int *); +#endif +#undef ERTS_INCLUDE_SCHEDULER_INTERNALS +#endif /* ERL_PORT_TASK_H__ */ +#endif /* ERTS_PORT_TASK_ONLY_BASIC_TYPES__ */ diff --git a/erts/emulator/beam/erl_posix_str.c b/erts/emulator/beam/erl_posix_str.c new file mode 100644 index 0000000000..02db10905b --- /dev/null +++ b/erts/emulator/beam/erl_posix_str.c @@ -0,0 +1,641 @@ +/* + * Original: tclPosixStr.c -- + * + * This file contains procedures that generate strings + * corresponding to various POSIX-related codes, such + * as errno and signals. + * + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclPosixStr.c 1.32 96/10/10 10:09:42 + */ + +/* %ExternalCopyright% */ +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#ifdef __WIN32__ +#ifndef WINDOWS_H_INCLUDES_WINSOCK2_H +#include +#endif +#include +#endif + +#include "erl_errno.h" +#include "sys.h" +#include "erl_driver.h" + +/* + *---------------------------------------------------------------------- + * + * erl_errno_id -- + * + * Return a textual identifier for the given errno value. + * + * Results: + * This procedure returns a machine-readable textual identifier + * that corresponds to the current errno value (e.g. "eperm"). + * The identifier is the same as the #define name in errno.h, + * except that it is in lowercase. + * + *---------------------------------------------------------------------- + */ + +char * +erl_errno_id(error) + int error; /* Posix error number (as from errno). */ +{ + switch (error) { +#ifdef E2BIG + case E2BIG: return "e2big"; +#endif +#ifdef EACCES + case EACCES: return "eacces"; +#endif +#ifdef EADDRINUSE + case EADDRINUSE: return "eaddrinuse"; +#endif +#ifdef EADDRNOTAVAIL + case EADDRNOTAVAIL: return "eaddrnotavail"; +#endif +#ifdef EADV + case EADV: return "eadv"; +#endif +#ifdef EAFNOSUPPORT + case EAFNOSUPPORT: return "eafnosupport"; +#endif +#ifdef EAGAIN + case EAGAIN: return "eagain"; +#endif +#ifdef EALIGN + case EALIGN: return "ealign"; +#endif +#if defined(EALREADY) && (!defined(EBUSY) || (EALREADY != EBUSY )) + case EALREADY: return "ealready"; +#endif +#ifdef EBADE + case EBADE: return "ebade"; +#endif +#ifdef EBADF + case EBADF: return "ebadf"; +#endif +#ifdef EBADFD + case EBADFD: return "ebadfd"; +#endif +#ifdef EBADMSG + case EBADMSG: return "ebadmsg"; +#endif +#ifdef EBADR + case EBADR: return "ebadr"; +#endif +#ifdef EBADRPC + case EBADRPC: return "ebadrpc"; +#endif +#ifdef EBADRQC + case EBADRQC: return "ebadrqc"; +#endif +#ifdef EBADSLT + case EBADSLT: return "ebadslt"; +#endif +#ifdef EBFONT + case EBFONT: return "ebfont"; +#endif +#ifdef EBUSY + case EBUSY: return "ebusy"; +#endif +#ifdef ECHILD + case ECHILD: return "echild"; +#endif +#ifdef ECHRNG + case ECHRNG: return "echrng"; +#endif +#ifdef ECOMM + case ECOMM: return "ecomm"; +#endif +#ifdef ECONNABORTED + case ECONNABORTED: return "econnaborted"; +#endif +#ifdef ECONNREFUSED + case ECONNREFUSED: return "econnrefused"; +#endif +#ifdef ECONNRESET + case ECONNRESET: return "econnreset"; +#endif +#if defined(EDEADLK) && (!defined(EWOULDBLOCK) || (EDEADLK != EWOULDBLOCK)) + case EDEADLK: return "edeadlk"; +#endif +#if defined(EDEADLOCK) && (!defined(EDEADLK) || (EDEADLOCK != EDEADLK)) + case EDEADLOCK: return "edeadlock"; +#endif +#ifdef EDESTADDRREQ + case EDESTADDRREQ: return "edestaddrreq"; +#endif +#ifdef EDIRTY + case EDIRTY: return "edirty"; +#endif +#ifdef EDOM + case EDOM: return "edom"; +#endif +#ifdef EDOTDOT + case EDOTDOT: return "edotdot"; +#endif +#ifdef EDQUOT + case EDQUOT: return "edquot"; +#endif +#ifdef EDUPPKG + case EDUPPKG: return "eduppkg"; +#endif +#ifdef EEXIST + case EEXIST: return "eexist"; +#endif +#ifdef EFAULT + case EFAULT: return "efault"; +#endif +#ifdef EFBIG + case EFBIG: return "efbig"; +#endif +#ifdef EHOSTDOWN + case EHOSTDOWN: return "ehostdown"; +#endif +#ifdef EHOSTUNREACH + case EHOSTUNREACH: return "ehostunreach"; +#endif +#if defined(EIDRM) && (!defined(EINPROGRESS) || (EIDRM != EINPROGRESS)) + case EIDRM: return "eidrm"; +#endif +#ifdef EINIT + case EINIT: return "einit"; +#endif +#ifdef EINPROGRESS + case EINPROGRESS: return "einprogress"; +#endif +#ifdef EINTR + case EINTR: return "eintr"; +#endif +#ifdef EINVAL + case EINVAL: return "einval"; +#endif +#ifdef EIO + case EIO: return "eio"; +#endif +#ifdef EISCONN + case EISCONN: return "eisconn"; +#endif +#ifdef EISDIR + case EISDIR: return "eisdir"; +#endif +#ifdef EISNAME + case EISNAM: return "eisnam"; +#endif +#ifdef ELBIN + case ELBIN: return "elbin"; +#endif +#ifdef EL2HLT + case EL2HLT: return "el2hlt"; +#endif +#ifdef EL2NSYNC + case EL2NSYNC: return "el2nsync"; +#endif +#ifdef EL3HLT + case EL3HLT: return "el3hlt"; +#endif +#ifdef EL3RST + case EL3RST: return "el3rst"; +#endif +#ifdef ELIBACC + case ELIBACC: return "elibacc"; +#endif +#ifdef ELIBBAD + case ELIBBAD: return "elibbad"; +#endif +#ifdef ELIBEXEC + case ELIBEXEC: return "elibexec"; +#endif +#ifdef ELIBMAX + case ELIBMAX: return "elibmax"; +#endif +#ifdef ELIBSCN + case ELIBSCN: return "elibscn"; +#endif +#ifdef ELNRNG + case ELNRNG: return "elnrng"; +#endif +#if defined(ELOOP) && (!defined(ENOENT) || (ELOOP != ENOENT)) + case ELOOP: return "eloop"; +#endif +#ifdef EMFILE + case EMFILE: return "emfile"; +#endif +#ifdef EMLINK + case EMLINK: return "emlink"; +#endif +#ifdef EMSGSIZE + case EMSGSIZE: return "emsgsize"; +#endif +#ifdef EMULTIHOP + case EMULTIHOP: return "emultihop"; +#endif +#ifdef ENAMETOOLONG + case ENAMETOOLONG: return "enametoolong"; +#endif +#ifdef ENAVAIL + case ENAVAIL: return "enavail"; +#endif +#ifdef ENET + case ENET: return "enet"; +#endif +#ifdef ENETDOWN + case ENETDOWN: return "enetdown"; +#endif +#ifdef ENETRESET + case ENETRESET: return "enetreset"; +#endif +#ifdef ENETUNREACH + case ENETUNREACH: return "enetunreach"; +#endif +#ifdef ENFILE + case ENFILE: return "enfile"; +#endif +#ifdef ENOANO + case ENOANO: return "enoano"; +#endif +#if defined(ENOBUFS) && (!defined(ENOSR) || (ENOBUFS != ENOSR)) + case ENOBUFS: return "enobufs"; +#endif +#ifdef ENOCSI + case ENOCSI: return "enocsi"; +#endif +#if defined(ENODATA) && (!defined(ECONNREFUSED) || (ENODATA != ECONNREFUSED)) + case ENODATA: return "enodata"; +#endif +#ifdef ENODEV + case ENODEV: return "enodev"; +#endif +#ifdef ENOENT + case ENOENT: return "enoent"; +#endif +#ifdef ENOEXEC + case ENOEXEC: return "enoexec"; +#endif +#ifdef ENOLCK + case ENOLCK: return "enolck"; +#endif +#ifdef ENOLINK + case ENOLINK: return "enolink"; +#endif +#ifdef ENOMEM + case ENOMEM: return "enomem"; +#endif +#ifdef ENOMSG + case ENOMSG: return "enomsg"; +#endif +#ifdef ENONET + case ENONET: return "enonet"; +#endif +#ifdef ENOPKG + case ENOPKG: return "enopkg"; +#endif +#ifdef ENOPROTOOPT + case ENOPROTOOPT: return "enoprotoopt"; +#endif +#ifdef ENOSPC + case ENOSPC: return "enospc"; +#endif +#if defined(ENOSR) && (!defined(ENAMETOOLONG) || (ENAMETOOLONG != ENOSR)) + case ENOSR: return "enosr"; +#endif +#if defined(ENOSTR) && (!defined(ENOTTY) || (ENOTTY != ENOSTR)) + case ENOSTR: return "enostr"; +#endif +#ifdef ENOSYM + case ENOSYM: return "enosym"; +#endif +#ifdef ENOSYS + case ENOSYS: return "enosys"; +#endif +#ifdef ENOTBLK + case ENOTBLK: return "enotblk"; +#endif +#ifdef ENOTCONN + case ENOTCONN: return "enotconn"; +#endif +#ifdef ENOTDIR + case ENOTDIR: return "enotdir"; +#endif +#if defined(ENOTEMPTY) && (!defined(EEXIST) || (ENOTEMPTY != EEXIST)) + case ENOTEMPTY: return "enotempty"; +#endif +#ifdef ENOTNAM + case ENOTNAM: return "enotnam"; +#endif +#ifdef ENOTSOCK + case ENOTSOCK: return "enotsock"; +#endif +#ifdef ENOTSUP + case ENOTSUP: return "enotsup"; +#endif +#ifdef ENOTTY + case ENOTTY: return "enotty"; +#endif +#ifdef ENOTUNIQ + case ENOTUNIQ: return "enotuniq"; +#endif +#ifdef ENXIO + case ENXIO: return "enxio"; +#endif +#if defined(EOPNOTSUPP) && (!defined(ENOTSUP) || (EOPNOTSUPP != ENOTSUP)) + case EOPNOTSUPP: return "eopnotsupp"; +#endif +#ifdef EPERM + case EPERM: return "eperm"; +#endif +#if defined(EPFNOSUPPORT) && (!defined(ENOLCK) || (ENOLCK != EPFNOSUPPORT)) + case EPFNOSUPPORT: return "epfnosupport"; +#endif +#ifdef EPIPE + case EPIPE: return "epipe"; +#endif +#ifdef EPROCLIM + case EPROCLIM: return "eproclim"; +#endif +#ifdef EPROCUNAVAIL + case EPROCUNAVAIL: return "eprocunavail"; +#endif +#ifdef EPROGMISMATCH + case EPROGMISMATCH: return "eprogmismatch"; +#endif +#ifdef EPROGUNAVAIL + case EPROGUNAVAIL: return "eprogunavail"; +#endif +#ifdef EPROTO + case EPROTO: return "eproto"; +#endif +#ifdef EPROTONOSUPPORT + case EPROTONOSUPPORT: return "eprotonosupport"; +#endif +#ifdef EPROTOTYPE + case EPROTOTYPE: return "eprototype"; +#endif +#ifdef ERANGE + case ERANGE: return "erange"; +#endif +#if defined(EREFUSED) && (!defined(ECONNREFUSED) || (EREFUSED != ECONNREFUSED)) + case EREFUSED: return "erefused"; +#endif +#ifdef EREMCHG + case EREMCHG: return "eremchg"; +#endif +#ifdef EREMDEV + case EREMDEV: return "eremdev"; +#endif +#ifdef EREMOTE + case EREMOTE: return "eremote"; +#endif +#ifdef EREMOTEIO + case EREMOTEIO: return "eremoteio"; +#endif +#ifdef EREMOTERELEASE + case EREMOTERELEASE: return "eremoterelease"; +#endif +#ifdef EROFS + case EROFS: return "erofs"; +#endif +#ifdef ERPCMISMATCH + case ERPCMISMATCH: return "erpcmismatch"; +#endif +#ifdef ERREMOTE + case ERREMOTE: return "erremote"; +#endif +#ifdef ESHUTDOWN + case ESHUTDOWN: return "eshutdown"; +#endif +#ifdef ESOCKTNOSUPPORT + case ESOCKTNOSUPPORT: return "esocktnosupport"; +#endif +#ifdef ESPIPE + case ESPIPE: return "espipe"; +#endif +#ifdef ESRCH + case ESRCH: return "esrch"; +#endif +#ifdef ESRMNT + case ESRMNT: return "esrmnt"; +#endif +#ifdef ESTALE + case ESTALE: return "estale"; +#endif +#ifdef ESUCCESS + case ESUCCESS: return "esuccess"; +#endif +#if defined(ETIME) && (!defined(ELOOP) || (ETIME != ELOOP)) + case ETIME: return "etime"; +#endif +#if defined(ETIMEDOUT) && (!defined(ENOSTR) || (ETIMEDOUT != ENOSTR)) && (!defined(EAGAIN) || (ETIMEDOUT != EAGAIN)) && (!defined(WSAETIMEDOUT) || (ETIMEDOUT != WSAETIMEDOUT)) + case ETIMEDOUT: return "etimedout"; +#endif +#ifdef ETOOMANYREFS + case ETOOMANYREFS: return "etoomanyrefs"; +#endif +#ifdef ETXTBSY + case ETXTBSY: return "etxtbsy"; +#endif +#ifdef EUCLEAN + case EUCLEAN: return "euclean"; +#endif +#ifdef EUNATCH + case EUNATCH: return "eunatch"; +#endif +#ifdef EUSERS + case EUSERS: return "eusers"; +#endif +#ifdef EVERSION + case EVERSION: return "eversion"; +#endif +#if defined(EWOULDBLOCK) && (!defined(EAGAIN) || (EWOULDBLOCK != EAGAIN)) && (!defined(WSAEWOULDBLOCK) || (EWOULDBLOCK != WSAEWOULDBLOCK)) + case EWOULDBLOCK: return "ewouldblock"; +#endif +#ifdef EXDEV + case EXDEV: return "exdev"; +#endif +#ifdef EXFULL + case EXFULL: return "exfull"; +#endif +#ifdef WSAEINTR + case WSAEINTR: return "eintr"; +#endif +#ifdef WSAEBADF + case WSAEBADF: return "ebadf"; +#endif +#ifdef WSAEACCES + case WSAEACCES: return "eacces"; +#endif +#ifdef WSAEFAULT + case WSAEFAULT: return "efault"; +#endif +#ifdef WSAEINVAL + case WSAEINVAL: return "einval"; +#endif +#ifdef WSAEMFILE + case WSAEMFILE: return "emfile"; +#endif +#ifdef WSAEWOULDBLOCK + case WSAEWOULDBLOCK: return "ewouldblock"; +#endif +#ifdef WSAEINPROGRESS + case WSAEINPROGRESS: return "einprogress"; +#endif +#ifdef WSAEALREADY + case WSAEALREADY: return "ealready"; +#endif +#ifdef WSAENOTSOCK + case WSAENOTSOCK: return "enotsock"; +#endif +#ifdef WSAEDESTADDRREQ + case WSAEDESTADDRREQ: return "edestaddrreq"; +#endif +#ifdef WSAEMSGSIZE + case WSAEMSGSIZE: return "emsgsize"; +#endif +#ifdef WSAEPROTOTYPE + case WSAEPROTOTYPE: return "eprototype"; +#endif +#ifdef WSAENOPROTOOPT + case WSAENOPROTOOPT: return "enoprotoopt"; +#endif +#ifdef WSAEPROTONOSUPPORT + case WSAEPROTONOSUPPORT: return "eprotonosupport"; +#endif +#ifdef WSAESOCKTNOSUPPORT + case WSAESOCKTNOSUPPORT: return "esocktnosupport"; +#endif +#ifdef WSAEOPNOTSUPP + case WSAEOPNOTSUPP: return "eopnotsupp"; +#endif +#ifdef WSAEPFNOSUPPORT + case WSAEPFNOSUPPORT: return "epfnosupport"; +#endif +#ifdef WSAEAFNOSUPPORT + case WSAEAFNOSUPPORT: return "eafnosupport"; +#endif +#ifdef WSAEADDRINUSE + case WSAEADDRINUSE: return "eaddrinuse"; +#endif +#ifdef WSAEADDRNOTAVAIL + case WSAEADDRNOTAVAIL: return "eaddrnotavail"; +#endif +#ifdef WSAENETDOWN + case WSAENETDOWN: return "enetdown"; +#endif +#ifdef WSAENETUNREACH + case WSAENETUNREACH: return "enetunreach"; +#endif +#ifdef WSAENETRESET + case WSAENETRESET: return "enetreset"; +#endif +#ifdef WSAECONNABORTED + case WSAECONNABORTED: return "econnaborted"; +#endif +#ifdef WSAECONNRESET + case WSAECONNRESET: return "econnreset"; +#endif +#ifdef WSAENOBUFS + case WSAENOBUFS: return "enobufs"; +#endif +#ifdef WSAEISCONN + case WSAEISCONN: return "eisconn"; +#endif +#ifdef WSAENOTCONN + case WSAENOTCONN: return "enotconn"; +#endif +#ifdef WSAESHUTDOWN + case WSAESHUTDOWN: return "eshutdown"; +#endif +#ifdef WSAETOOMANYREFS + case WSAETOOMANYREFS: return "etoomanyrefs"; +#endif +#ifdef WSAETIMEDOUT + case WSAETIMEDOUT: return "etimedout"; +#endif +#ifdef WSAECONNREFUSED + case WSAECONNREFUSED: return "econnrefused"; +#endif +#ifdef WSAELOOP + case WSAELOOP: return "eloop"; +#endif +#ifdef WSAENAMETOOLONG + case WSAENAMETOOLONG: return "enametoolong"; +#endif +#ifdef WSAEHOSTDOWN + case WSAEHOSTDOWN: return "ehostdown"; +#endif +#ifdef WSAEHOSTUNREACH + case WSAEHOSTUNREACH: return "ehostunreach"; +#endif +#ifdef WSAENOTEMPTY + case WSAENOTEMPTY: return "enotempty"; +#endif +#ifdef WSAEPROCLIM + case WSAEPROCLIM: return "eproclim"; +#endif +#ifdef WSAEUSERS + case WSAEUSERS: return "eusers"; +#endif +#ifdef WSAEDQUOT + case WSAEDQUOT: return "edquot"; +#endif +#ifdef WSAESTALE + case WSAESTALE: return "estale"; +#endif +#ifdef WSAEREMOTE + case WSAEREMOTE: return "eremote"; +#endif +#ifdef WSASYSNOTREADY + case WSASYSNOTREADY: return "sysnotready"; +#endif +#ifdef WSAVERNOTSUPPORTED + case WSAVERNOTSUPPORTED: return "vernotsupported"; +#endif +#ifdef WSANOTINITIALISED + case WSANOTINITIALISED: return "notinitialised"; +#endif +#ifdef WSAEDISCON + case WSAEDISCON: return "ediscon"; +#endif +#ifdef WSAENOMORE + case WSAENOMORE: return "enomore"; +#endif +#ifdef WSAECANCELLED + case WSAECANCELLED: return "ecancelled"; +#endif +#ifdef WSAEINVALIDPROCTABLE + case WSAEINVALIDPROCTABLE: return "einvalidproctable"; +#endif +#ifdef WSAEINVALIDPROVIDER + case WSAEINVALIDPROVIDER: return "einvalidprovider"; +#endif +#ifdef WSAEPROVIDERFAILEDINIT + case WSAEPROVIDERFAILEDINIT: return "eproviderfailedinit"; +#endif +#ifdef WSASYSCALLFAILURE + case WSASYSCALLFAILURE: return "syscallfailure"; +#endif +#ifdef WSASERVICE_NOT_FOUND + case WSASERVICE_NOT_FOUND: return "service_not_found"; +#endif +#ifdef WSATYPE_NOT_FOUND + case WSATYPE_NOT_FOUND: return "type_not_found"; +#endif +#ifdef WSA_E_NO_MORE + case WSA_E_NO_MORE: return "e_no_more"; +#endif +#ifdef WSA_E_CANCELLED + case WSA_E_CANCELLED: return "e_cancelled"; +#endif + } + return "unknown"; +} diff --git a/erts/emulator/beam/erl_printf_term.c b/erts/emulator/beam/erl_printf_term.c new file mode 100644 index 0000000000..7fe3f3bca5 --- /dev/null +++ b/erts/emulator/beam/erl_printf_term.c @@ -0,0 +1,458 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2005-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "erl_printf_term.h" +#include "sys.h" +#include "big.h" + +#define PRINT_CHAR(CNT, FN, ARG, C) \ +do { \ + int res__ = erts_printf_char((FN), (ARG), (C)); \ + if (res__ < 0) \ + return res__; \ + (CNT) += res__; \ +} while (0) + +#define PRINT_STRING(CNT, FN, ARG, STR) \ +do { \ + int res__ = erts_printf_string((FN), (ARG), (STR)); \ + if (res__ < 0) \ + return res__; \ + (CNT) += res__; \ +} while (0) + +#define PRINT_BUF(CNT, FN, ARG, BUF, LEN) \ +do { \ + int res__ = erts_printf_buf((FN), (ARG), (char*)(BUF), (LEN)); \ + if (res__ < 0) \ + return res__; \ + (CNT) += res__; \ +} while (0) + +#define PRINT_POINTER(CNT, FN, ARG, PTR) \ +do { \ + int res__ = erts_printf_pointer((FN), (ARG), (void *) (PTR)); \ + if (res__ < 0) \ + return res__; \ + (CNT) += res__; \ +} while (0) + +#define PRINT_ULONG(CNT, FN, ARG, C, P, W, I) \ +do { \ + int res__ = erts_printf_ulong((FN), (ARG), (C), (P), (W), (I)); \ + if (res__ < 0) \ + return res__; \ + (CNT) += res__; \ +} while (0) + +#define PRINT_SLONG(CNT, FN, ARG, C, P, W, I) \ +do { \ + int res__ = erts_printf_slong((FN), (ARG), (C), (P), (W), (I)); \ + if (res__ < 0) \ + return res__; \ + (CNT) += res__; \ +} while (0) + +#define PRINT_DOUBLE(CNT, FN, ARG, C, P, W, I) \ +do { \ + int res__ = erts_printf_double((FN), (ARG), (C), (P), (W), (I)); \ + if (res__ < 0) \ + return res__; \ + (CNT) += res__; \ +} while (0) + +/* CTYPE macros */ + +#define LATIN1 + +#define IS_DIGIT(c) ((c) >= '0' && (c) <= '9') +#ifdef LATIN1 +#define IS_LOWER(c) (((c) >= 'a' && (c) <= 'z') \ + || ((c) >= 128+95 && (c) <= 255 && (c) != 247)) +#define IS_UPPER(c) (((c) >= 'A' && (c) <= 'Z') \ + || ((c) >= 128+64 && (c) <= 128+94 && (c) != 247-32)) +#else +#define IS_LOWER(c) ((c) >= 'a' && (c) <= 'z') +#define IS_UPPER(c) ((c) >= 'A' && (c) <= 'Z') +#endif + +#define IS_ALNUM(c) (IS_DIGIT(c) || IS_LOWER(c) || IS_UPPER(c)) + +/* We don't include 160 (non-breaking space). */ +#define IS_SPACE(c) (c == ' ' || c == '\n' || c == '\t' || c == '\r') + +#ifdef LATIN1 +#define IS_CNTRL(c) ((c) < ' ' || (c) == 127 \ + || ((c) >= 128 && (c) < 128+32)) +#else +/* Treat all non-ASCII as control characters */ +#define IS_CNTRL(c) ((c) < ' ' || (c) >= 127) +#endif + +#define IS_PRINT(c) (!IS_CNTRL(c)) + +/* return 0 if list is not a non-empty flat list of printable characters */ + +static int +is_printable_string(Eterm list) +{ + int len = 0; + int c; + + while(is_list(list)) { + Eterm* consp = list_val(list); + Eterm hd = CAR(consp); + + if (!is_byte(hd)) + return 0; + c = signed_val(hd); + /* IS_PRINT || IS_SPACE would be another way to put it */ + if (IS_CNTRL(c) && !IS_SPACE(c)) + return 0; + len++; + list = CDR(consp); + } + if (is_nil(list)) + return len; + return 0; +} + +/* print a atom doing what quoting is necessary */ +static int print_atom_name(fmtfn_t fn, void* arg, Eterm atom, long *dcount) +{ + int n, i; + int res; + int need_quote; + int pos; + byte *s; + byte *cpos; + int c; + + res = 0; + i = atom_val(atom); + + if ((i < 0) || (i >= atom_table_size()) || (atom_tab(i) == NULL)) { + PRINT_STRING(res, fn, arg, "'); + return res; + } + + s = atom_tab(i)->name; + n = atom_tab(i)->len; + + *dcount -= atom_tab(i)->len; + + if (n == 0) { + PRINT_STRING(res, fn, arg, "''"); + return res; + } + + + need_quote = 0; + cpos = s; + pos = n - 1; + + c = *cpos++; + if (!IS_LOWER(c)) + need_quote++; + else { + while (pos--) { + c = *cpos++; + if (!IS_ALNUM(c) && (c != '_')) { + need_quote++; + break; + } + } + } + cpos = s; + pos = n; + if (need_quote) + PRINT_CHAR(res, fn, arg, '\''); + while(pos--) { + c = *cpos++; + switch(c) { + case '\'': PRINT_STRING(res, fn, arg, "\\'"); break; + case '\\': PRINT_STRING(res, fn, arg, "\\\\"); break; + case '\n': PRINT_STRING(res, fn, arg, "\\n"); break; + case '\f': PRINT_STRING(res, fn, arg, "\\f"); break; + case '\t': PRINT_STRING(res, fn, arg, "\\t"); break; + case '\r': PRINT_STRING(res, fn, arg, "\\r"); break; + case '\b': PRINT_STRING(res, fn, arg, "\\b"); break; + case '\v': PRINT_STRING(res, fn, arg, "\\v"); break; + default: + if (IS_CNTRL(c)) { + PRINT_CHAR(res, fn, arg, '\\'); + PRINT_ULONG(res, fn, arg, 'o', 1, 3, (unsigned long) c); + } + else + PRINT_CHAR(res, fn, arg, (char) c); + break; + } + } + if (need_quote) + PRINT_CHAR(res, fn, arg, '\''); + return res; +} + + + +static int +print_term(fmtfn_t fn, void* arg, Eterm obj, long *dcount) +{ + int res; + int i; + Uint32 *ref_num; + Eterm* nobj; + + res = 0; + + if ((*dcount)-- <= 0) + return res; + +#ifdef HYBRID___NOT_ACTIVE + /* Color coded output based on memory location */ + if(ptr_val(obj) >= global_heap && ptr_val(obj) < global_hend) + PRINT_STRING(res, fn, arg, "\033[32m"); +#ifdef INCREMENTAL + else if(ptr_val(obj) >= inc_fromspc && ptr_val(obj) < inc_fromend) + PRINT_STRING(res, fn, arg, "\033[33m"); +#endif + else if(IS_CONST(obj)) + PRINT_STRING(res, fn, arg, "\033[34m"); + else + PRINT_STRING(res, fn, arg, "\033[31m"); +#endif + + if (is_CP(obj)) { + PRINT_STRING(res, fn, arg, "'); + return res; + } + + switch (tag_val_def(obj)) { + case NIL_DEF: + PRINT_STRING(res, fn, arg, "[]"); + break; + case ATOM_DEF: { + int tres = print_atom_name(fn, arg, obj, dcount); + if (tres < 0) + return tres; + res += tres; + if (*dcount <= 0) + return res; + break; + } + case SMALL_DEF: + PRINT_SLONG(res, fn, arg, 'd', 0, 1, (signed long) signed_val(obj)); + break; + case BIG_DEF: { + int print_res; + char def_buf[64]; + char *buf, *big_str; + Uint sz = (Uint) big_decimal_estimate(obj); + sz++; + if (sz <= 64) + buf = &def_buf[0]; + else + buf = erts_alloc(ERTS_ALC_T_TMP, sz); + big_str = erts_big_to_string(obj, buf, sz); + print_res = erts_printf_string(fn, arg, big_str); + if (buf != &def_buf[0]) + erts_free(ERTS_ALC_T_TMP, (void *) buf); + if (print_res < 0) + return print_res; + res += print_res; + break; + } + case REF_DEF: + case EXTERNAL_REF_DEF: + PRINT_STRING(res, fn, arg, "#Ref<"); + PRINT_ULONG(res, fn, arg, 'u', 0, 1, + (unsigned long) ref_channel_no(obj)); + ref_num = ref_numbers(obj); + for (i = ref_no_of_numbers(obj)-1; i >= 0; i--) { + PRINT_CHAR(res, fn, arg, '.'); + PRINT_ULONG(res, fn, arg, 'u', 0, 1, (unsigned long) ref_num[i]); + } + PRINT_CHAR(res, fn, arg, '>'); + break; + case PID_DEF: + case EXTERNAL_PID_DEF: + PRINT_CHAR(res, fn, arg, '<'); + PRINT_ULONG(res, fn, arg, 'u', 0, 1, + (unsigned long) pid_channel_no(obj)); + PRINT_CHAR(res, fn, arg, '.'); + PRINT_ULONG(res, fn, arg, 'u', 0, 1, + (unsigned long) pid_number(obj)); + PRINT_CHAR(res, fn, arg, '.'); + PRINT_ULONG(res, fn, arg, 'u', 0, 1, + (unsigned long) pid_serial(obj)); + PRINT_CHAR(res, fn, arg, '>'); + break; + case PORT_DEF: + case EXTERNAL_PORT_DEF: + PRINT_STRING(res, fn, arg, "#Port<"); + PRINT_ULONG(res, fn, arg, 'u', 0, 1, + (unsigned long) port_channel_no(obj)); + PRINT_CHAR(res, fn, arg, '.'); + PRINT_ULONG(res, fn, arg, 'u', 0, 1, + (unsigned long) port_number(obj)); + PRINT_CHAR(res, fn, arg, '>'); + break; + case LIST_DEF: + if (is_printable_string(obj)) { + int c; + PRINT_CHAR(res, fn, arg, '"'); + nobj = list_val(obj); + while (1) { + if ((*dcount)-- <= 0) + return res; + c = signed_val(*nobj++); + if (c == '\n') + PRINT_STRING(res, fn, arg, "\\n"); + else { + if (c == '"') + PRINT_CHAR(res, fn, arg, '\\'); + PRINT_CHAR(res, fn, arg, (char) c); + } + if (is_not_list(*nobj)) + break; + nobj = list_val(*nobj); + } + PRINT_CHAR(res, fn, arg, '"'); + } else { + PRINT_CHAR(res, fn, arg, '['); + nobj = list_val(obj); + while (1) { + int tres = print_term(fn, arg, *nobj++, dcount); + if (tres < 0) + return tres; + res += tres; + if (*dcount <= 0) + return res; + if (is_not_list(*nobj)) + break; + PRINT_CHAR(res, fn, arg, ','); + nobj = list_val(*nobj); + } + if (is_not_nil(*nobj)) { + int tres; + PRINT_CHAR(res, fn, arg, '|'); + tres = print_term(fn, arg, *nobj, dcount); + if (tres < 0) + return tres; + res += tres; + if (*dcount <= 0) + return res; + } + PRINT_CHAR(res, fn, arg, ']'); + } + break; + case TUPLE_DEF: + nobj = tuple_val(obj); /* pointer to arity */ + i = arityval(*nobj); /* arity */ + PRINT_CHAR(res, fn, arg, '{'); + while (i--) { + int tres = print_term(fn, arg, *++nobj, dcount); + if (tres < 0) + return tres; + res += tres; + if (*dcount <= 0) + return res; + if (i >= 1) + PRINT_CHAR(res, fn, arg, ','); + } + PRINT_CHAR(res, fn, arg, '}'); + break; + case FLOAT_DEF: { + FloatDef ff; + GET_DOUBLE(obj, ff); + PRINT_DOUBLE(res, fn, arg, 'e', 6, 0, ff.fd); + } + break; + case BINARY_DEF: + { + ProcBin* pb = (ProcBin *) binary_val(obj); + if (pb->size == 1) + PRINT_STRING(res, fn, arg, "<<1 byte>>"); + else { + PRINT_STRING(res, fn, arg, "<<"); + PRINT_ULONG(res, fn, arg, 'u', 0, 1, (unsigned long) pb->size); + PRINT_STRING(res, fn, arg, " bytes>>"); + } + } + break; + case EXPORT_DEF: + { + Export* ep = (Export *) (export_val(obj))[1]; + Atom* module = atom_tab(atom_val(ep->code[0])); + Atom* name = atom_tab(atom_val(ep->code[1])); + + PRINT_STRING(res, fn, arg, "#Fun<"); + PRINT_BUF(res, fn, arg, module->name, module->len); + PRINT_CHAR(res, fn, arg, '.'); + PRINT_BUF(res, fn, arg, name->name, name->len); + PRINT_CHAR(res, fn, arg, '.'); + PRINT_SLONG(res, fn, arg, 'd', 0, 1, + (signed long) ep->code[2]); + PRINT_CHAR(res, fn, arg, '>'); + } + break; + case FUN_DEF: + { + ErlFunThing *funp = (ErlFunThing *) fun_val(obj); + Atom *ap = atom_tab(atom_val(funp->fe->module)); + + PRINT_STRING(res, fn, arg, "#Fun<"); + PRINT_BUF(res, fn, arg, ap->name, ap->len); + PRINT_CHAR(res, fn, arg, '.'); + PRINT_SLONG(res, fn, arg, 'd', 0, 1, + (signed long) funp->fe->old_index); + PRINT_CHAR(res, fn, arg, '.'); + PRINT_SLONG(res, fn, arg, 'd', 0, 1, + (signed long) funp->fe->old_uniq); + PRINT_CHAR(res, fn, arg, '>'); + } + break; + default: + PRINT_STRING(res, fn, arg, "'); + break; + } + + return res; +} + +int +erts_printf_term(fmtfn_t fn, void* arg, unsigned long term, long precision) +{ + int res = print_term(fn, arg, (Uint) term, &precision); + if (res < 0) + return res; + if (precision <= 0) + PRINT_STRING(res, fn, arg, "... "); + return res; +} diff --git a/erts/emulator/beam/erl_printf_term.h b/erts/emulator/beam/erl_printf_term.h new file mode 100644 index 0000000000..4f76028396 --- /dev/null +++ b/erts/emulator/beam/erl_printf_term.h @@ -0,0 +1,26 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2005-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifndef ERL_PRINTF_TERM_H__ +#define ERL_PRINTF_TERM_H__ + +#include "erl_printf_format.h" +int erts_printf_term(fmtfn_t fn, void* arg, unsigned long term, long precision); + +#endif diff --git a/erts/emulator/beam/erl_process.c b/erts/emulator/beam/erl_process.c new file mode 100644 index 0000000000..9960172366 --- /dev/null +++ b/erts/emulator/beam/erl_process.c @@ -0,0 +1,9469 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#define ERL_PROCESS_C__ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include /* offsetof() */ +#include +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "erl_process.h" +#include "erl_nmgc.h" +#include "error.h" +#include "bif.h" +#include "erl_db.h" +#include "dist.h" +#include "beam_catches.h" +#include "erl_instrument.h" +#include "erl_threads.h" +#include "erl_binary.h" + +#define ERTS_RUNQ_CHECK_BALANCE_REDS_PER_SCHED (2000*CONTEXT_REDS) +#define ERTS_RUNQ_CALL_CHECK_BALANCE_REDS \ + (ERTS_RUNQ_CHECK_BALANCE_REDS_PER_SCHED/2) + +#define ERTS_PROC_MIN_CONTEXT_SWITCH_REDS_COST (CONTEXT_REDS/10) + +#define ERTS_SCHED_SLEEP_SPINCOUNT 10000 + +#define ERTS_WAKEUP_OTHER_LIMIT (100*CONTEXT_REDS/2) +#define ERTS_WAKEUP_OTHER_DEC 10 +#define ERTS_WAKEUP_OTHER_FIXED_INC (CONTEXT_REDS/10) + +#define ERTS_MAX_CPU_TOPOLOGY_ID ((int) 0xffff) + +#if 0 || defined(DEBUG) +#define ERTS_FAKE_SCHED_BIND_PRINT_SORTED_CPU_DATA +#endif + +#if defined(DEBUG) && 0 +#define HARDDEBUG +#else +#undef HARDDEBUG +#endif + +#ifdef HARDDEBUG +#define HARDDEBUG_RUNQS +#endif + +#ifdef HIPE +#include "hipe_mode_switch.h" /* for hipe_init_process() */ +#include "hipe_signal.h" /* for hipe_thread_signal_init() */ +#endif + +#ifdef ERTS_ENABLE_LOCK_COUNT +#include "erl_lock_count.h" +#endif + +#define MAX_BIT (1 << PRIORITY_MAX) +#define HIGH_BIT (1 << PRIORITY_HIGH) +#define NORMAL_BIT (1 << PRIORITY_NORMAL) +#define LOW_BIT (1 << PRIORITY_LOW) + +#define ERTS_MAYBE_SAVE_TERMINATING_PROCESS(P) \ +do { \ + ERTS_SMP_LC_ASSERT(erts_lc_mtx_is_locked(&proc_tab_mtx)); \ + if (saved_term_procs.end) \ + save_terminating_process((P)); \ +} while (0) + +#define ERTS_EMPTY_RUNQ(RQ) \ + ((RQ)->len == 0 && (RQ)->misc.start == NULL) + +extern Eterm beam_apply[]; +extern Eterm beam_exit[]; +extern Eterm beam_continue_exit[]; + +static Sint p_last; +static Sint p_next; +static Sint p_serial; +static Uint p_serial_mask; +static Uint p_serial_shift; + +Uint erts_no_schedulers; +Uint erts_max_processes = ERTS_DEFAULT_MAX_PROCESSES; +Uint erts_process_tab_index_mask; + +int erts_sched_thread_suggested_stack_size = -1; + +#ifdef ERTS_ENABLE_LOCK_CHECK +ErtsLcPSDLocks erts_psd_required_locks[ERTS_PSD_SIZE]; +#endif + +#ifdef ERTS_SMP + +int erts_disable_proc_not_running_opt; + +#define ERTS_SCHED_CHANGING_ONLINE 1 +#define ERTS_SCHED_CHANGING_MULTI_SCHED 2 + +static struct { + erts_smp_mtx_t mtx; + erts_smp_cnd_t cnd; + int changing; + int online; + int curr_online; + int wait_curr_online; + erts_smp_atomic_t active; + struct { + erts_smp_atomic_t ongoing; + long wait_active; + ErtsProcList *procs; + } msb; /* Multi Scheduling Block */ +} schdlr_sspnd; + +static struct { + erts_smp_mtx_t update_mtx; + erts_smp_atomic_t active_runqs; + int last_active_runqs; + erts_smp_atomic_t used_runqs; + int forced_check_balance; + erts_smp_atomic_t checking_balance; + int halftime; + int full_reds_history_index; + struct { + int active_runqs; + int reds; + int max_len; + } prev_rise; + Uint n; +} balance_info; + +#define ERTS_BLNCE_SAVE_RISE(ACTIVE, MAX_LEN, REDS) \ +do { \ + balance_info.prev_rise.active_runqs = (ACTIVE); \ + balance_info.prev_rise.max_len = (MAX_LEN); \ + balance_info.prev_rise.reds = (REDS); \ +} while (0) + +#endif + +/* + * Cpu topology hierarchy. + */ +#define ERTS_TOPOLOGY_NODE 0 +#define ERTS_TOPOLOGY_PROCESSOR 1 +#define ERTS_TOPOLOGY_PROCESSOR_NODE 2 +#define ERTS_TOPOLOGY_CORE 3 +#define ERTS_TOPOLOGY_THREAD 4 +#define ERTS_TOPOLOGY_LOGICAL 5 + +#define ERTS_TOPOLOGY_MAX_DEPTH 6 + +typedef struct { + int bind_id; + int bound_id; +} ErtsCpuBindData; + +static ErtsCpuBindData *scheduler2cpu_map; +erts_smp_rwmtx_t erts_cpu_bind_rwmtx; + +typedef enum { + ERTS_CPU_BIND_SPREAD, + ERTS_CPU_BIND_PROCESSOR_SPREAD, + ERTS_CPU_BIND_THREAD_SPREAD, + ERTS_CPU_BIND_THREAD_NO_NODE_PROCESSOR_SPREAD, + ERTS_CPU_BIND_NO_NODE_PROCESSOR_SPREAD, + ERTS_CPU_BIND_NO_NODE_THREAD_SPREAD, + ERTS_CPU_BIND_NO_SPREAD, + ERTS_CPU_BIND_NONE +} ErtsCpuBindOrder; + +ErtsCpuBindOrder cpu_bind_order; + +static erts_cpu_topology_t *user_cpudata; +static int user_cpudata_size; +static erts_cpu_topology_t *system_cpudata; +static int system_cpudata_size; + +erts_sched_stat_t erts_sched_stat; + +ErtsRunQueue *erts_common_run_queue; + +#ifdef USE_THREADS +static erts_tsd_key_t sched_data_key; +#endif + +static erts_smp_mtx_t proc_tab_mtx; + +static erts_smp_atomic_t function_calls; + +#ifdef ERTS_SMP +static erts_smp_atomic_t doing_sys_schedule; +static erts_smp_atomic_t no_empty_run_queues; +#else /* !ERTS_SMP */ +ErtsSchedulerData *erts_scheduler_data; +#endif + +ErtsAlignedRunQueue *erts_aligned_run_queues; +Uint erts_no_run_queues; + +typedef struct { + ErtsSchedulerData esd; + char align[ERTS_ALC_CACHE_LINE_ALIGN_SIZE(sizeof(ErtsSchedulerData))]; +} ErtsAlignedSchedulerData; + +ErtsAlignedSchedulerData *erts_aligned_scheduler_data; + +#ifndef BM_COUNTERS +static int processes_busy; +#endif + +Process** process_tab; +static Uint last_reductions; +static Uint last_exact_reductions; +Uint erts_default_process_flags; +Eterm erts_system_monitor; +Eterm erts_system_monitor_msg_queue_len; +Eterm erts_system_monitor_long_gc; +Eterm erts_system_monitor_large_heap; +struct erts_system_monitor_flags_t erts_system_monitor_flags; + +/* system performance monitor */ +Eterm erts_system_profile; +struct erts_system_profile_flags_t erts_system_profile_flags; + +#ifdef HYBRID +Uint erts_num_active_procs; +Process** erts_active_procs; +#endif + +static erts_smp_atomic_t process_count; + +typedef struct ErtsTermProcElement_ ErtsTermProcElement; +struct ErtsTermProcElement_ { + ErtsTermProcElement *next; + ErtsTermProcElement *prev; + int ix; + union { + struct { + Eterm pid; + SysTimeval spawned; + SysTimeval exited; + } process; + struct { + SysTimeval time; + } bif_invocation; + } u; +}; + +static struct { + ErtsTermProcElement *start; + ErtsTermProcElement *end; +} saved_term_procs; + +ERTS_SCHED_PREF_QUICK_ALLOC_IMPL(misc_op_list, + ErtsMiscOpList, + 10, + ERTS_ALC_T_MISC_OP_LIST) + +ERTS_SCHED_PREF_QUICK_ALLOC_IMPL(proclist, + ErtsProcList, + 200, + ERTS_ALC_T_PROC_LIST) + +#define ERTS_RUNQ_IX(IX) (&erts_aligned_run_queues[(IX)].runq) +#define ERTS_SCHEDULER_IX(IX) (&erts_aligned_scheduler_data[(IX)].esd) + +#define ERTS_FOREACH_RUNQ(RQVAR, DO) \ +do { \ + ErtsRunQueue *RQVAR; \ + int ix__; \ + for (ix__ = 0; ix__ < erts_no_run_queues; ix__++) { \ + RQVAR = ERTS_RUNQ_IX(ix__); \ + erts_smp_runq_lock(RQVAR); \ + { DO; } \ + erts_smp_runq_unlock(RQVAR); \ + } \ +} while (0) + +#define ERTS_FOREACH_OP_RUNQ(RQVAR, DO) \ +do { \ + ErtsRunQueue *RQVAR; \ + int ix__; \ + ERTS_SMP_LC_ASSERT(erts_smp_lc_mtx_is_locked(&schdlr_sspnd.mtx)); \ + for (ix__ = 0; ix__ < schdlr_sspnd.online; ix__++) { \ + RQVAR = ERTS_RUNQ_IX(ix__); \ + erts_smp_runq_lock(RQVAR); \ + { DO; } \ + erts_smp_runq_unlock(RQVAR); \ + } \ +} while (0) + +#define ERTS_ATOMIC_FOREACH_RUNQ_X(RQVAR, DO, DOX) \ +do { \ + ErtsRunQueue *RQVAR; \ + int ix__; \ + for (ix__ = 0; ix__ < erts_no_run_queues; ix__++) { \ + RQVAR = ERTS_RUNQ_IX(ix__); \ + erts_smp_runq_lock(RQVAR); \ + { DO; } \ + } \ + { DOX; } \ + for (ix__ = 0; ix__ < erts_no_run_queues; ix__++) \ + erts_smp_runq_unlock(ERTS_RUNQ_IX(ix__)); \ +} while (0) + +#define ERTS_ATOMIC_FOREACH_RUNQ(RQVAR, DO) \ + ERTS_ATOMIC_FOREACH_RUNQ_X(RQVAR, DO, ) +/* + * Local functions. + */ + +static void init_processes_bif(void); +static void save_terminating_process(Process *p); +static void exec_misc_ops(ErtsRunQueue *); +static void print_function_from_pc(int to, void *to_arg, Eterm* x); +static int stack_element_dump(int to, void *to_arg, Process* p, Eterm* sp, + int yreg); +#ifdef ERTS_SMP +static void handle_pending_exiters(ErtsProcList *); + +static void cpu_bind_order_sort(erts_cpu_topology_t *cpudata, + int size, + ErtsCpuBindOrder bind_order, + int mk_seq); +static void signal_schedulers_bind_change(erts_cpu_topology_t *cpudata, int size); + +#endif + +static void early_cpu_bind_init(void); +static void late_cpu_bind_init(void); + +#if defined(ERTS_SMP) && defined(ERTS_ENABLE_LOCK_CHECK) +int +erts_smp_lc_runq_is_locked(ErtsRunQueue *runq) +{ + return erts_smp_lc_mtx_is_locked(&runq->mtx); +} +#endif + +void +erts_pre_init_process(void) +{ +#ifdef USE_THREADS + erts_tsd_key_create(&sched_data_key); +#endif + +#ifdef ERTS_ENABLE_LOCK_CHECK + { + int ix; + + erts_psd_required_locks[ERTS_PSD_ERROR_HANDLER].get_locks + = ERTS_PSD_ERROR_HANDLER_BUF_GET_LOCKS; + erts_psd_required_locks[ERTS_PSD_ERROR_HANDLER].set_locks + = ERTS_PSD_ERROR_HANDLER_BUF_SET_LOCKS; + + erts_psd_required_locks[ERTS_PSD_SAVED_CALLS_BUF].get_locks + = ERTS_PSD_SAVED_CALLS_BUF_GET_LOCKS; + erts_psd_required_locks[ERTS_PSD_SAVED_CALLS_BUF].set_locks + = ERTS_PSD_SAVED_CALLS_BUF_SET_LOCKS; + + erts_psd_required_locks[ERTS_PSD_SCHED_ID].get_locks + = ERTS_PSD_SCHED_ID_GET_LOCKS; + erts_psd_required_locks[ERTS_PSD_SCHED_ID].set_locks + = ERTS_PSD_SCHED_ID_SET_LOCKS; + + erts_psd_required_locks[ERTS_PSD_DIST_ENTRY].get_locks + = ERTS_PSD_DIST_ENTRY_GET_LOCKS; + erts_psd_required_locks[ERTS_PSD_DIST_ENTRY].set_locks + = ERTS_PSD_DIST_ENTRY_GET_LOCKS; + + /* Check that we have locks for all entries */ + for (ix = 0; ix < ERTS_PSD_SIZE; ix++) { + ERTS_SMP_LC_ASSERT(erts_psd_required_locks[ix].get_locks); + ERTS_SMP_LC_ASSERT(erts_psd_required_locks[ix].set_locks); + } + } +#endif +} + +/* initialize the scheduler */ +void +erts_init_process(void) +{ + Uint proc_bits = ERTS_PROC_BITS; + +#ifdef ERTS_SMP + erts_disable_proc_not_running_opt = 0; + erts_init_proc_lock(); +#endif + + init_proclist_alloc(); + + erts_smp_atomic_init(&process_count, 0); + + if (erts_use_r9_pids_ports) { + proc_bits = ERTS_R9_PROC_BITS; + ASSERT(erts_max_processes <= (1 << ERTS_R9_PROC_BITS)); + } + + process_tab = (Process**) erts_alloc(ERTS_ALC_T_PROC_TABLE, + erts_max_processes*sizeof(Process*)); + sys_memzero(process_tab, erts_max_processes * sizeof(Process*)); +#ifdef HYBRID + erts_active_procs = (Process**) + erts_alloc(ERTS_ALC_T_ACTIVE_PROCS, + erts_max_processes * sizeof(Process*)); + erts_num_active_procs = 0; +#endif + + erts_smp_mtx_init(&proc_tab_mtx, "proc_tab"); + p_last = -1; + p_next = 0; + p_serial = 0; + + p_serial_shift = erts_fit_in_bits(erts_max_processes - 1); + p_serial_mask = ((~(~((Uint) 0) << proc_bits)) >> p_serial_shift); + erts_process_tab_index_mask = ~(~((Uint) 0) << p_serial_shift); +#ifndef BM_COUNTERS + processes_busy = 0; +#endif + last_reductions = 0; + last_exact_reductions = 0; + erts_default_process_flags = 0; +} + +void +erts_late_init_process(void) +{ + int ix; + init_processes_bif(); + + erts_smp_spinlock_init(&erts_sched_stat.lock, "sched_stat"); + for (ix = 0; ix < ERTS_NO_PRIO_LEVELS; ix++) { + Eterm atom; + char *atom_str; + switch (ix) { + case PRIORITY_MAX: + atom_str = "process_max"; + break; + case PRIORITY_HIGH: + atom_str = "process_high"; + break; + case PRIORITY_NORMAL: + atom_str = "process_normal"; + break; + case PRIORITY_LOW: + atom_str = "process_low"; + break; + case ERTS_PORT_PRIO_LEVEL: + atom_str = "port"; + break; + default: + atom_str = "bad_prio"; + ASSERT(!"bad prio"); + break; + } + atom = am_atom_put(atom_str, sys_strlen(atom_str)); + erts_sched_stat.prio[ix].name = atom; + erts_sched_stat.prio[ix].total_executed = 0; + erts_sched_stat.prio[ix].executed = 0; + erts_sched_stat.prio[ix].total_migrated = 0; + erts_sched_stat.prio[ix].migrated = 0; + } + +} + +static ERTS_INLINE ErtsProcList * +proclist_create(Process *p) +{ + ErtsProcList *plp = proclist_alloc(); + plp->pid = p->id; + plp->started = p->started; + return plp; +} + +static ERTS_INLINE void +proclist_destroy(ErtsProcList *plp) +{ + proclist_free(plp); +} + +static ERTS_INLINE int +proclist_same(ErtsProcList *plp, Process *p) +{ + return (plp->pid == p->id + && erts_cmp_timeval(&plp->started, &p->started) == 0); +} + +ErtsProcList * +erts_proclist_create(Process *p) +{ + return proclist_create(p); +} + +void +erts_proclist_destroy(ErtsProcList *plp) +{ + proclist_destroy(plp); +} + +int +erts_proclist_same(ErtsProcList *plp, Process *p) +{ + return proclist_same(plp, p); +} + +void * +erts_psd_set_init(Process *p, ErtsProcLocks plocks, int ix, void *data) +{ + void *old; + ErtsProcLocks xplocks; + int refc = 0; + ErtsPSD *psd = erts_alloc(ERTS_ALC_T_PSD, sizeof(ErtsPSD)); + int i; + for (i = 0; i < ERTS_PSD_SIZE; i++) + psd->data[i] = NULL; + + ERTS_SMP_LC_ASSERT(plocks); + ERTS_SMP_LC_ASSERT(plocks == erts_proc_lc_my_proc_locks(p)); + + xplocks = ERTS_PROC_LOCKS_ALL; + xplocks &= ~plocks; + if (xplocks && erts_smp_proc_trylock(p, xplocks) == EBUSY) { + if (xplocks & ERTS_PROC_LOCK_MAIN) { + erts_smp_proc_inc_refc(p); + erts_smp_proc_unlock(p, plocks); + erts_smp_proc_lock(p, ERTS_PROC_LOCKS_ALL); + refc = 1; + } + else { + if (plocks & ERTS_PROC_LOCKS_ALL_MINOR) + erts_smp_proc_unlock(p, plocks & ERTS_PROC_LOCKS_ALL_MINOR); + erts_smp_proc_lock(p, ERTS_PROC_LOCKS_ALL_MINOR); + } + } + if (!p->psd) + p->psd = psd; + if (xplocks) + erts_smp_proc_unlock(p, xplocks); + if (refc) + erts_smp_proc_dec_refc(p); + ASSERT(p->psd); + if (p->psd != psd) + erts_free(ERTS_ALC_T_PSD, psd); + old = p->psd->data[ix]; + p->psd->data[ix] = data; + ERTS_SMP_LC_ASSERT(plocks == erts_proc_lc_my_proc_locks(p)); + return old; +} + +#ifdef ERTS_SMP + +static void +prepare_for_block(void *vrq) +{ + erts_smp_runq_unlock((ErtsRunQueue *) vrq); +} + +static void +resume_after_block(void *vrq) +{ + erts_smp_runq_lock((ErtsRunQueue *) vrq); +} + +#endif + +static ERTS_INLINE void +sched_waiting_sys(Uint no, ErtsRunQueue *rq) +{ + ERTS_SMP_LC_ASSERT(erts_smp_lc_runq_is_locked(rq)); + ASSERT(rq->waiting >= 0); + rq->flags |= (ERTS_RUNQ_FLG_OUT_OF_WORK + | ERTS_RUNQ_FLG_HALFTIME_OUT_OF_WORK); + rq->waiting++; + rq->waiting *= -1; + rq->woken = 0; + if (erts_system_profile_flags.scheduler) + profile_scheduler(make_small(no), am_inactive); +} + +static ERTS_INLINE void +sched_active_sys(Uint no, ErtsRunQueue *rq) +{ + ERTS_SMP_LC_ASSERT(erts_smp_lc_runq_is_locked(rq)); + ASSERT(rq->waiting < 0); + rq->waiting *= -1; + rq->waiting--; + if (erts_system_profile_flags.scheduler) + profile_scheduler(make_small(no), am_active); +} + +Uint +erts_active_schedulers(void) +{ + /* RRRRRRRRR */ + + Uint as = erts_no_schedulers; + + ERTS_ATOMIC_FOREACH_RUNQ(rq, as -= abs(rq->waiting)); + + ASSERT(as >= 0); + return as; +} + +#ifdef ERTS_SMP + +static ERTS_INLINE void +sched_waiting(Uint no, ErtsRunQueue *rq) +{ + ERTS_SMP_LC_ASSERT(erts_smp_lc_runq_is_locked(rq)); + rq->flags |= (ERTS_RUNQ_FLG_OUT_OF_WORK + | ERTS_RUNQ_FLG_HALFTIME_OUT_OF_WORK); + if (rq->waiting < 0) + rq->waiting--; + else + rq->waiting++; + rq->woken = 0; + if (erts_system_profile_flags.scheduler) + profile_scheduler(make_small(no), am_inactive); +} + +static ERTS_INLINE void +sched_active(Uint no, ErtsRunQueue *rq) +{ + ERTS_SMP_LC_ASSERT(erts_smp_lc_runq_is_locked(rq)); + if (rq->waiting < 0) + rq->waiting++; + else + rq->waiting--; + if (erts_system_profile_flags.scheduler) + profile_scheduler(make_small(no), am_active); +} + +static int ERTS_INLINE +ongoing_multi_scheduling_block(void) +{ + return erts_smp_atomic_read(&schdlr_sspnd.msb.ongoing) != 0; +} + +static ERTS_INLINE void +empty_runq(ErtsRunQueue *rq) +{ + long oifls = erts_smp_atomic_band(&rq->info_flags, ~ERTS_RUNQ_IFLG_NONEMPTY); + if (oifls & ERTS_RUNQ_IFLG_NONEMPTY) { +#ifdef DEBUG + long empty = erts_smp_atomic_read(&no_empty_run_queues); + ASSERT(0 <= empty && empty < erts_no_run_queues); +#endif + erts_smp_atomic_inc(&no_empty_run_queues); + } +} + +static ERTS_INLINE void +non_empty_runq(ErtsRunQueue *rq) +{ + long oifls = erts_smp_atomic_bor(&rq->info_flags, ERTS_RUNQ_IFLG_NONEMPTY); + if (!(oifls & ERTS_RUNQ_IFLG_NONEMPTY)) { +#ifdef DEBUG + long empty = erts_smp_atomic_read(&no_empty_run_queues); + ASSERT(0 < empty && empty <= erts_no_run_queues); +#endif + erts_smp_atomic_dec(&no_empty_run_queues); + } +} + +static ERTS_INLINE int +sched_spin_wake(ErtsRunQueue *rq) +{ +#if ERTS_SCHED_SLEEP_SPINCOUNT == 0 + return 0; +#else + long val; + ERTS_SMP_LC_ASSERT(erts_smp_lc_runq_is_locked(rq)); + + val = erts_smp_atomic_read(&rq->spin_waiter); + ASSERT(val >= 0); + if (val != 0) { + erts_smp_atomic_inc(&rq->spin_wake); + return 1; + } + return 0; +#endif +} + +static ERTS_INLINE int +sched_spin_wake_all(ErtsRunQueue *rq) +{ +#if ERTS_SCHED_SLEEP_SPINCOUNT == 0 + return 0; +#else + long val; + ERTS_SMP_LC_ASSERT(erts_smp_lc_runq_is_locked(rq)); + + val = erts_smp_atomic_read(&rq->spin_waiter); + ASSERT(val >= 0); + if (val != 0) + erts_smp_atomic_add(&rq->spin_wake, val); + return val; +#endif +} + +static void +sched_sys_wait(Uint no, ErtsRunQueue *rq) +{ + long dt; +#if ERTS_SCHED_SLEEP_SPINCOUNT != 0 + int val; + int spincount = ERTS_SCHED_SLEEP_SPINCOUNT; + ERTS_SMP_LC_ASSERT(erts_smp_lc_runq_is_locked(rq)); + +#endif + + sched_waiting_sys(no, rq); + +#if ERTS_SCHED_SLEEP_SPINCOUNT != 0 + erts_smp_atomic_inc(&rq->spin_waiter); + erts_smp_runq_unlock(rq); + + erl_sys_schedule(1); /* Might give us something to do */ + + dt = do_time_read_and_reset(); + if (dt) bump_timer(dt); + + while (spincount-- > 0) { + val = erts_smp_atomic_read(&rq->spin_wake); + ASSERT(val >= 0); + if (val != 0) { + erts_smp_runq_lock(rq); + val = erts_smp_atomic_read(&rq->spin_wake); + ASSERT(val >= 0); + if (val != 0) + goto woken; + if (spincount == 0) + goto sleep; + erts_smp_runq_unlock(rq); + } + } + + erts_smp_runq_lock(rq); + val = erts_smp_atomic_read(&rq->spin_wake); + ASSERT(val >= 0); + if (val != 0) { + woken: + erts_smp_atomic_dec(&rq->spin_wake); + ASSERT(erts_smp_atomic_read(&rq->spin_wake) >= 0); + erts_smp_atomic_dec(&rq->spin_waiter); + ASSERT(erts_smp_atomic_read(&rq->spin_waiter) >= 0); + } + else { + sleep: + erts_smp_atomic_dec(&rq->spin_waiter); + ASSERT(erts_smp_atomic_read(&rq->spin_waiter) >= 0); + /* + * If we got new I/O tasks we aren't allowed to + * sleep in erl_sys_schedule(). + */ + if (!erts_port_task_have_outstanding_io_tasks()) { +#endif + + erts_sys_schedule_interrupt(0); + erts_smp_runq_unlock(rq); + + erl_sys_schedule(0); + + dt = do_time_read_and_reset(); + if (dt) bump_timer(dt); + + erts_smp_runq_lock(rq); + +#if ERTS_SCHED_SLEEP_SPINCOUNT != 0 + } + } +#endif + + sched_active_sys(no, rq); +} + +static void +sched_cnd_wait(Uint no, ErtsRunQueue *rq) +{ +#if ERTS_SCHED_SLEEP_SPINCOUNT != 0 + int val; + int spincount = ERTS_SCHED_SLEEP_SPINCOUNT; + ERTS_SMP_LC_ASSERT(erts_smp_lc_runq_is_locked(rq)); +#endif + + sched_waiting(no, rq); + erts_smp_activity_begin(ERTS_ACTIVITY_WAIT, + prepare_for_block, + resume_after_block, + (void *) rq); + +#if ERTS_SCHED_SLEEP_SPINCOUNT == 0 + erts_smp_cnd_wait(&rq->cnd, &rq->mtx); +#else + erts_smp_atomic_inc(&rq->spin_waiter); + erts_smp_mtx_unlock(&rq->mtx); + + while (spincount-- > 0) { + val = erts_smp_atomic_read(&rq->spin_wake); + ASSERT(val >= 0); + if (val != 0) { + erts_smp_mtx_lock(&rq->mtx); + val = erts_smp_atomic_read(&rq->spin_wake); + ASSERT(val >= 0); + if (val != 0) + goto woken; + if (spincount == 0) + goto sleep; + erts_smp_mtx_unlock(&rq->mtx); + } + } + + erts_smp_mtx_lock(&rq->mtx); + val = erts_smp_atomic_read(&rq->spin_wake); + ASSERT(val >= 0); + if (val == 0) { + sleep: + erts_smp_atomic_dec(&rq->spin_waiter); + ASSERT(erts_smp_atomic_read(&rq->spin_waiter) >= 0); + erts_smp_cnd_wait(&rq->cnd, &rq->mtx); + } + else { + woken: + erts_smp_atomic_dec(&rq->spin_wake); + ASSERT(erts_smp_atomic_read(&rq->spin_wake) >= 0); + erts_smp_atomic_dec(&rq->spin_waiter); + ASSERT(erts_smp_atomic_read(&rq->spin_waiter) >= 0); + } +#endif + + erts_smp_activity_end(ERTS_ACTIVITY_WAIT, + prepare_for_block, + resume_after_block, + (void *) rq); + + sched_active(no, rq); +} + +static void +wake_one_scheduler(void) +{ + ASSERT(erts_common_run_queue); + ERTS_SMP_LC_ASSERT(erts_smp_lc_runq_is_locked(erts_common_run_queue)); + if (erts_common_run_queue->waiting) { + if (!sched_spin_wake(erts_common_run_queue)) { + if (erts_common_run_queue->waiting == -1) /* One scheduler waiting + and doing so in + sys_schedule */ + erts_sys_schedule_interrupt(1); + else + erts_smp_cnd_signal(&erts_common_run_queue->cnd); + } + } +} + +static void +wake_scheduler(ErtsRunQueue *rq, int incq) +{ + ASSERT(!erts_common_run_queue); + ASSERT(-1 <= rq->waiting && rq->waiting <= 1); + ERTS_SMP_LC_ASSERT(erts_smp_lc_runq_is_locked(rq)); + if (rq->waiting && !rq->woken) { + if (!sched_spin_wake(rq)) { + if (rq->waiting < 0) + erts_sys_schedule_interrupt(1); + else + erts_smp_cnd_signal(&rq->cnd); + } + rq->woken = 1; + if (incq) + non_empty_runq(rq); + } +} + +static void +wake_all_schedulers(void) +{ + if (erts_common_run_queue) { + erts_smp_runq_lock(erts_common_run_queue); + if (erts_common_run_queue->waiting) { + if (erts_common_run_queue->waiting < 0) + erts_sys_schedule_interrupt(1); + sched_spin_wake_all(erts_common_run_queue); + erts_smp_cnd_broadcast(&erts_common_run_queue->cnd); + } + erts_smp_runq_unlock(erts_common_run_queue); + } + else { + int ix; + for (ix = 0; ix < erts_no_run_queues; ix++) { + ErtsRunQueue *rq = ERTS_RUNQ_IX(ix); + erts_smp_runq_lock(rq); + wake_scheduler(rq, 0); + erts_smp_runq_unlock(rq); + } + } +} + +static ERTS_INLINE int +chk_wake_sched(ErtsRunQueue *crq, int ix, int activate) +{ + long iflgs; + ErtsRunQueue *wrq; + if (crq->ix == ix) + return 0; + wrq = ERTS_RUNQ_IX(ix); + iflgs = erts_smp_atomic_read(&wrq->info_flags); + if (!(iflgs & (ERTS_RUNQ_IFLG_SUSPENDED|ERTS_RUNQ_IFLG_NONEMPTY))) { + erts_smp_xrunq_lock(crq, wrq); + if (activate) { + if (ix == erts_smp_atomic_cmpxchg(&balance_info.active_runqs, ix+1, ix)) { + wrq->flags &= ~ERTS_RUNQ_FLG_INACTIVE; + } + } + wake_scheduler(wrq, 0); + erts_smp_xrunq_unlock(crq, wrq); + return 1; + } + return 0; +} + +static void +wake_scheduler_on_empty_runq(ErtsRunQueue *crq) +{ + int ix = crq->ix; + int stop_ix = ix; + int active_ix = erts_smp_atomic_read(&balance_info.active_runqs); + int balance_ix = erts_smp_atomic_read(&balance_info.used_runqs); + + if (active_ix > balance_ix) + active_ix = balance_ix; + + if (ix >= active_ix) + stop_ix = ix = active_ix; + + /* Try to wake a scheduler on an active run queue */ + while (1) { + ix--; + if (ix < 0) { + if (active_ix == stop_ix) + break; + ix = active_ix - 1; + } + if (ix == stop_ix) + break; + if (chk_wake_sched(crq, ix, 0)) + return; + } + + if (active_ix < balance_ix) { + /* Try to activate a new run queue and wake its scheduler */ + (void) chk_wake_sched(crq, active_ix, 1); + } +} + +#endif /* ERTS_SMP */ + +static ERTS_INLINE void +smp_notify_inc_runq(ErtsRunQueue *runq) +{ +#ifdef ERTS_SMP + if (erts_common_run_queue) + wake_one_scheduler(); + else + wake_scheduler(runq, 1); +#endif +} + +void +erts_smp_notify_inc_runq__(ErtsRunQueue *runq) +{ + smp_notify_inc_runq(runq); +} + +#ifdef ERTS_SMP + +ErtsRunQueue * +erts_prepare_emigrate(ErtsRunQueue *c_rq, ErtsRunQueueInfo *c_rqi, int prio) +{ + ASSERT(ERTS_CHK_RUNQ_FLG_EMIGRATE(c_rq->flags, prio)); + ASSERT(ERTS_CHK_RUNQ_FLG_EVACUATE(c_rq->flags, prio) + || c_rqi->len >= c_rqi->migrate.limit.this); + + while (1) { + ErtsRunQueue *n_rq = c_rqi->migrate.runq; + ERTS_DBG_VERIFY_VALID_RUNQP(n_rq); + erts_smp_xrunq_lock(c_rq, n_rq); + + /* + * erts_smp_xrunq_lock() may release lock on c_rq! We have + * to check that we still want to emigrate and emigrate + * to the same run queue as before. + */ + + if (ERTS_CHK_RUNQ_FLG_EMIGRATE(c_rq->flags, prio)) { + Uint32 force = (ERTS_CHK_RUNQ_FLG_EVACUATE(c_rq->flags, prio) + | (c_rq->flags & ERTS_RUNQ_FLG_INACTIVE)); + if (force || c_rqi->len > c_rqi->migrate.limit.this) { + ErtsRunQueueInfo *n_rqi; + /* We still want to emigrate */ + + if (n_rq != c_rqi->migrate.runq) { + /* Ahh... run queue changed; need to do it all over again... */ + erts_smp_runq_unlock(n_rq); + continue; + } + else { + + if (prio == ERTS_PORT_PRIO_LEVEL) + n_rqi = &n_rq->ports.info; + else + n_rqi = &n_rq->procs.prio_info[prio]; + + if (force || (n_rqi->len < c_rqi->migrate.limit.other)) { + /* emigrate ... */ + return n_rq; + } + } + } + } + + ASSERT(n_rq != c_rq); + erts_smp_runq_unlock(n_rq); + if (!(c_rq->flags & ERTS_RUNQ_FLG_INACTIVE)) { + /* No more emigrations to this runq */ + ERTS_UNSET_RUNQ_FLG_EMIGRATE(c_rq->flags, prio); + ERTS_DBG_SET_INVALID_RUNQP(c_rqi->migrate.runq, 0x3); + } + + return NULL; + } +} + +static void +immigrate(ErtsRunQueue *rq) +{ + int prio; + + ASSERT(rq->flags & ERTS_RUNQ_FLGS_IMMIGRATE_QMASK); + + for (prio = 0; prio < ERTS_NO_PRIO_LEVELS; prio++) { + if (ERTS_CHK_RUNQ_FLG_IMMIGRATE(rq->flags, prio)) { + ErtsRunQueueInfo *rqi = (prio == ERTS_PORT_PRIO_LEVEL + ? &rq->ports.info + : &rq->procs.prio_info[prio]); + ErtsRunQueue *from_rq = rqi->migrate.runq; + int rq_locked, from_rq_locked; + + ERTS_DBG_VERIFY_VALID_RUNQP(from_rq); + + rq_locked = 1; + from_rq_locked = 1; + erts_smp_xrunq_lock(rq, from_rq); + /* + * erts_smp_xrunq_lock() may release lock on rq! We have + * to check that we still want to immigrate from the same + * run queue as before. + */ + if (ERTS_CHK_RUNQ_FLG_IMMIGRATE(rq->flags, prio) + && from_rq == rqi->migrate.runq) { + ErtsRunQueueInfo *from_rqi = (prio == ERTS_PORT_PRIO_LEVEL + ? &from_rq->ports.info + : &from_rq->procs.prio_info[prio]); + if ((ERTS_CHK_RUNQ_FLG_EVACUATE(rq->flags, prio) + && ERTS_CHK_RUNQ_FLG_EVACUATE(from_rq->flags, prio) + && from_rqi->len) + || (from_rqi->len > rqi->migrate.limit.other + && rqi->len < rqi->migrate.limit.this)) { + if (prio == ERTS_PORT_PRIO_LEVEL) { + Port *prt = from_rq->ports.start; + if (prt) { + int prt_locked = 0; + (void) erts_port_migrate(prt, &prt_locked, + from_rq, &from_rq_locked, + rq, &rq_locked); + if (prt_locked) + erts_smp_port_unlock(prt); + } + } + else { + Process *proc; + ErtsRunPrioQueue *from_rpq; + from_rpq = (prio == PRIORITY_LOW + ? &from_rq->procs.prio[PRIORITY_NORMAL] + : &from_rq->procs.prio[prio]); + for (proc = from_rpq->first; proc; proc = proc->next) + if (proc->prio == prio && !proc->bound_runq) + break; + if (proc) { + ErtsProcLocks proc_locks = 0; + (void) erts_proc_migrate(proc, &proc_locks, + from_rq, &from_rq_locked, + rq, &rq_locked); + if (proc_locks) + erts_smp_proc_unlock(proc, proc_locks); + } + } + } + else { + ERTS_UNSET_RUNQ_FLG_IMMIGRATE(rq->flags, prio); + ERTS_DBG_SET_INVALID_RUNQP(rqi->migrate.runq, 0x1); + } + } + if (from_rq_locked) + erts_smp_runq_unlock(from_rq); + if (!rq_locked) + erts_smp_runq_lock(rq); + } + } +} + +static void +evacuate_run_queue(ErtsRunQueue *evac_rq, ErtsRunQueue *rq) +{ + Port *prt; + int prio; + int prt_locked = 0; + int rq_locked = 0; + int evac_rq_locked = 1; + + erts_smp_runq_lock(evac_rq); + + evac_rq->flags &= ~ERTS_RUNQ_FLGS_IMMIGRATE_QMASK; + evac_rq->flags |= (ERTS_RUNQ_FLGS_EMIGRATE_QMASK + | ERTS_RUNQ_FLGS_EVACUATE_QMASK + | ERTS_RUNQ_FLG_SUSPENDED); + + erts_smp_atomic_bor(&evac_rq->info_flags, ERTS_RUNQ_IFLG_SUSPENDED); + + /* + * Need to set up evacuation paths first since we + * may release the run queue lock on evac_rq + * when evacuating. + */ + evac_rq->misc.evac_runq = rq; + evac_rq->ports.info.migrate.runq = rq; + for (prio = 0; prio < ERTS_NO_PROC_PRIO_LEVELS; prio++) + evac_rq->procs.prio_info[prio].migrate.runq = rq; + + /* Evacuate scheduled misc ops */ + + if (evac_rq->misc.start) { + rq_locked = 1; + erts_smp_xrunq_lock(evac_rq, rq); + if (rq->misc.end) + rq->misc.end->next = evac_rq->misc.start; + else + rq->misc.start = evac_rq->misc.start; + rq->misc.end = evac_rq->misc.end; + evac_rq->misc.start = NULL; + evac_rq->misc.end = NULL; + } + + /* Evacuate scheduled ports */ + prt = evac_rq->ports.start; + while (prt) { + (void) erts_port_migrate(prt, &prt_locked, + evac_rq, &evac_rq_locked, + rq, &rq_locked); + if (prt_locked) + erts_smp_port_unlock(prt); + if (!evac_rq_locked) { + evac_rq_locked = 1; + erts_smp_runq_lock(evac_rq); + } + prt = evac_rq->ports.start; + } + + /* Evacuate scheduled processes */ + for (prio = 0; prio < ERTS_NO_PROC_PRIO_LEVELS; prio++) { + Process *proc; + + switch (prio) { + case PRIORITY_MAX: + case PRIORITY_HIGH: + case PRIORITY_NORMAL: + proc = evac_rq->procs.prio[prio].first; + while (proc) { + ErtsProcLocks proc_locks = 0; + + /* Bound processes are stuck... */ + while (proc->bound_runq) { + proc = proc->next; + if (!proc) + goto end_of_proc; + } + + (void) erts_proc_migrate(proc, &proc_locks, + evac_rq, &evac_rq_locked, + rq, &rq_locked); + if (proc_locks) + erts_smp_proc_unlock(proc, proc_locks); + if (!evac_rq_locked) { + erts_smp_runq_lock(evac_rq); + evac_rq_locked = 1; + } + + proc = evac_rq->procs.prio[prio].first; + } + + end_of_proc: + +#ifdef DEBUG + for (proc = evac_rq->procs.prio[prio].first; + proc; + proc = proc->next) { + ASSERT(proc->bound_runq); + } +#endif + break; + case PRIORITY_LOW: + break; + default: + ASSERT(!"Invalid process priority"); + break; + } + } + + if (rq_locked) + erts_smp_runq_unlock(rq); + + if (!evac_rq_locked) + erts_smp_runq_lock(evac_rq); + wake_scheduler(evac_rq, 0); + erts_smp_runq_unlock(evac_rq); +} + +static int +try_steal_task_from_victim(ErtsRunQueue *rq, int *rq_lockedp, ErtsRunQueue *vrq) +{ + Process *proc; + int vrq_locked; + + if (*rq_lockedp) + erts_smp_xrunq_lock(rq, vrq); + else + erts_smp_runq_lock(vrq); + vrq_locked = 1; + + ERTS_SMP_LC_CHK_RUNQ_LOCK(rq, *rq_lockedp); + ERTS_SMP_LC_CHK_RUNQ_LOCK(vrq, vrq_locked); + + /* + * Check for a runnable process to steal... + */ + + switch (vrq->flags & ERTS_RUNQ_FLGS_PROCS_QMASK) { + case MAX_BIT: + case MAX_BIT|HIGH_BIT: + case MAX_BIT|NORMAL_BIT: + case MAX_BIT|LOW_BIT: + case MAX_BIT|HIGH_BIT|NORMAL_BIT: + case MAX_BIT|HIGH_BIT|LOW_BIT: + case MAX_BIT|NORMAL_BIT|LOW_BIT: + case MAX_BIT|HIGH_BIT|NORMAL_BIT|LOW_BIT: + for (proc = vrq->procs.prio[PRIORITY_MAX].last; + proc; + proc = proc->prev) { + if (!proc->bound_runq) + break; + } + if (proc) + break; + case HIGH_BIT: + case HIGH_BIT|NORMAL_BIT: + case HIGH_BIT|LOW_BIT: + case HIGH_BIT|NORMAL_BIT|LOW_BIT: + for (proc = vrq->procs.prio[PRIORITY_HIGH].last; + proc; + proc = proc->prev) { + if (!proc->bound_runq) + break; + } + if (proc) + break; + case NORMAL_BIT: + case LOW_BIT: + case NORMAL_BIT|LOW_BIT: + for (proc = vrq->procs.prio[PRIORITY_NORMAL].last; + proc; + proc = proc->prev) { + if (!proc->bound_runq) + break; + } + if (proc) + break; + case 0: + proc = NULL; + break; + default: + ASSERT(!"Invalid queue mask"); + proc = NULL; + break; + } + + if (proc) { + ErtsProcLocks proc_locks = 0; + int res; + ErtsMigrateResult mres; + mres = erts_proc_migrate(proc, &proc_locks, + vrq, &vrq_locked, + rq, rq_lockedp); + if (proc_locks) + erts_smp_proc_unlock(proc, proc_locks); + res = !0; + switch (mres) { + case ERTS_MIGRATE_FAILED_RUNQ_SUSPENDED: + res = 0; + case ERTS_MIGRATE_SUCCESS: + if (vrq_locked) + erts_smp_runq_unlock(vrq); + return res; + default: /* Other failures */ + break; + } + } + + ERTS_SMP_LC_CHK_RUNQ_LOCK(rq, *rq_lockedp); + ERTS_SMP_LC_CHK_RUNQ_LOCK(vrq, vrq_locked); + + if (!vrq_locked) { + if (*rq_lockedp) + erts_smp_xrunq_lock(rq, vrq); + else + erts_smp_runq_lock(vrq); + vrq_locked = 1; + } + + ERTS_SMP_LC_CHK_RUNQ_LOCK(rq, *rq_lockedp); + ERTS_SMP_LC_CHK_RUNQ_LOCK(vrq, vrq_locked); + + /* + * Check for a runnable port to steal... + */ + + if (vrq->ports.info.len) { + Port *prt = vrq->ports.end; + int prt_locked = 0; + int res; + ErtsMigrateResult mres; + + mres = erts_port_migrate(prt, &prt_locked, + vrq, &vrq_locked, + rq, rq_lockedp); + if (prt_locked) + erts_smp_port_unlock(prt); + res = !0; + switch (mres) { + case ERTS_MIGRATE_FAILED_RUNQ_SUSPENDED: + res = 0; + case ERTS_MIGRATE_SUCCESS: + if (vrq_locked) + erts_smp_runq_unlock(vrq); + return res; + default: /* Other failures */ + break; + } + } + + if (vrq_locked) + erts_smp_runq_unlock(vrq); + + return 0; +} + + +static ERTS_INLINE int +check_possible_steal_victim(ErtsRunQueue *rq, int *rq_lockedp, int vix) +{ + ErtsRunQueue *vrq = ERTS_RUNQ_IX(vix); + long iflgs = erts_smp_atomic_read(&vrq->info_flags); + if (iflgs & ERTS_RUNQ_IFLG_NONEMPTY) + return try_steal_task_from_victim(rq, rq_lockedp, vrq); + else + return 0; +} + + +static int +try_steal_task(ErtsRunQueue *rq) +{ + int res, rq_locked, vix, active_rqs, blnc_rqs; + + if (erts_common_run_queue) + return 0; + + /* + * We are not allowed to steal jobs to this run queue + * if it is suspended. Note that it might get suspended + * at any time when we don't have the lock on the run + * queue. + */ + if (rq->flags & ERTS_RUNQ_FLG_SUSPENDED) + return 0; + + res = 0; + rq_locked = 1; + + ERTS_SMP_LC_CHK_RUNQ_LOCK(rq, rq_locked); + + active_rqs = erts_smp_atomic_read(&balance_info.active_runqs); + blnc_rqs = erts_smp_atomic_read(&balance_info.used_runqs); + + if (active_rqs > blnc_rqs) + active_rqs = blnc_rqs; + + if (rq->ix < active_rqs) { + + /* First try to steal from an inactive run queue... */ + if (active_rqs < blnc_rqs) { + int no = blnc_rqs - active_rqs; + int stop_ix = vix = active_rqs + rq->ix % no; + while (erts_smp_atomic_read(&no_empty_run_queues) < blnc_rqs) { + res = check_possible_steal_victim(rq, &rq_locked, vix); + if (res) + goto done; + vix++; + if (vix >= blnc_rqs) + vix = active_rqs; + if (vix == stop_ix) + break; + } + } + + vix = rq->ix; + + /* ... then try to steal a job from another active queue... */ + while (erts_smp_atomic_read(&no_empty_run_queues) < blnc_rqs) { + vix++; + if (vix >= active_rqs) + vix = 0; + if (vix == rq->ix) + break; + + res = check_possible_steal_victim(rq, &rq_locked, vix); + if (res) + goto done; + } + + } + + done: + + if (!rq_locked) + erts_smp_runq_lock(rq); + + if (!res) + res = !ERTS_EMPTY_RUNQ(rq); + + return res; +} + +#ifdef ERTS_SMP_SCHEDULERS_NEED_TO_CHECK_CHILDREN +void +erts_smp_notify_check_children_needed(void) +{ + int i; + for (i = 0; i < erts_no_schedulers; i++) { + erts_smp_runq_lock(ERTS_SCHEDULER_IX(i)->run_queue); + ERTS_SCHEDULER_IX(i)->check_children = 1; + if (!erts_common_run_queue) + wake_scheduler(ERTS_SCHEDULER_IX(i)->run_queue, 0); + erts_smp_runq_unlock(ERTS_SCHEDULER_IX(i)->run_queue); + } + if (ongoing_multi_scheduling_block()) { + /* Also blocked schedulers need to check children */ + erts_smp_mtx_lock(&schdlr_sspnd.mtx); + for (i = 0; i < erts_no_schedulers; i++) + ERTS_SCHEDULER_IX(i)->blocked_check_children = 1; + erts_smp_cnd_broadcast(&schdlr_sspnd.cnd); + erts_smp_mtx_unlock(&schdlr_sspnd.mtx); + } + if (erts_common_run_queue) + wake_all_schedulers(); +} +#endif + +/* Run queue balancing */ + +typedef struct { + Uint32 flags; + struct { + int max_len; + int avail; + int reds; + int migration_limit; + int emigrate_to; + int immigrate_from; + } prio[ERTS_NO_PRIO_LEVELS]; + int reds; + int full_reds; + int full_reds_history_sum; + int full_reds_history_change; + int oowc; + int max_len; +} ErtsRunQueueBalance; +static ErtsRunQueueBalance *run_queue_info; + +typedef struct { + int qix; + int len; +} ErtsRunQueueCompare; +static ErtsRunQueueCompare *run_queue_compare; + +static int +rqc_len_cmp(const void *x, const void *y) +{ + return ((ErtsRunQueueCompare *) x)->len - ((ErtsRunQueueCompare *) y)->len; +} + +#define ERTS_PERCENT(X, Y) \ + ((Y) == 0 \ + ? ((X) == 0 ? 100 : INT_MAX) \ + : ((100*(X))/(Y))) + +#define ERTS_UPDATE_FULL_REDS(QIX, LAST_REDS) \ +do { \ + run_queue_info[(QIX)].full_reds \ + = run_queue_info[(QIX)].full_reds_history_sum; \ + run_queue_info[(QIX)].full_reds += (LAST_REDS); \ + run_queue_info[(QIX)].full_reds \ + >>= ERTS_FULL_REDS_HISTORY_AVG_SHFT; \ + run_queue_info[(QIX)].full_reds_history_sum \ + -= run_queue_info[(QIX)].full_reds_history_change; \ + run_queue_info[(QIX)].full_reds_history_sum += (LAST_REDS); \ + run_queue_info[(QIX)].full_reds_history_change = (LAST_REDS); \ +} while (0) + +#define ERTS_DBG_CHK_FULL_REDS_HISTORY(RQ) \ +do { \ + int sum__ = 0; \ + int rix__; \ + for (rix__ = 0; rix__ < ERTS_FULL_REDS_HISTORY_SIZE; rix__++) \ + sum__ += (RQ)->full_reds_history[rix__]; \ + ASSERT(sum__ == (RQ)->full_reds_history_sum); \ +} while (0); + +static void +check_balance(ErtsRunQueue *c_rq) +{ + ErtsRunQueueBalance avg = {0}; + Sint64 scheds_reds, full_scheds_reds; + int forced, active, current_active, oowc, half_full_scheds, full_scheds, + mmax_len, blnc_no_rqs, qix, pix, freds_hist_ix; + + if (erts_smp_atomic_xchg(&balance_info.checking_balance, 1)) { + c_rq->check_balance_reds = INT_MAX; + return; + } + + blnc_no_rqs = (int) erts_smp_atomic_read(&balance_info.used_runqs); + if (blnc_no_rqs == 1) { + c_rq->check_balance_reds = INT_MAX; + erts_smp_atomic_set(&balance_info.checking_balance, 0); + return; + } + + erts_smp_runq_unlock(c_rq); + + if (balance_info.halftime) { + balance_info.halftime = 0; + erts_smp_atomic_set(&balance_info.checking_balance, 0); + ERTS_FOREACH_RUNQ(rq, + { + if (rq->waiting) + rq->flags |= ERTS_RUNQ_FLG_HALFTIME_OUT_OF_WORK; + else + rq->flags &= ~ERTS_RUNQ_FLG_HALFTIME_OUT_OF_WORK; + rq->check_balance_reds = ERTS_RUNQ_CALL_CHECK_BALANCE_REDS; + }); + + erts_smp_runq_lock(c_rq); + return; + } + + /* + * check_balance() is never called in more threads + * than one at a time, i.e., we will normally never + * get any conflicts on the balance_info.update_mtx. + * However, when blocking multi scheduling (which performance + * critical applications do *not* do) migration information + * is manipulated. Such updates of the migration information + * might clash with balancing. + */ + erts_smp_mtx_lock(&balance_info.update_mtx); + + forced = balance_info.forced_check_balance; + balance_info.forced_check_balance = 0; + + blnc_no_rqs = (int) erts_smp_atomic_read(&balance_info.used_runqs); + if (blnc_no_rqs == 1) { + erts_smp_mtx_unlock(&balance_info.update_mtx); + erts_smp_runq_lock(c_rq); + c_rq->check_balance_reds = INT_MAX; + erts_smp_atomic_set(&balance_info.checking_balance, 0); + return; + } + + freds_hist_ix = balance_info.full_reds_history_index; + balance_info.full_reds_history_index++; + if (balance_info.full_reds_history_index >= ERTS_FULL_REDS_HISTORY_SIZE) + balance_info.full_reds_history_index = 0; + + current_active = erts_smp_atomic_read(&balance_info.active_runqs); + + /* Read balance information for all run queues */ + for (qix = 0; qix < blnc_no_rqs; qix++) { + ErtsRunQueue *rq = ERTS_RUNQ_IX(qix); + erts_smp_runq_lock(rq); + + run_queue_info[qix].flags = rq->flags; + for (pix = 0; pix < ERTS_NO_PROC_PRIO_LEVELS; pix++) { + run_queue_info[qix].prio[pix].max_len + = rq->procs.prio_info[pix].max_len; + run_queue_info[qix].prio[pix].reds + = rq->procs.prio_info[pix].reds; + } + run_queue_info[qix].prio[ERTS_PORT_PRIO_LEVEL].max_len + = rq->ports.info.max_len; + run_queue_info[qix].prio[ERTS_PORT_PRIO_LEVEL].reds + = rq->ports.info.reds; + + run_queue_info[qix].full_reds_history_sum + = rq->full_reds_history_sum; + run_queue_info[qix].full_reds_history_change + = rq->full_reds_history[freds_hist_ix]; + + run_queue_info[qix].oowc = rq->out_of_work_count; + run_queue_info[qix].max_len = rq->max_len; + rq->check_balance_reds = INT_MAX; + + erts_smp_runq_unlock(rq); + } + + full_scheds = 0; + half_full_scheds = 0; + full_scheds_reds = 0; + scheds_reds = 0; + oowc = 0; + mmax_len = 0; + + /* Calculate availability for each priority in each run queues */ + for (qix = 0; qix < blnc_no_rqs; qix++) { + int treds = 0; + + if (run_queue_info[qix].flags & ERTS_RUNQ_FLG_OUT_OF_WORK) { + for (pix = 0; pix < ERTS_NO_PRIO_LEVELS; pix++) { + run_queue_info[qix].prio[pix].avail = 100; + treds += run_queue_info[qix].prio[pix].reds; + } + if (!(run_queue_info[qix].flags & ERTS_RUNQ_FLG_HALFTIME_OUT_OF_WORK)) + half_full_scheds++; + ERTS_UPDATE_FULL_REDS(qix, ERTS_RUNQ_CHECK_BALANCE_REDS_PER_SCHED); + } + else { + ASSERT(!(run_queue_info[qix].flags & ERTS_RUNQ_FLG_HALFTIME_OUT_OF_WORK)); + for (pix = 0; pix < ERTS_NO_PRIO_LEVELS; pix++) + treds += run_queue_info[qix].prio[pix].reds; + if (treds == 0) { + for (pix = 0; pix < ERTS_NO_PRIO_LEVELS; pix++) + run_queue_info[qix].prio[pix].avail = 0; + } + else { + int xreds = 0; + int procreds = treds; + procreds -= run_queue_info[qix].prio[ERTS_PORT_PRIO_LEVEL].reds; + + for (pix = 0; pix < ERTS_NO_PROC_PRIO_LEVELS; pix++) { + int av; + + if (xreds == 0) + av = 100; + else if (procreds == xreds) + av = 0; + else { + av = (100*(procreds - xreds)) / procreds; + if (av == 0) + av = 1; + } + run_queue_info[qix].prio[pix].avail = av; + if (pix < PRIORITY_NORMAL) /* ie., max or high */ + xreds += run_queue_info[qix].prio[pix].reds; + } + run_queue_info[qix].prio[ERTS_PORT_PRIO_LEVEL].avail = 100; + } + ERTS_UPDATE_FULL_REDS(qix, treds); + full_scheds_reds += run_queue_info[qix].full_reds; + full_scheds++; + half_full_scheds++; + } + run_queue_info[qix].reds = treds; + scheds_reds += treds; + oowc += run_queue_info[qix].oowc; + if (mmax_len < run_queue_info[qix].max_len) + mmax_len = run_queue_info[qix].max_len; + } + + if (!forced && half_full_scheds != blnc_no_rqs) { + int min = 1; + if (min < half_full_scheds) + min = half_full_scheds; + if (full_scheds) { + active = (scheds_reds - 1)/ERTS_RUNQ_CHECK_BALANCE_REDS_PER_SCHED+1; + } + else { + active = balance_info.last_active_runqs - 1; + } + + if (balance_info.last_active_runqs < current_active) { + ERTS_BLNCE_SAVE_RISE(current_active, mmax_len, scheds_reds); + active = current_active; + } + else if (active < balance_info.prev_rise.active_runqs) { + if (ERTS_PERCENT(mmax_len, + balance_info.prev_rise.max_len) >= 90 + && ERTS_PERCENT(scheds_reds, + balance_info.prev_rise.reds) >= 90) { + active = balance_info.prev_rise.active_runqs; + } + } + + if (active < min) + active = min; + else if (active > blnc_no_rqs) + active = blnc_no_rqs; + + if (active == blnc_no_rqs) + goto all_active; + + for (qix = 0; qix < active; qix++) { + run_queue_info[qix].flags = 0; + for (pix = 0; pix < ERTS_NO_PRIO_LEVELS; pix++) { + run_queue_info[qix].prio[pix].emigrate_to = -1; + run_queue_info[qix].prio[pix].immigrate_from = -1; + run_queue_info[qix].prio[pix].migration_limit = 0; + } + } + for (qix = active; qix < blnc_no_rqs; qix++) { + run_queue_info[qix].flags = ERTS_RUNQ_FLG_INACTIVE; + for (pix = 0; pix < ERTS_NO_PRIO_LEVELS; pix++) { + int tix = qix % active; + ERTS_SET_RUNQ_FLG_EMIGRATE(run_queue_info[qix].flags, pix); + run_queue_info[qix].prio[pix].emigrate_to = tix; + run_queue_info[qix].prio[pix].immigrate_from = -1; + run_queue_info[qix].prio[pix].migration_limit = 0; + } + } + } + else { + if (balance_info.last_active_runqs < current_active) + ERTS_BLNCE_SAVE_RISE(current_active, mmax_len, scheds_reds); + all_active: + + active = blnc_no_rqs; + + for (qix = 0; qix < blnc_no_rqs; qix++) { + + if (full_scheds_reds > 0) { + /* Calculate availability compared to other schedulers */ + if (!(run_queue_info[qix].flags & ERTS_RUNQ_FLG_OUT_OF_WORK)) { + Sint64 tmp = ((Sint64) run_queue_info[qix].full_reds + * (Sint64) full_scheds); + for (pix = 0; pix < ERTS_NO_PRIO_LEVELS; pix++) { + Sint64 avail = run_queue_info[qix].prio[pix].avail; + avail = (avail*tmp)/full_scheds_reds; + ASSERT(avail >= 0); + run_queue_info[qix].prio[pix].avail = (int) avail; + } + } + } + + /* Calculate average max length */ + for (pix = 0; pix < ERTS_NO_PRIO_LEVELS; pix++) { + run_queue_info[qix].prio[pix].emigrate_to = -1; + run_queue_info[qix].prio[pix].immigrate_from = -1; + avg.prio[pix].max_len += run_queue_info[qix].prio[pix].max_len; + avg.prio[pix].avail += run_queue_info[qix].prio[pix].avail; + } + + } + + for (pix = 0; pix < ERTS_NO_PRIO_LEVELS; pix++) { + int max_len = avg.prio[pix].max_len; + if (max_len != 0) { + int avail = avg.prio[pix].avail; + if (avail != 0) { + max_len = ((100*max_len - 1) / avail) + 1; + avg.prio[pix].max_len = max_len; + ASSERT(max_len >= 0); + } + } + } + + /* Calculate migration limits for all priority queues in all + run queues */ + for (qix = 0; qix < blnc_no_rqs; qix++) { + run_queue_info[qix].flags = 0; /* Reset for later use... */ + for (pix = 0; pix < ERTS_NO_PRIO_LEVELS; pix++) { + int limit; + if (avg.prio[pix].max_len == 0 + || run_queue_info[qix].prio[pix].avail == 0) + limit = 0; + else + limit = (((avg.prio[pix].max_len + * run_queue_info[qix].prio[pix].avail) - 1) + / 100 + 1); + run_queue_info[qix].prio[pix].migration_limit = limit; + } + } + + /* Setup migration paths for all priorities */ + for (pix = 0; pix < ERTS_NO_PRIO_LEVELS; pix++) { + int low = 0, high = 0; + for (qix = 0; qix < blnc_no_rqs; qix++) { + int len_diff = run_queue_info[qix].prio[pix].max_len; + len_diff -= run_queue_info[qix].prio[pix].migration_limit; +#ifdef DBG_PRINT +if (pix == 2) erts_fprintf(stderr, "%d ", len_diff); +#endif + run_queue_compare[qix].qix = qix; + run_queue_compare[qix].len = len_diff; + if (len_diff != 0) { + if (len_diff < 0) + low++; + else + high++; + } + } +#ifdef DBG_PRINT +if (pix == 2) erts_fprintf(stderr, "\n"); +#endif + if (low && high) { + int from_qix; + int to_qix; + int eof = 0; + int eot = 0; + int tix = 0; + int fix = blnc_no_rqs-1; + qsort(run_queue_compare, + blnc_no_rqs, + sizeof(ErtsRunQueueCompare), + rqc_len_cmp); + + while (1) { + if (run_queue_compare[fix].len <= 0) + eof = 1; + if (run_queue_compare[tix].len >= 0) + eot = 1; + if (eof || eot) + break; + from_qix = run_queue_compare[fix].qix; + to_qix = run_queue_compare[tix].qix; + if (run_queue_info[from_qix].prio[pix].avail == 0) { + ERTS_SET_RUNQ_FLG_EVACUATE(run_queue_info[from_qix].flags, + pix); + ERTS_SET_RUNQ_FLG_EVACUATE(run_queue_info[to_qix].flags, + pix); + } + ERTS_SET_RUNQ_FLG_EMIGRATE(run_queue_info[from_qix].flags, pix); + ERTS_SET_RUNQ_FLG_IMMIGRATE(run_queue_info[to_qix].flags, pix); + run_queue_info[from_qix].prio[pix].emigrate_to = to_qix; + run_queue_info[to_qix].prio[pix].immigrate_from = from_qix; + tix++; + fix--; + +#ifdef DBG_PRINT +if (pix == 2) erts_fprintf(stderr, "%d >--> %d\n", from_qix, to_qix); +#endif + } + + if (!eot && eof) { + if (fix < blnc_no_rqs-1) + fix++; + + if (run_queue_compare[fix].len > 0) { + int fix2 = -1; + while (tix < fix) { + if (run_queue_compare[tix].len >= 0) + break; + if (fix2 < fix) + fix2 = blnc_no_rqs-1; + from_qix = run_queue_compare[fix2].qix; + to_qix = run_queue_compare[tix].qix; + ASSERT(to_qix != from_qix); + if (run_queue_info[from_qix].prio[pix].avail == 0) + ERTS_SET_RUNQ_FLG_EVACUATE(run_queue_info[to_qix].flags, + pix); + ERTS_SET_RUNQ_FLG_IMMIGRATE(run_queue_info[to_qix].flags, pix); + run_queue_info[to_qix].prio[pix].immigrate_from = from_qix; + tix++; + fix2--; +#ifdef DBG_PRINT +if (pix == 2) erts_fprintf(stderr, "%d --> %d\n", from_qix, to_qix); +#endif + } + } + } + else if (!eof && eot) { + if (tix > 0) + tix--; + if (run_queue_compare[tix].len < 0) { + int tix2 = 0; + while (tix < fix) { + if (run_queue_compare[fix].len <= 0) + break; + if (tix2 > tix) + tix2 = 0; + from_qix = run_queue_compare[fix].qix; + to_qix = run_queue_compare[tix2].qix; + ASSERT(to_qix != from_qix); + if (run_queue_info[from_qix].prio[pix].avail == 0) + ERTS_SET_RUNQ_FLG_EVACUATE(run_queue_info[from_qix].flags, + pix); + ERTS_SET_RUNQ_FLG_EMIGRATE(run_queue_info[from_qix].flags, pix); + run_queue_info[from_qix].prio[pix].emigrate_to = to_qix; + fix--; + tix2++; +#ifdef DBG_PRINT +if (pix == 2) erts_fprintf(stderr, "%d >-- %d\n", from_qix, to_qix); +#endif + + } + } + } + } + } + +#ifdef DBG_PRINT +erts_fprintf(stderr, "--------------------------------\n"); +#endif + } + + balance_info.last_active_runqs = active; + erts_smp_atomic_set(&balance_info.active_runqs, active); + + balance_info.halftime = 1; + erts_smp_atomic_set(&balance_info.checking_balance, 0); + + /* Write migration paths and reset balance statistics in all queues */ + for (qix = 0; qix < blnc_no_rqs; qix++) { + int mqix; + Uint32 flags; + ErtsRunQueue *rq = ERTS_RUNQ_IX(qix); + ErtsRunQueueInfo *rqi; + flags = run_queue_info[qix].flags; + erts_smp_runq_lock(rq); + flags |= (rq->flags & ~ERTS_RUNQ_FLGS_MIGRATION_INFO); + ASSERT(!(flags & ERTS_RUNQ_FLG_OUT_OF_WORK)); + if (rq->waiting) + flags |= ERTS_RUNQ_FLG_OUT_OF_WORK; + + rq->full_reds_history_sum + = run_queue_info[qix].full_reds_history_sum; + rq->full_reds_history[freds_hist_ix] + = run_queue_info[qix].full_reds_history_change; + + ERTS_DBG_CHK_FULL_REDS_HISTORY(rq); + + rq->out_of_work_count = 0; + rq->flags = flags; + rq->max_len = rq->len; + for (pix = 0; pix < ERTS_NO_PRIO_LEVELS; pix++) { + rqi = (pix == ERTS_PORT_PRIO_LEVEL + ? &rq->ports.info + : &rq->procs.prio_info[pix]); + rqi->max_len = rqi->len; + rqi->reds = 0; + if (!(ERTS_CHK_RUNQ_FLG_EMIGRATE(flags, pix) + | ERTS_CHK_RUNQ_FLG_IMMIGRATE(flags, pix))) { + ASSERT(run_queue_info[qix].prio[pix].immigrate_from < 0); + ASSERT(run_queue_info[qix].prio[pix].emigrate_to < 0); +#ifdef DEBUG + rqi->migrate.limit.this = -1; + rqi->migrate.limit.other = -1; + ERTS_DBG_SET_INVALID_RUNQP(rqi->migrate.runq, 0x2); +#endif + + } + else if (ERTS_CHK_RUNQ_FLG_EMIGRATE(flags, pix)) { + ASSERT(!ERTS_CHK_RUNQ_FLG_IMMIGRATE(flags, pix)); + ASSERT(run_queue_info[qix].prio[pix].immigrate_from < 0); + ASSERT(run_queue_info[qix].prio[pix].emigrate_to >= 0); + + mqix = run_queue_info[qix].prio[pix].emigrate_to; + rqi->migrate.limit.this + = run_queue_info[qix].prio[pix].migration_limit; + rqi->migrate.limit.other + = run_queue_info[mqix].prio[pix].migration_limit; + rqi->migrate.runq = ERTS_RUNQ_IX(mqix); + } + else { + ASSERT(ERTS_CHK_RUNQ_FLG_IMMIGRATE(flags, pix)); + ASSERT(run_queue_info[qix].prio[pix].emigrate_to < 0); + ASSERT(run_queue_info[qix].prio[pix].immigrate_from >= 0); + + mqix = run_queue_info[qix].prio[pix].immigrate_from; + rqi->migrate.limit.this + = run_queue_info[qix].prio[pix].migration_limit; + rqi->migrate.limit.other + = run_queue_info[mqix].prio[pix].migration_limit; + rqi->migrate.runq = ERTS_RUNQ_IX(mqix); + } + } + + rq->check_balance_reds = ERTS_RUNQ_CALL_CHECK_BALANCE_REDS; + erts_smp_runq_unlock(rq); + } + + balance_info.n++; + erts_smp_mtx_unlock(&balance_info.update_mtx); + + erts_smp_runq_lock(c_rq); +} + +#endif /* #ifdef ERTS_SMP */ + +Uint +erts_debug_nbalance(void) +{ +#ifdef ERTS_SMP + Uint n; + erts_smp_mtx_lock(&balance_info.update_mtx); + n = balance_info.n; + erts_smp_mtx_unlock(&balance_info.update_mtx); + return n; +#else + return 0; +#endif +} + +void +erts_early_init_scheduling(void) +{ + early_cpu_bind_init(); +} + +void +erts_init_scheduling(int mrq, int no_schedulers, int no_schedulers_online) +{ + int ix, n; + +#ifndef ERTS_SMP + mrq = 0; +#endif + + init_misc_op_list_alloc(); + + ASSERT(no_schedulers_online <= no_schedulers); + ASSERT(no_schedulers_online >= 1); + ASSERT(no_schedulers >= 1); + + /* Create and initialize run queues */ + + n = (int) (mrq ? no_schedulers : 1); + + erts_aligned_run_queues = erts_alloc(ERTS_ALC_T_RUNQS, + (sizeof(ErtsAlignedRunQueue)*(n+1))); + if ((((Uint) erts_aligned_run_queues) & ERTS_CACHE_LINE_MASK) == 0) + erts_aligned_run_queues = ((ErtsAlignedRunQueue *) + ((((Uint) erts_aligned_run_queues) + & ~ERTS_CACHE_LINE_MASK) + + ERTS_CACHE_LINE_SIZE)); + +#ifdef ERTS_SMP + erts_smp_atomic_init(&no_empty_run_queues, 0); +#endif + + for (ix = 0; ix < n; ix++) { + int pix, rix; + ErtsRunQueue *rq = ERTS_RUNQ_IX(ix); + + rq->ix = ix; + erts_smp_atomic_init(&rq->info_flags, ERTS_RUNQ_IFLG_NONEMPTY); + + erts_smp_mtx_init(&rq->mtx, "run_queue"); + erts_smp_cnd_init(&rq->cnd); + + erts_smp_atomic_init(&rq->spin_waiter, 0); + erts_smp_atomic_init(&rq->spin_wake, 0); + + rq->waiting = 0; + rq->woken = 0; + rq->flags = !mrq ? ERTS_RUNQ_FLG_SHARED_RUNQ : 0; + rq->check_balance_reds = ERTS_RUNQ_CALL_CHECK_BALANCE_REDS; + rq->full_reds_history_sum = 0; + for (rix = 0; rix < ERTS_FULL_REDS_HISTORY_SIZE; rix++) { + rq->full_reds_history_sum += ERTS_RUNQ_CHECK_BALANCE_REDS_PER_SCHED; + rq->full_reds_history[rix] = ERTS_RUNQ_CHECK_BALANCE_REDS_PER_SCHED; + } + rq->out_of_work_count = 0; + rq->max_len = 0; + rq->len = 0; + rq->wakeup_other = 0; + rq->wakeup_other_reds = 0; + + rq->procs.len = 0; + rq->procs.pending_exiters = NULL; + rq->procs.context_switches = 0; + rq->procs.reductions = 0; + + for (pix = 0; pix < ERTS_NO_PROC_PRIO_LEVELS; pix++) { + rq->procs.prio_info[pix].len = 0; + rq->procs.prio_info[pix].max_len = 0; + rq->procs.prio_info[pix].reds = 0; + rq->procs.prio_info[pix].migrate.limit.this = 0; + rq->procs.prio_info[pix].migrate.limit.other = 0; + ERTS_DBG_SET_INVALID_RUNQP(rq->procs.prio_info[pix].migrate.runq, + 0x0); + if (pix < ERTS_NO_PROC_PRIO_LEVELS - 1) { + rq->procs.prio[pix].first = NULL; + rq->procs.prio[pix].last = NULL; + } + } + + rq->misc.start = NULL; + rq->misc.end = NULL; + rq->misc.evac_runq = NULL; + + rq->ports.info.len = 0; + rq->ports.info.max_len = 0; + rq->ports.info.reds = 0; + rq->ports.info.migrate.limit.this = 0; + rq->ports.info.migrate.limit.other = 0; + rq->ports.info.migrate.runq = NULL; + rq->ports.start = NULL; + rq->ports.end = NULL; + } + + erts_common_run_queue = !mrq ? ERTS_RUNQ_IX(0) : NULL; + erts_no_run_queues = n; + +#ifdef ERTS_SMP + + if (erts_no_run_queues != 1) { + run_queue_info = erts_alloc(ERTS_ALC_T_RUNQ_BLNS, + (sizeof(ErtsRunQueueBalance) + * erts_no_run_queues)); + run_queue_compare = erts_alloc(ERTS_ALC_T_RUNQ_BLNS, + (sizeof(ErtsRunQueueCompare) + * erts_no_run_queues)); + } + +#endif + + /* Create and initialize scheduler specific data */ + + n = (int) no_schedulers; + erts_aligned_scheduler_data = erts_alloc(ERTS_ALC_T_SCHDLR_DATA, + (sizeof(ErtsAlignedSchedulerData) + *(n+1))); + if ((((Uint) erts_aligned_scheduler_data) & ERTS_CACHE_LINE_MASK) == 0) + erts_aligned_scheduler_data = ((ErtsAlignedSchedulerData *) + ((((Uint) erts_aligned_scheduler_data) + & ~ERTS_CACHE_LINE_MASK) + + ERTS_CACHE_LINE_SIZE)); + for (ix = 0; ix < n; ix++) { + ErtsSchedulerData *esdp = ERTS_SCHEDULER_IX(ix); +#ifdef ERTS_SMP + erts_bits_init_state(&esdp->erl_bits_state); + esdp->match_pseudo_process = NULL; + esdp->free_process = NULL; +#endif + esdp->no = (Uint) ix+1; + esdp->current_process = NULL; + esdp->current_port = NULL; + + esdp->virtual_reds = 0; + esdp->cpu_id = -1; + + erts_init_atom_cache_map(&esdp->atom_cache_map); + + if (erts_common_run_queue) { + esdp->run_queue = erts_common_run_queue; + esdp->run_queue->scheduler = NULL; + } + else { + esdp->run_queue = ERTS_RUNQ_IX(ix); + esdp->run_queue->scheduler = esdp; + } + +#ifdef ERTS_SMP +#ifdef ERTS_SMP_SCHEDULERS_NEED_TO_CHECK_CHILDREN + esdp->check_children = 0; + esdp->blocked_check_children = 0; +#endif + erts_smp_atomic_init(&esdp->suspended, 0); + erts_smp_atomic_init(&esdp->chk_cpu_bind, 0); +#endif + } + +#ifdef ERTS_SMP + erts_smp_mtx_init(&schdlr_sspnd.mtx, "schdlr_sspnd"); + erts_smp_cnd_init(&schdlr_sspnd.cnd); + + schdlr_sspnd.changing = 0; + schdlr_sspnd.online = no_schedulers_online; + schdlr_sspnd.curr_online = no_schedulers; + erts_smp_atomic_init(&schdlr_sspnd.msb.ongoing, 0); + erts_smp_atomic_init(&schdlr_sspnd.active, no_schedulers); + schdlr_sspnd.msb.procs = NULL; + erts_smp_atomic_set(&balance_info.used_runqs, + erts_common_run_queue ? 1 : no_schedulers_online); + erts_smp_atomic_init(&balance_info.active_runqs, no_schedulers); + balance_info.last_active_runqs = no_schedulers; + erts_smp_mtx_init(&balance_info.update_mtx, "migration_info_update"); + balance_info.forced_check_balance = 0; + balance_info.halftime = 1; + balance_info.full_reds_history_index = 0; + erts_smp_atomic_init(&balance_info.checking_balance, 0); + balance_info.prev_rise.active_runqs = 0; + balance_info.prev_rise.max_len = 0; + balance_info.prev_rise.reds = 0; + balance_info.n = 0; + + if (no_schedulers_online < no_schedulers) { + if (erts_common_run_queue) { + for (ix = no_schedulers_online; ix < no_schedulers; ix++) + erts_smp_atomic_set(&(ERTS_SCHEDULER_IX(ix)->suspended), 1); + } + else { + for (ix = no_schedulers_online; ix < erts_no_run_queues; ix++) + evacuate_run_queue(ERTS_RUNQ_IX(ix), + ERTS_RUNQ_IX(ix % no_schedulers_online)); + } + } + + schdlr_sspnd.wait_curr_online = no_schedulers_online; + schdlr_sspnd.curr_online *= 2; /* Boot strapping... */ + schdlr_sspnd.changing = ERTS_SCHED_CHANGING_ONLINE; + + erts_smp_atomic_init(&doing_sys_schedule, 0); + +#else /* !ERTS_SMP */ + { + ErtsSchedulerData *esdp; + esdp = ERTS_SCHEDULER_IX(0); + erts_scheduler_data = esdp; +#ifdef USE_THREADS + erts_tsd_set(sched_data_key, (void *) esdp); +#endif + } + erts_no_schedulers = 1; +#endif + + erts_smp_atomic_init(&function_calls, 0); + + /* init port tasks */ + erts_port_task_init(); + + late_cpu_bind_init(); +} + +ErtsRunQueue * +erts_schedid2runq(Uint id) +{ + int ix; + if (erts_common_run_queue) + return erts_common_run_queue; + ix = (int) id - 1; + ASSERT(0 <= ix && ix < erts_no_run_queues); + return ERTS_RUNQ_IX(ix); +} + +#ifdef USE_THREADS + +ErtsSchedulerData * +erts_get_scheduler_data(void) +{ + return (ErtsSchedulerData *) erts_tsd_get(sched_data_key); +} + +#endif + +static int remove_proc_from_runq(ErtsRunQueue *rq, Process *p, int to_inactive); + +static ERTS_INLINE void +suspend_process(ErtsRunQueue *rq, Process *p) +{ + ERTS_SMP_LC_ASSERT(ERTS_PROC_LOCK_STATUS & erts_proc_lc_my_proc_locks(p)); + ERTS_SMP_LC_ASSERT(erts_smp_lc_runq_is_locked(rq)); + p->rcount++; /* count number of suspend */ +#ifdef ERTS_SMP + ASSERT(!(p->runq_flags & ERTS_PROC_RUNQ_FLG_RUNNING) + || p == erts_get_current_process()); + ASSERT(p->status != P_RUNNING + || p->runq_flags & ERTS_PROC_RUNQ_FLG_RUNNING); + if (p->status_flags & ERTS_PROC_SFLG_PENDADD2SCHEDQ) + goto runable; +#endif + switch(p->status) { + case P_SUSPENDED: + break; + case P_RUNABLE: +#ifdef ERTS_SMP + runable: + if (!ERTS_PROC_PENDING_EXIT(p)) +#endif + remove_proc_from_runq(rq, p, 1); + /* else: + * leave process in schedq so it will discover the pending exit + */ + p->rstatus = P_RUNABLE; /* wakeup as runnable */ + break; + case P_RUNNING: + p->rstatus = P_RUNABLE; /* wakeup as runnable */ + break; + case P_WAITING: + p->rstatus = P_WAITING; /* wakeup as waiting */ + break; + case P_EXITING: + return; /* ignore this */ + case P_GARBING: + case P_FREE: + erl_exit(1, "bad state in suspend_process()\n"); + } + + if ((erts_system_profile_flags.runnable_procs) && (p->rcount == 1) && (p->status != P_WAITING)) { + profile_runnable_proc(p, am_inactive); + } + + p->status = P_SUSPENDED; + +} + +static ERTS_INLINE void +resume_process(Process *p) +{ + Uint32 *statusp; + ERTS_SMP_LC_ASSERT(ERTS_PROC_LOCK_STATUS & erts_proc_lc_my_proc_locks(p)); + switch (p->status) { + case P_SUSPENDED: + statusp = &p->status; + break; + case P_GARBING: + if (p->gcstatus == P_SUSPENDED) { + statusp = &p->gcstatus; + break; + } + /* Fall through */ + default: + return; + } + + ASSERT(p->rcount > 0); + + if (--p->rcount > 0) /* multiple suspend */ + return; + switch(p->rstatus) { + case P_RUNABLE: + *statusp = P_WAITING; /* make erts_add_to_runq work */ + erts_add_to_runq(p); + break; + case P_WAITING: + *statusp = P_WAITING; + break; + default: + erl_exit(1, "bad state in resume_process()\n"); + } + p->rstatus = P_FREE; +} + +#ifdef ERTS_SMP + +static void +susp_sched_prep_block(void *unused) +{ + erts_smp_mtx_unlock(&schdlr_sspnd.mtx); +} + +static void +susp_sched_resume_block(void *unused) +{ + erts_smp_mtx_lock(&schdlr_sspnd.mtx); +} + +static void +suspend_scheduler(ErtsSchedulerData *esdp) +{ + long no = (long) esdp->no; + ErtsRunQueue *rq = esdp->run_queue; + long active_schedulers; + int curr_online = 1; + int wake = 0; + + /* + * Schedulers may be suspended in two different ways: + * - A scheduler may be suspended since it is not online. + * All schedulers with scheduler ids greater than + * schdlr_sspnd.online are suspended. + * - Multi scheduling is blocked. All schedulers except the + * scheduler with scheduler id 1 are suspended. + * + * Regardless of why a scheduler is suspended, it ends up here. + */ + + ASSERT(no != 1); + + erts_smp_runq_unlock(esdp->run_queue); + + /* Unbind from cpu */ + erts_smp_rwmtx_rwlock(&erts_cpu_bind_rwmtx); + if (scheduler2cpu_map[esdp->no].bound_id >= 0 + && erts_unbind_from_cpu(erts_cpuinfo) == 0) { + esdp->cpu_id = scheduler2cpu_map[esdp->no].bound_id = -1; + } + erts_smp_rwmtx_rwunlock(&erts_cpu_bind_rwmtx); + + if (erts_system_profile_flags.scheduler) + profile_scheduler(make_small(esdp->no), am_inactive); + + erts_smp_mtx_lock(&schdlr_sspnd.mtx); + + active_schedulers = erts_smp_atomic_dectest(&schdlr_sspnd.active); + ASSERT(active_schedulers >= 1); + if (schdlr_sspnd.changing == ERTS_SCHED_CHANGING_MULTI_SCHED) { + if (active_schedulers == schdlr_sspnd.msb.wait_active) + wake = 1; + if (active_schedulers == 1) + schdlr_sspnd.changing = 0; + } + + while (1) { + +#ifdef ERTS_SMP_SCHEDULERS_NEED_TO_CHECK_CHILDREN + int check_children; + erts_smp_runq_lock(esdp->run_queue); + check_children = esdp->check_children; + esdp->check_children = 0; + erts_smp_runq_unlock(esdp->run_queue); + if (check_children) { + erts_smp_mtx_unlock(&schdlr_sspnd.mtx); + erts_check_children(); + erts_smp_mtx_lock(&schdlr_sspnd.mtx); + } +#endif + + if (schdlr_sspnd.changing == ERTS_SCHED_CHANGING_ONLINE) { + int changed = 0; + if (no > schdlr_sspnd.online && curr_online) { + schdlr_sspnd.curr_online--; + curr_online = 0; + changed = 1; + } + else if (no <= schdlr_sspnd.online && !curr_online) { + schdlr_sspnd.curr_online++; + curr_online = 1; + changed = 1; + } + if (changed + && schdlr_sspnd.curr_online == schdlr_sspnd.wait_curr_online) + wake = 1; + if (schdlr_sspnd.online == schdlr_sspnd.curr_online) + schdlr_sspnd.changing = 0; + } + + if (wake) { + erts_smp_cnd_broadcast(&schdlr_sspnd.cnd); + wake = 0; + } + + + if (!(rq->flags & (ERTS_RUNQ_FLG_SHARED_RUNQ|ERTS_RUNQ_FLG_SUSPENDED))) + break; + if ((rq->flags & ERTS_RUNQ_FLG_SHARED_RUNQ) + && !erts_smp_atomic_read(&esdp->suspended)) + break; + + erts_smp_activity_begin(ERTS_ACTIVITY_WAIT, + susp_sched_prep_block, + susp_sched_resume_block, + NULL); + while (1) { + +#ifdef ERTS_SMP_SCHEDULERS_NEED_TO_CHECK_CHILDREN + if (esdp->blocked_check_children) + break; +#endif + + erts_smp_cnd_wait(&schdlr_sspnd.cnd, &schdlr_sspnd.mtx); + + if (schdlr_sspnd.changing == ERTS_SCHED_CHANGING_ONLINE) + break; + + if (!(rq->flags & (ERTS_RUNQ_FLG_SHARED_RUNQ + | ERTS_RUNQ_FLG_SUSPENDED))) + break; + if ((rq->flags & ERTS_RUNQ_FLG_SHARED_RUNQ) + && !erts_smp_atomic_read(&esdp->suspended)) + break; + } + +#ifdef ERTS_SMP_SCHEDULERS_NEED_TO_CHECK_CHILDREN + esdp->blocked_check_children = 0; +#endif + + erts_smp_activity_end(ERTS_ACTIVITY_WAIT, + susp_sched_prep_block, + susp_sched_resume_block, + NULL); + } + + erts_smp_atomic_inc(&schdlr_sspnd.active); + + erts_smp_mtx_unlock(&schdlr_sspnd.mtx); + + if (erts_system_profile_flags.scheduler) + profile_scheduler(make_small(esdp->no), am_active); + + erts_smp_runq_lock(esdp->run_queue); + non_empty_runq(esdp->run_queue); + + /* Make sure we check if we should bind to a cpu or not... */ + if (rq->flags & ERTS_RUNQ_FLG_SHARED_RUNQ) + erts_smp_atomic_set(&esdp->chk_cpu_bind, 1); + else + rq->flags |= ERTS_RUNQ_FLG_CHK_CPU_BIND; +} + +#define ERTS_RUNQ_RESET_SUSPEND_INFO(RQ, DBG_ID) \ +do { \ + int pix__; \ + (RQ)->misc.evac_runq = NULL; \ + (RQ)->ports.info.migrate.runq = NULL; \ + (RQ)->flags &= ~(ERTS_RUNQ_FLGS_IMMIGRATE_QMASK \ + | ERTS_RUNQ_FLGS_EMIGRATE_QMASK \ + | ERTS_RUNQ_FLGS_EVACUATE_QMASK \ + | ERTS_RUNQ_FLG_SUSPENDED); \ + (RQ)->flags |= (ERTS_RUNQ_FLG_OUT_OF_WORK \ + | ERTS_RUNQ_FLG_HALFTIME_OUT_OF_WORK); \ + (RQ)->check_balance_reds = ERTS_RUNQ_CALL_CHECK_BALANCE_REDS; \ + erts_smp_atomic_band(&(RQ)->info_flags, ~ERTS_RUNQ_IFLG_SUSPENDED); \ + for (pix__ = 0; pix__ < ERTS_NO_PROC_PRIO_LEVELS; pix__++) { \ + (RQ)->procs.prio_info[pix__].max_len = 0; \ + (RQ)->procs.prio_info[pix__].reds = 0; \ + ERTS_DBG_SET_INVALID_RUNQP((RQ)->procs.prio_info[pix__].migrate.runq,\ + (DBG_ID)); \ + } \ + (RQ)->ports.info.max_len = 0; \ + (RQ)->ports.info.reds = 0; \ +} while (0) + +#define ERTS_RUNQ_RESET_MIGRATION_PATHS__(RQ) \ +do { \ + ERTS_SMP_LC_ASSERT(erts_smp_lc_runq_is_locked((RQ))); \ + (RQ)->misc.evac_runq = NULL; \ + (RQ)->ports.info.migrate.runq = NULL; \ + (RQ)->flags &= ~(ERTS_RUNQ_FLGS_IMMIGRATE_QMASK \ + | ERTS_RUNQ_FLGS_EMIGRATE_QMASK \ + | ERTS_RUNQ_FLGS_EVACUATE_QMASK); \ +} while (0) + +#ifdef DEBUG +#define ERTS_RUNQ_RESET_MIGRATION_PATHS(RQ, DBG_ID) \ +do { \ + int pix__; \ + ERTS_RUNQ_RESET_MIGRATION_PATHS__((RQ)); \ + for (pix__ = 0; pix__ < ERTS_NO_PROC_PRIO_LEVELS; pix__++) \ + ERTS_DBG_SET_INVALID_RUNQP((RQ)->procs.prio_info[pix__].migrate.runq,\ + (DBG_ID)); \ +} while (0) +#else +#define ERTS_RUNQ_RESET_MIGRATION_PATHS(RQ, DBG_ID) \ + ERTS_RUNQ_RESET_MIGRATION_PATHS__((RQ)) +#endif + +ErtsSchedSuspendResult +erts_schedulers_state(Uint *total, + Uint *online, + Uint *active, + int yield_allowed) +{ + int res; + erts_smp_mtx_lock(&schdlr_sspnd.mtx); + if (yield_allowed && schdlr_sspnd.changing) + res = ERTS_SCHDLR_SSPND_YIELD_RESTART; + else { + *active = *online = schdlr_sspnd.online; + if (ongoing_multi_scheduling_block()) + *active = 1; + res = ERTS_SCHDLR_SSPND_DONE; + } + erts_smp_mtx_unlock(&schdlr_sspnd.mtx); + *total = erts_no_schedulers; + return res; +} + +ErtsSchedSuspendResult +erts_set_schedulers_online(Process *p, + ErtsProcLocks plocks, + Sint new_no, + Sint *old_no) +{ + int ix, res, no, have_unlocked_plocks; + + if (new_no < 1 || erts_no_schedulers < new_no) + return ERTS_SCHDLR_SSPND_EINVAL; + + erts_smp_mtx_lock(&schdlr_sspnd.mtx); + + have_unlocked_plocks = 0; + no = (int) new_no; + + if (schdlr_sspnd.changing) { + res = ERTS_SCHDLR_SSPND_YIELD_RESTART; + } + else { + int online = *old_no = schdlr_sspnd.online; + if (no == schdlr_sspnd.online) { + res = ERTS_SCHDLR_SSPND_DONE; + } + else { + schdlr_sspnd.changing = ERTS_SCHED_CHANGING_ONLINE; + schdlr_sspnd.online = no; + if (no > online) { + int ix; + schdlr_sspnd.wait_curr_online = no; + if (ongoing_multi_scheduling_block()) + /* No schedulers to resume */; + else if (erts_common_run_queue) { + for (ix = online; ix < no; ix++) + erts_smp_atomic_set(&ERTS_SCHEDULER_IX(ix)->suspended, + 0); + } + else { + if (plocks) { + have_unlocked_plocks = 1; + erts_smp_proc_unlock(p, plocks); + } + erts_smp_mtx_unlock(&schdlr_sspnd.mtx); + erts_smp_mtx_lock(&balance_info.update_mtx); + for (ix = online; ix < no; ix++) { + ErtsRunQueue *rq = ERTS_RUNQ_IX(ix); + erts_smp_runq_lock(rq); + ERTS_RUNQ_RESET_SUSPEND_INFO(rq, 0x5); + erts_smp_runq_unlock(rq); + } + /* + * Spread evacuation paths among all online + * run queues. + */ + for (ix = no; ix < erts_no_run_queues; ix++) { + ErtsRunQueue *from_rq = ERTS_RUNQ_IX(ix); + ErtsRunQueue *to_rq = ERTS_RUNQ_IX(ix % no); + evacuate_run_queue(from_rq, to_rq); + } + erts_smp_atomic_set(&balance_info.used_runqs, no); + erts_smp_mtx_unlock(&balance_info.update_mtx); + erts_smp_mtx_lock(&schdlr_sspnd.mtx); + } + erts_smp_cnd_broadcast(&schdlr_sspnd.cnd); + res = ERTS_SCHDLR_SSPND_DONE; + } + else /* if (no < online) */ { + if (p->scheduler_data->no <= no) { + res = ERTS_SCHDLR_SSPND_DONE; + schdlr_sspnd.wait_curr_online = no; + } + else { + /* + * Yield! Current process needs to migrate + * before bif returns. + */ + res = ERTS_SCHDLR_SSPND_YIELD_DONE; + schdlr_sspnd.wait_curr_online = no+1; + } + + if (ongoing_multi_scheduling_block()) + erts_smp_cnd_broadcast(&schdlr_sspnd.cnd); + else if (erts_common_run_queue) { + for (ix = no; ix < online; ix++) + erts_smp_atomic_set(&ERTS_SCHEDULER_IX(ix)->suspended, + 1); + wake_all_schedulers(); + } + else { + if (plocks) { + have_unlocked_plocks = 1; + erts_smp_proc_unlock(p, plocks); + } + erts_smp_mtx_unlock(&schdlr_sspnd.mtx); + erts_smp_mtx_lock(&balance_info.update_mtx); + + for (ix = 0; ix < online; ix++) { + ErtsRunQueue *rq = ERTS_RUNQ_IX(ix); + erts_smp_runq_lock(rq); + ERTS_RUNQ_RESET_MIGRATION_PATHS(rq, 0x6); + erts_smp_runq_unlock(rq); + } + /* + * Evacutation order important! Newly suspended run queues + * has to be evacuated last. + */ + for (ix = erts_no_run_queues-1; ix >= no; ix--) + evacuate_run_queue(ERTS_RUNQ_IX(ix), + ERTS_RUNQ_IX(ix % no)); + erts_smp_atomic_set(&balance_info.used_runqs, no); + erts_smp_mtx_unlock(&balance_info.update_mtx); + erts_smp_mtx_lock(&schdlr_sspnd.mtx); + ERTS_FOREACH_OP_RUNQ(rq, wake_scheduler(rq, 0)); + } + } + + erts_smp_activity_begin(ERTS_ACTIVITY_WAIT, + susp_sched_prep_block, + susp_sched_resume_block, + NULL); + while (schdlr_sspnd.curr_online != schdlr_sspnd.wait_curr_online) + erts_smp_cnd_wait(&schdlr_sspnd.cnd, &schdlr_sspnd.mtx); + erts_smp_activity_end(ERTS_ACTIVITY_WAIT, + susp_sched_prep_block, + susp_sched_resume_block, + NULL); + } + } + + erts_smp_mtx_unlock(&schdlr_sspnd.mtx); + if (have_unlocked_plocks) + erts_smp_proc_lock(p, plocks); + + return res; +} + +ErtsSchedSuspendResult +erts_block_multi_scheduling(Process *p, ErtsProcLocks plocks, int on, int all) +{ + int ix, res, have_unlocked_plocks = 0; + ErtsProcList *plp; + + erts_smp_mtx_lock(&schdlr_sspnd.mtx); + if (on) { + if (schdlr_sspnd.changing) { + res = ERTS_SCHDLR_SSPND_YIELD_RESTART; /* Yield */ + } + else if (erts_is_multi_scheduling_blocked()) { + plp = proclist_create(p); + plp->next = schdlr_sspnd.msb.procs; + schdlr_sspnd.msb.procs = plp; + p->flags |= F_HAVE_BLCKD_MSCHED; + ASSERT(erts_smp_atomic_read(&schdlr_sspnd.active) == 1); + ASSERT(p->scheduler_data->no == 1); + res = 1; + } + else { + p->flags |= F_HAVE_BLCKD_MSCHED; + if (plocks) { + have_unlocked_plocks = 1; + erts_smp_proc_unlock(p, plocks); + } + erts_smp_atomic_set(&schdlr_sspnd.msb.ongoing, 1); + if (schdlr_sspnd.online == 1) { + res = ERTS_SCHDLR_SSPND_DONE_MSCHED_BLOCKED; + ASSERT(erts_smp_atomic_read(&schdlr_sspnd.active) == 1); + ASSERT(p->scheduler_data->no == 1); + } + else { + schdlr_sspnd.changing = ERTS_SCHED_CHANGING_MULTI_SCHED; + if (p->scheduler_data->no == 1) { + res = ERTS_SCHDLR_SSPND_DONE_MSCHED_BLOCKED; + schdlr_sspnd.msb.wait_active = 1; + } + else { + /* + * Yield! Current process needs to migrate + * before bif returns. + */ + res = ERTS_SCHDLR_SSPND_YIELD_DONE_MSCHED_BLOCKED; + schdlr_sspnd.msb.wait_active = 2; + } + if (erts_common_run_queue) { + for (ix = 1; ix < schdlr_sspnd.online; ix++) + erts_smp_atomic_set(&ERTS_SCHEDULER_IX(ix)->suspended, 1); + wake_all_schedulers(); + } + else { + erts_smp_mtx_unlock(&schdlr_sspnd.mtx); + erts_smp_mtx_lock(&balance_info.update_mtx); + erts_smp_atomic_set(&balance_info.used_runqs, 1); + for (ix = 0; ix < schdlr_sspnd.online; ix++) { + ErtsRunQueue *rq = ERTS_RUNQ_IX(ix); + erts_smp_runq_lock(rq); + ERTS_RUNQ_RESET_MIGRATION_PATHS(rq, 0x7); + erts_smp_runq_unlock(rq); + } + /* + * Evacuate all activities in all other run queues + * into the first run queue. Note order is important, + * online run queues has to be evacuated last. + */ + for (ix = erts_no_run_queues-1; ix >= 1; ix--) + evacuate_run_queue(ERTS_RUNQ_IX(ix), ERTS_RUNQ_IX(0)); + erts_smp_mtx_unlock(&balance_info.update_mtx); + erts_smp_mtx_lock(&schdlr_sspnd.mtx); + } + erts_smp_activity_begin(ERTS_ACTIVITY_WAIT, + susp_sched_prep_block, + susp_sched_resume_block, + NULL); + while (erts_smp_atomic_read(&schdlr_sspnd.active) + != schdlr_sspnd.msb.wait_active) + erts_smp_cnd_wait(&schdlr_sspnd.cnd, &schdlr_sspnd.mtx); + erts_smp_activity_end(ERTS_ACTIVITY_WAIT, + susp_sched_prep_block, + susp_sched_resume_block, + NULL); + } + plp = proclist_create(p); + plp->next = schdlr_sspnd.msb.procs; + schdlr_sspnd.msb.procs = plp; +#ifdef DEBUG + ERTS_FOREACH_RUNQ(srq, + { + if (srq != ERTS_RUNQ_IX(0)) { + ASSERT(ERTS_EMPTY_RUNQ(srq)); + ASSERT(srq->flags & ERTS_RUNQ_FLG_SUSPENDED); + } + }); +#endif + ASSERT(p->scheduler_data); + } + } + else if (!ongoing_multi_scheduling_block()) { + ASSERT(!schdlr_sspnd.msb.procs); + res = ERTS_SCHDLR_SSPND_DONE; + } + else { + if (p->flags & F_HAVE_BLCKD_MSCHED) { + ErtsProcList **plpp = &schdlr_sspnd.msb.procs; + plp = schdlr_sspnd.msb.procs; + + while (plp) { + if (!proclist_same(plp, p)){ + plpp = &plp->next; + plp = plp->next; + } + else { + *plpp = plp->next; + proclist_destroy(plp); + if (!all) + break; + plp = *plpp; + } + } + } + if (schdlr_sspnd.msb.procs) + res = ERTS_SCHDLR_SSPND_DONE_MSCHED_BLOCKED; + else { + schdlr_sspnd.changing = ERTS_SCHED_CHANGING_MULTI_SCHED; +#ifdef DEBUG + ERTS_FOREACH_RUNQ(rq, + { + if (rq != p->scheduler_data->run_queue) { + if (!ERTS_EMPTY_RUNQ(rq)) { + Process *rp; + int pix; + ASSERT(rq->ports.info.len == 0); + for (pix = 0; pix < ERTS_NO_PROC_PRIO_LEVELS; pix++) { + for (rp = rq->procs.prio[pix].first; + rp; + rp = rp->next) { + ASSERT(rp->bound_runq); + } + } + } + + ASSERT(rq->flags & ERTS_RUNQ_FLG_SUSPENDED); + } + }); +#endif + p->flags &= ~F_HAVE_BLCKD_MSCHED; + erts_smp_atomic_set(&schdlr_sspnd.msb.ongoing, 0); + if (schdlr_sspnd.online == 1) + /* No schedulers to resume */; + else if (erts_common_run_queue) { + for (ix = 1; ix < schdlr_sspnd.online; ix++) + erts_smp_atomic_set(&ERTS_SCHEDULER_IX(ix)->suspended, 0); + wake_all_schedulers(); + } + else { + int online = schdlr_sspnd.online; + erts_smp_mtx_unlock(&schdlr_sspnd.mtx); + if (plocks) { + have_unlocked_plocks = 1; + erts_smp_proc_unlock(p, plocks); + } + erts_smp_mtx_lock(&balance_info.update_mtx); + + /* Resume all online run queues */ + for (ix = 1; ix < online; ix++) { + ErtsRunQueue *rq = ERTS_RUNQ_IX(ix); + erts_smp_runq_lock(rq); + ERTS_RUNQ_RESET_SUSPEND_INFO(rq, 0x4); + erts_smp_runq_unlock(rq); + } + + /* Spread evacuation paths among all online run queues */ + for (ix = online; ix < erts_no_run_queues; ix++) + evacuate_run_queue(ERTS_RUNQ_IX(ix), + ERTS_RUNQ_IX(ix % online)); + + erts_smp_atomic_set(&balance_info.used_runqs, online); + /* Make sure that we balance soon... */ + balance_info.forced_check_balance = 1; + erts_smp_runq_lock(ERTS_RUNQ_IX(0)); + ERTS_RUNQ_IX(0)->check_balance_reds = 0; + erts_smp_runq_unlock(ERTS_RUNQ_IX(0)); + erts_smp_mtx_unlock(&balance_info.update_mtx); + erts_smp_mtx_lock(&schdlr_sspnd.mtx); + } + erts_smp_cnd_broadcast(&schdlr_sspnd.cnd); + schdlr_sspnd.changing = 0; + res = ERTS_SCHDLR_SSPND_DONE; + } + } + + erts_smp_mtx_unlock(&schdlr_sspnd.mtx); + if (have_unlocked_plocks) + erts_smp_proc_lock(p, plocks); + return res; +} + +#ifdef DEBUG +void +erts_dbg_multi_scheduling_return_trap(Process *p, Eterm return_value) +{ + if (return_value == am_blocked) { + long active = erts_smp_atomic_read(&schdlr_sspnd.active); + ASSERT(1 <= active && active <= 2); + ASSERT(ERTS_PROC_GET_SCHDATA(p)->no == 1); + } +} +#endif + +int +erts_is_multi_scheduling_blocked(void) +{ + return (erts_smp_atomic_read(&schdlr_sspnd.msb.ongoing) + && erts_smp_atomic_read(&schdlr_sspnd.active) == 1); +} + +Eterm +erts_multi_scheduling_blockers(Process *p) +{ + Eterm res = NIL; + + erts_smp_mtx_lock(&schdlr_sspnd.mtx); + if (erts_is_multi_scheduling_blocked()) { + Eterm *hp, *hp_end; + ErtsProcList *plp1, *plp2; + Uint max_size; + ASSERT(schdlr_sspnd.msb.procs); + for (max_size = 0, plp1 = schdlr_sspnd.msb.procs; + plp1; + plp1 = plp1->next) { + max_size += 2; + } + ASSERT(max_size); + hp = HAlloc(p, max_size); + hp_end = hp + max_size; + for (plp1 = schdlr_sspnd.msb.procs; plp1; plp1 = plp1->next) { + for (plp2 = schdlr_sspnd.msb.procs; + plp2->pid != plp1->pid; + plp2 = plp2->next); + if (plp2 == plp1) { + res = CONS(hp, plp1->pid, res); + hp += 2; + } + /* else: already in result list */ + } + HRelease(p, hp_end, hp); + } + erts_smp_mtx_unlock(&schdlr_sspnd.mtx); + return res; +} + +static void * +sched_thread_func(void *vesdp) +{ +#ifdef ERTS_ENABLE_LOCK_CHECK + { + char buf[31]; + Uint no = ((ErtsSchedulerData *) vesdp)->no; + erts_snprintf(&buf[0], 31, "scheduler %bpu", no); + erts_lc_set_thread_name(&buf[0]); + } +#endif + erts_alloc_reg_scheduler_id(((ErtsSchedulerData *) vesdp)->no); + erts_tsd_set(sched_data_key, vesdp); +#ifdef ERTS_SMP + erts_proc_lock_prepare_proc_lock_waiter(); +#endif + erts_register_blockable_thread(); +#ifdef HIPE + hipe_thread_signal_init(); +#endif + erts_thread_init_float(); + erts_smp_mtx_lock(&schdlr_sspnd.mtx); + + ASSERT(schdlr_sspnd.changing == ERTS_SCHED_CHANGING_ONLINE); + + schdlr_sspnd.curr_online--; + + if (((ErtsSchedulerData *) vesdp)->no != 1) { + if (schdlr_sspnd.online == schdlr_sspnd.curr_online) { + schdlr_sspnd.changing = 0; + erts_smp_cnd_broadcast(&schdlr_sspnd.cnd); + } + } + else if (schdlr_sspnd.curr_online == schdlr_sspnd.wait_curr_online) + schdlr_sspnd.changing = 0; + else { + erts_smp_activity_begin(ERTS_ACTIVITY_WAIT, + susp_sched_prep_block, + susp_sched_resume_block, + NULL); + while (schdlr_sspnd.curr_online != schdlr_sspnd.wait_curr_online) + erts_smp_cnd_wait(&schdlr_sspnd.cnd, &schdlr_sspnd.mtx); + erts_smp_activity_end(ERTS_ACTIVITY_WAIT, + susp_sched_prep_block, + susp_sched_resume_block, + NULL); + ASSERT(!schdlr_sspnd.changing); + } + erts_smp_mtx_unlock(&schdlr_sspnd.mtx); + + process_main(); + /* No schedulers should *ever* terminate */ + erl_exit(ERTS_ABORT_EXIT, "Scheduler thread number %bpu terminated\n", + ((ErtsSchedulerData *) vesdp)->no); + return NULL; +} + +void +erts_start_schedulers(void) +{ + int res = 0; + Uint actual = 0; + Uint wanted = erts_no_schedulers; + Uint wanted_no_schedulers = erts_no_schedulers; + ethr_thr_opts opts = ETHR_THR_OPTS_DEFAULT_INITER; + + opts.detached = 1; + opts.suggested_stack_size = erts_sched_thread_suggested_stack_size; + + if (wanted < 1) + wanted = 1; + if (wanted > ERTS_MAX_NO_OF_SCHEDULERS) { + wanted = ERTS_MAX_NO_OF_SCHEDULERS; + res = ENOTSUP; + } + + erts_block_system(0); + + while (actual < wanted) { + ErtsSchedulerData *esdp = ERTS_SCHEDULER_IX(actual); + actual++; + ASSERT(actual == esdp->no); +#ifdef ERTS_ENABLE_LOCK_COUNT + res = erts_lcnt_thr_create(&esdp->tid,sched_thread_func,(void*)esdp,&opts); +#else + res = ethr_thr_create(&esdp->tid,sched_thread_func,(void*)esdp,&opts); +#endif + if (res != 0) { + actual--; + break; + } + } + + erts_no_schedulers = actual; + erts_release_system(); + + if (actual < 1) + erl_exit(1, + "Failed to create any scheduler-threads: %s (%d)\n", + erl_errno_id(res), + res); + if (res != 0) { + erts_dsprintf_buf_t *dsbufp = erts_create_logger_dsbuf(); + ASSERT(actual != wanted_no_schedulers); + erts_dsprintf(dsbufp, + "Failed to create %bpu scheduler-threads (%s:%d); " + "only %bpu scheduler-thread%s created.\n", + wanted_no_schedulers, erl_errno_id(res), res, + actual, actual == 1 ? " was" : "s were"); + erts_send_error_to_logger_nogl(dsbufp); + } +} + +#endif /* ERTS_SMP */ + +static int +int_cmp(const void *vx, const void *vy) +{ + return *((int *) vx) - *((int *) vy); +} + +static int +cpu_spread_order_cmp(const void *vx, const void *vy) +{ + erts_cpu_topology_t *x = (erts_cpu_topology_t *) vx; + erts_cpu_topology_t *y = (erts_cpu_topology_t *) vy; + + if (x->thread != y->thread) + return x->thread - y->thread; + if (x->core != y->core) + return x->core - y->core; + if (x->processor_node != y->processor_node) + return x->processor_node - y->processor_node; + if (x->processor != y->processor) + return x->processor - y->processor; + if (x->node != y->node) + return x->node - y->node; + return 0; +} + +static int +cpu_processor_spread_order_cmp(const void *vx, const void *vy) +{ + erts_cpu_topology_t *x = (erts_cpu_topology_t *) vx; + erts_cpu_topology_t *y = (erts_cpu_topology_t *) vy; + + if (x->thread != y->thread) + return x->thread - y->thread; + if (x->processor_node != y->processor_node) + return x->processor_node - y->processor_node; + if (x->core != y->core) + return x->core - y->core; + if (x->node != y->node) + return x->node - y->node; + if (x->processor != y->processor) + return x->processor - y->processor; + return 0; +} + +static int +cpu_thread_spread_order_cmp(const void *vx, const void *vy) +{ + erts_cpu_topology_t *x = (erts_cpu_topology_t *) vx; + erts_cpu_topology_t *y = (erts_cpu_topology_t *) vy; + + if (x->thread != y->thread) + return x->thread - y->thread; + if (x->node != y->node) + return x->node - y->node; + if (x->processor != y->processor) + return x->processor - y->processor; + if (x->processor_node != y->processor_node) + return x->processor_node - y->processor_node; + if (x->core != y->core) + return x->core - y->core; + return 0; +} + +static int +cpu_thread_no_node_processor_spread_order_cmp(const void *vx, const void *vy) +{ + erts_cpu_topology_t *x = (erts_cpu_topology_t *) vx; + erts_cpu_topology_t *y = (erts_cpu_topology_t *) vy; + + if (x->thread != y->thread) + return x->thread - y->thread; + if (x->node != y->node) + return x->node - y->node; + if (x->core != y->core) + return x->core - y->core; + if (x->processor != y->processor) + return x->processor - y->processor; + return 0; +} + +static int +cpu_no_node_processor_spread_order_cmp(const void *vx, const void *vy) +{ + erts_cpu_topology_t *x = (erts_cpu_topology_t *) vx; + erts_cpu_topology_t *y = (erts_cpu_topology_t *) vy; + + if (x->node != y->node) + return x->node - y->node; + if (x->thread != y->thread) + return x->thread - y->thread; + if (x->core != y->core) + return x->core - y->core; + if (x->processor != y->processor) + return x->processor - y->processor; + return 0; +} + +static int +cpu_no_node_thread_spread_order_cmp(const void *vx, const void *vy) +{ + erts_cpu_topology_t *x = (erts_cpu_topology_t *) vx; + erts_cpu_topology_t *y = (erts_cpu_topology_t *) vy; + + if (x->node != y->node) + return x->node - y->node; + if (x->thread != y->thread) + return x->thread - y->thread; + if (x->processor != y->processor) + return x->processor - y->processor; + if (x->core != y->core) + return x->core - y->core; + return 0; +} + +static int +cpu_no_spread_order_cmp(const void *vx, const void *vy) +{ + erts_cpu_topology_t *x = (erts_cpu_topology_t *) vx; + erts_cpu_topology_t *y = (erts_cpu_topology_t *) vy; + + if (x->node != y->node) + return x->node - y->node; + if (x->processor != y->processor) + return x->processor - y->processor; + if (x->processor_node != y->processor_node) + return x->processor_node - y->processor_node; + if (x->core != y->core) + return x->core - y->core; + if (x->thread != y->thread) + return x->thread - y->thread; + return 0; +} + +static ERTS_INLINE void +make_cpudata_id_seq(erts_cpu_topology_t *cpudata, int size, int no_node) +{ + int ix; + int node = -1; + int processor = -1; + int processor_node = -1; + int processor_node_node = -1; + int core = -1; + int thread = -1; + int old_node = -1; + int old_processor = -1; + int old_processor_node = -1; + int old_core = -1; + int old_thread = -1; + + for (ix = 0; ix < size; ix++) { + if (!no_node || cpudata[ix].node >= 0) { + if (old_node == cpudata[ix].node) + cpudata[ix].node = node; + else { + old_node = cpudata[ix].node; + old_processor = processor = -1; + if (!no_node) + old_processor_node = processor_node = -1; + old_core = core = -1; + old_thread = thread = -1; + if (no_node || cpudata[ix].node >= 0) + cpudata[ix].node = ++node; + } + } + if (old_processor == cpudata[ix].processor) + cpudata[ix].processor = processor; + else { + old_processor = cpudata[ix].processor; + if (!no_node) + processor_node_node = old_processor_node = processor_node = -1; + old_core = core = -1; + old_thread = thread = -1; + cpudata[ix].processor = ++processor; + } + if (no_node && cpudata[ix].processor_node < 0) + old_processor_node = -1; + else { + if (old_processor_node == cpudata[ix].processor_node) { + if (no_node) + cpudata[ix].node = cpudata[ix].processor_node = node; + else { + if (processor_node_node >= 0) + cpudata[ix].node = processor_node_node; + cpudata[ix].processor_node = processor_node; + } + } + else { + old_processor_node = cpudata[ix].processor_node; + old_core = core = -1; + old_thread = thread = -1; + if (no_node) + cpudata[ix].node = cpudata[ix].processor_node = ++node; + else { + cpudata[ix].node = processor_node_node = ++node; + cpudata[ix].processor_node = ++processor_node; + } + } + } + if (!no_node && cpudata[ix].processor_node < 0) + cpudata[ix].processor_node = 0; + if (old_core == cpudata[ix].core) + cpudata[ix].core = core; + else { + old_core = cpudata[ix].core; + old_thread = thread = -1; + cpudata[ix].core = ++core; + } + if (old_thread == cpudata[ix].thread) + cpudata[ix].thread = thread; + else + old_thread = cpudata[ix].thread = ++thread; + } +} + +static void +cpu_bind_order_sort(erts_cpu_topology_t *cpudata, + int size, + ErtsCpuBindOrder bind_order, + int mk_seq) +{ + if (size > 1) { + int no_node = 0; + int (*cmp_func)(const void *, const void *); + switch (bind_order) { + case ERTS_CPU_BIND_SPREAD: + cmp_func = cpu_spread_order_cmp; + break; + case ERTS_CPU_BIND_PROCESSOR_SPREAD: + cmp_func = cpu_processor_spread_order_cmp; + break; + case ERTS_CPU_BIND_THREAD_SPREAD: + cmp_func = cpu_thread_spread_order_cmp; + break; + case ERTS_CPU_BIND_THREAD_NO_NODE_PROCESSOR_SPREAD: + no_node = 1; + cmp_func = cpu_thread_no_node_processor_spread_order_cmp; + break; + case ERTS_CPU_BIND_NO_NODE_PROCESSOR_SPREAD: + no_node = 1; + cmp_func = cpu_no_node_processor_spread_order_cmp; + break; + case ERTS_CPU_BIND_NO_NODE_THREAD_SPREAD: + no_node = 1; + cmp_func = cpu_no_node_thread_spread_order_cmp; + break; + case ERTS_CPU_BIND_NO_SPREAD: + cmp_func = cpu_no_spread_order_cmp; + break; + default: + cmp_func = NULL; + erl_exit(ERTS_ABORT_EXIT, + "Bad cpu bind type: %d\n", + (int) cpu_bind_order); + break; + } + + if (mk_seq) + make_cpudata_id_seq(cpudata, size, no_node); + + qsort(cpudata, size, sizeof(erts_cpu_topology_t), cmp_func); + } +} + +static int +processor_order_cmp(const void *vx, const void *vy) +{ + erts_cpu_topology_t *x = (erts_cpu_topology_t *) vx; + erts_cpu_topology_t *y = (erts_cpu_topology_t *) vy; + + if (x->processor != y->processor) + return x->processor - y->processor; + if (x->node != y->node) + return x->node - y->node; + if (x->processor_node != y->processor_node) + return x->processor_node - y->processor_node; + if (x->core != y->core) + return x->core - y->core; + if (x->thread != y->thread) + return x->thread - y->thread; + return 0; +} + +static void +check_cpu_bind(ErtsSchedulerData *esdp) +{ + int res; + int cpu_id; + erts_smp_runq_unlock(esdp->run_queue); + erts_smp_rwmtx_rwlock(&erts_cpu_bind_rwmtx); + cpu_id = scheduler2cpu_map[esdp->no].bind_id; + if (cpu_id >= 0 && cpu_id != scheduler2cpu_map[esdp->no].bound_id) { + res = erts_bind_to_cpu(erts_cpuinfo, cpu_id); + if (res == 0) + esdp->cpu_id = scheduler2cpu_map[esdp->no].bound_id = cpu_id; + else { + erts_dsprintf_buf_t *dsbufp = erts_create_logger_dsbuf(); + erts_dsprintf(dsbufp, "Scheduler %d failed to bind to cpu %d: %s\n", + (int) esdp->no, cpu_id, erl_errno_id(-res)); + erts_send_error_to_logger_nogl(dsbufp); + if (scheduler2cpu_map[esdp->no].bound_id >= 0) + goto unbind; + } + } + else if (cpu_id < 0 && scheduler2cpu_map[esdp->no].bound_id >= 0) { + unbind: + /* Get rid of old binding */ + res = erts_unbind_from_cpu(erts_cpuinfo); + if (res == 0) + esdp->cpu_id = scheduler2cpu_map[esdp->no].bound_id = -1; + else { + erts_dsprintf_buf_t *dsbufp = erts_create_logger_dsbuf(); + erts_dsprintf(dsbufp, "Scheduler %d failed to unbind from cpu %d: %s\n", + (int) esdp->no, cpu_id, erl_errno_id(-res)); + erts_send_error_to_logger_nogl(dsbufp); + } + } + erts_smp_runq_lock(esdp->run_queue); +#ifdef ERTS_SMP + if (erts_common_run_queue) + erts_smp_atomic_set(&esdp->chk_cpu_bind, 0); + else { + esdp->run_queue->flags &= ~ERTS_RUNQ_FLG_CHK_CPU_BIND; + } +#endif + erts_smp_rwmtx_rwunlock(&erts_cpu_bind_rwmtx); + +} + +static void +signal_schedulers_bind_change(erts_cpu_topology_t *cpudata, int size) +{ + int s_ix = 1; + int cpu_ix; + + if (cpu_bind_order != ERTS_CPU_BIND_NONE) { + + cpu_bind_order_sort(cpudata, size, cpu_bind_order, 1); + + for (cpu_ix = 0; cpu_ix < size && cpu_ix < erts_no_schedulers; cpu_ix++) + if (erts_is_cpu_available(erts_cpuinfo, cpudata[cpu_ix].logical)) + scheduler2cpu_map[s_ix++].bind_id = cpudata[cpu_ix].logical; + } + + if (s_ix <= erts_no_schedulers) + for (; s_ix <= erts_no_schedulers; s_ix++) + scheduler2cpu_map[s_ix].bind_id = -1; + +#ifdef ERTS_SMP + if (erts_common_run_queue) { + for (s_ix = 0; s_ix < erts_no_schedulers; s_ix++) + erts_smp_atomic_set(&ERTS_SCHEDULER_IX(s_ix)->chk_cpu_bind, 1); + wake_all_schedulers(); + } + else { + ERTS_FOREACH_RUNQ(rq, + { + rq->flags |= ERTS_RUNQ_FLG_CHK_CPU_BIND; + wake_scheduler(rq, 0); + }); + } +#else + check_cpu_bind(erts_get_scheduler_data()); +#endif +} + +int +erts_init_scheduler_bind_type(char *how) +{ + if (erts_bind_to_cpu(erts_cpuinfo, -1) == -ENOTSUP) + return ERTS_INIT_SCHED_BIND_TYPE_NOT_SUPPORTED; + + if (!system_cpudata && !user_cpudata) + return ERTS_INIT_SCHED_BIND_TYPE_ERROR_NO_CPU_TOPOLOGY; + + if (sys_strcmp(how, "s") == 0) + cpu_bind_order = ERTS_CPU_BIND_SPREAD; + else if (sys_strcmp(how, "ps") == 0) + cpu_bind_order = ERTS_CPU_BIND_PROCESSOR_SPREAD; + else if (sys_strcmp(how, "ts") == 0) + cpu_bind_order = ERTS_CPU_BIND_THREAD_SPREAD; + else if (sys_strcmp(how, "db") == 0 + || sys_strcmp(how, "tnnps") == 0) + cpu_bind_order = ERTS_CPU_BIND_THREAD_NO_NODE_PROCESSOR_SPREAD; + else if (sys_strcmp(how, "nnps") == 0) + cpu_bind_order = ERTS_CPU_BIND_NO_NODE_PROCESSOR_SPREAD; + else if (sys_strcmp(how, "nnts") == 0) + cpu_bind_order = ERTS_CPU_BIND_NO_NODE_THREAD_SPREAD; + else if (sys_strcmp(how, "ns") == 0) + cpu_bind_order = ERTS_CPU_BIND_NO_SPREAD; + else if (sys_strcmp(how, "u") == 0) + cpu_bind_order = ERTS_CPU_BIND_NONE; + else + return ERTS_INIT_SCHED_BIND_TYPE_ERROR_NO_BAD_TYPE; + + return ERTS_INIT_SCHED_BIND_TYPE_SUCCESS; +} + +typedef struct { + int *id; + int used; + int size; +} ErtsCpuTopIdSeq; + +typedef struct { + ErtsCpuTopIdSeq logical; + ErtsCpuTopIdSeq thread; + ErtsCpuTopIdSeq core; + ErtsCpuTopIdSeq processor_node; + ErtsCpuTopIdSeq processor; + ErtsCpuTopIdSeq node; +} ErtsCpuTopEntry; + +static void +init_cpu_top_entry(ErtsCpuTopEntry *cte) +{ + int size = 10; + cte->logical.id = erts_alloc(ERTS_ALC_T_TMP_CPU_IDS, + sizeof(int)*size); + cte->logical.size = size; + cte->thread.id = erts_alloc(ERTS_ALC_T_TMP_CPU_IDS, + sizeof(int)*size); + cte->thread.size = size; + cte->core.id = erts_alloc(ERTS_ALC_T_TMP_CPU_IDS, + sizeof(int)*size); + cte->core.size = size; + cte->processor_node.id = erts_alloc(ERTS_ALC_T_TMP_CPU_IDS, + sizeof(int)*size); + cte->processor_node.size = size; + cte->processor.id = erts_alloc(ERTS_ALC_T_TMP_CPU_IDS, + sizeof(int)*size); + cte->processor.size = size; + cte->node.id = erts_alloc(ERTS_ALC_T_TMP_CPU_IDS, + sizeof(int)*size); + cte->node.size = size; +} + +static void +destroy_cpu_top_entry(ErtsCpuTopEntry *cte) +{ + erts_free(ERTS_ALC_T_TMP_CPU_IDS, cte->logical.id); + erts_free(ERTS_ALC_T_TMP_CPU_IDS, cte->thread.id); + erts_free(ERTS_ALC_T_TMP_CPU_IDS, cte->core.id); + erts_free(ERTS_ALC_T_TMP_CPU_IDS, cte->processor_node.id); + erts_free(ERTS_ALC_T_TMP_CPU_IDS, cte->processor.id); + erts_free(ERTS_ALC_T_TMP_CPU_IDS, cte->node.id); +} + +static int +get_cput_value_or_range(int *v, int *vr, char **str) +{ + long l; + char *c = *str; + errno = 0; + if (!isdigit((unsigned char)*c)) + return ERTS_INIT_CPU_TOPOLOGY_INVALID_ID; + l = strtol(c, &c, 10); + if (errno != 0 || l < 0 || ERTS_MAX_CPU_TOPOLOGY_ID < l) + return ERTS_INIT_CPU_TOPOLOGY_INVALID_ID; + *v = (int) l; + if (*c == '-') { + c++; + if (!isdigit((unsigned char)*c)) + return ERTS_INIT_CPU_TOPOLOGY_INVALID_ID_RANGE; + l = strtol(c, &c, 10); + if (errno != 0 || l < 0 || ERTS_MAX_CPU_TOPOLOGY_ID < l) + return ERTS_INIT_CPU_TOPOLOGY_INVALID_ID_RANGE; + *vr = (int) l; + } + *str = c; + return ERTS_INIT_CPU_TOPOLOGY_OK; +} + +static int +get_cput_id_seq(ErtsCpuTopIdSeq *idseq, char **str) +{ + int ix = 0; + int need_size = 0; + char *c = *str; + + while (1) { + int res; + int val; + int nids; + int val_range = -1; + res = get_cput_value_or_range(&val, &val_range, &c); + if (res != ERTS_INIT_CPU_TOPOLOGY_OK) + return res; + if (val_range < 0 || val_range == val) + nids = 1; + else { + if (val_range > val) + nids = val_range - val + 1; + else + nids = val - val_range + 1; + } + need_size += nids; + if (need_size > idseq->size) { + idseq->size = need_size + 10; + idseq->id = erts_realloc(ERTS_ALC_T_TMP_CPU_IDS, + idseq->id, + sizeof(int)*idseq->size); + } + if (nids == 1) + idseq->id[ix++] = val; + else if (val_range > val) { + for (; val <= val_range; val++) + idseq->id[ix++] = val; + } + else { + for (; val >= val_range; val--) + idseq->id[ix++] = val; + } + if (*c != ',') + break; + c++; + } + *str = c; + idseq->used = ix; + return ERTS_INIT_CPU_TOPOLOGY_OK; +} + +static int +get_cput_entry(ErtsCpuTopEntry *cput, char **str) +{ + int h; + char *c = *str; + + cput->logical.used = 0; + cput->thread.id[0] = 0; + cput->thread.used = 1; + cput->core.id[0] = 0; + cput->core.used = 1; + cput->processor_node.id[0] = -1; + cput->processor_node.used = 1; + cput->processor.id[0] = 0; + cput->processor.used = 1; + cput->node.id[0] = -1; + cput->node.used = 1; + + h = ERTS_TOPOLOGY_MAX_DEPTH; + while (*c != ':' && *c != '\0') { + int res; + ErtsCpuTopIdSeq *idseqp; + switch (*c++) { + case 'L': + if (h <= ERTS_TOPOLOGY_LOGICAL) + return ERTS_INIT_CPU_TOPOLOGY_INVALID_HIERARCHY; + idseqp = &cput->logical; + h = ERTS_TOPOLOGY_LOGICAL; + break; + case 't': + case 'T': + if (h <= ERTS_TOPOLOGY_THREAD) + return ERTS_INIT_CPU_TOPOLOGY_INVALID_HIERARCHY; + idseqp = &cput->thread; + h = ERTS_TOPOLOGY_THREAD; + break; + case 'c': + case 'C': + if (h <= ERTS_TOPOLOGY_CORE) + return ERTS_INIT_CPU_TOPOLOGY_INVALID_HIERARCHY; + idseqp = &cput->core; + h = ERTS_TOPOLOGY_CORE; + break; + case 'p': + case 'P': + if (h <= ERTS_TOPOLOGY_PROCESSOR) + return ERTS_INIT_CPU_TOPOLOGY_INVALID_HIERARCHY; + idseqp = &cput->processor; + h = ERTS_TOPOLOGY_PROCESSOR; + break; + case 'n': + case 'N': + if (h <= ERTS_TOPOLOGY_PROCESSOR) { + do_node: + if (h <= ERTS_TOPOLOGY_NODE) + return ERTS_INIT_CPU_TOPOLOGY_INVALID_HIERARCHY; + idseqp = &cput->node; + h = ERTS_TOPOLOGY_NODE; + } + else { + int p_node = 0; + char *p_chk = c; + while (*p_chk != '\0' && *p_chk != ':') { + if (*p_chk == 'p' || *p_chk == 'P') { + p_node = 1; + break; + } + p_chk++; + } + if (!p_node) + goto do_node; + if (h <= ERTS_TOPOLOGY_PROCESSOR_NODE) + return ERTS_INIT_CPU_TOPOLOGY_INVALID_HIERARCHY; + idseqp = &cput->processor_node; + h = ERTS_TOPOLOGY_PROCESSOR_NODE; + } + break; + default: + return ERTS_INIT_CPU_TOPOLOGY_INVALID_ID_TYPE; + } + res = get_cput_id_seq(idseqp, &c); + if (res != ERTS_INIT_CPU_TOPOLOGY_OK) + return res; + } + + if (cput->logical.used < 1) + return ERTS_INIT_CPU_TOPOLOGY_MISSING_LID; + + if (*c == ':') { + c++; + } + + if (cput->thread.used != 1 + && cput->thread.used != cput->logical.used) + return ERTS_INIT_CPU_TOPOLOGY_INVALID_ID_RANGE; + if (cput->core.used != 1 + && cput->core.used != cput->logical.used) + return ERTS_INIT_CPU_TOPOLOGY_INVALID_ID_RANGE; + if (cput->processor_node.used != 1 + && cput->processor_node.used != cput->logical.used) + return ERTS_INIT_CPU_TOPOLOGY_INVALID_ID_RANGE; + if (cput->processor.used != 1 + && cput->processor.used != cput->logical.used) + return ERTS_INIT_CPU_TOPOLOGY_INVALID_ID_RANGE; + if (cput->node.used != 1 + && cput->node.used != cput->logical.used) + return ERTS_INIT_CPU_TOPOLOGY_INVALID_ID_RANGE; + + *str = c; + return ERTS_INIT_CPU_TOPOLOGY_OK; +} + +static int +verify_topology(erts_cpu_topology_t *cpudata, int size) +{ + if (size > 0) { + int *logical; + int node, processor, no_nodes, i; + + /* Verify logical ids */ + logical = erts_alloc(ERTS_ALC_T_TMP, sizeof(int)*size); + + for (i = 0; i < user_cpudata_size; i++) + logical[i] = user_cpudata[i].logical; + + qsort(logical, user_cpudata_size, sizeof(int), int_cmp); + for (i = 0; i < user_cpudata_size-1; i++) { + if (logical[i] == logical[i+1]) { + erts_free(ERTS_ALC_T_TMP, logical); + return ERTS_INIT_CPU_TOPOLOGY_NOT_UNIQUE_LIDS; + } + } + + erts_free(ERTS_ALC_T_TMP, logical); + + qsort(cpudata, size, sizeof(erts_cpu_topology_t), processor_order_cmp); + + /* Verify unique entities */ + + for (i = 1; i < user_cpudata_size; i++) { + if (user_cpudata[i-1].processor == user_cpudata[i].processor + && user_cpudata[i-1].node == user_cpudata[i].node + && (user_cpudata[i-1].processor_node + == user_cpudata[i].processor_node) + && user_cpudata[i-1].core == user_cpudata[i].core + && user_cpudata[i-1].thread == user_cpudata[i].thread) { + return ERTS_INIT_CPU_TOPOLOGY_NOT_UNIQUE_ENTITIES; + } + } + + /* Verify numa nodes */ + node = cpudata[0].node; + processor = cpudata[0].processor; + no_nodes = cpudata[0].node < 0 && cpudata[0].processor_node < 0; + for (i = 1; i < size; i++) { + if (no_nodes) { + if (cpudata[i].node >= 0 || cpudata[i].processor_node >= 0) + return ERTS_INIT_CPU_TOPOLOGY_INVALID_NODES; + } + else { + if (cpudata[i].processor == processor && cpudata[i].node != node) + return ERTS_INIT_CPU_TOPOLOGY_INVALID_NODES; + node = cpudata[i].node; + processor = cpudata[i].processor; + if (node >= 0 && cpudata[i].processor_node >= 0) + return ERTS_INIT_CPU_TOPOLOGY_INVALID_NODES; + if (node < 0 && cpudata[i].processor_node < 0) + return ERTS_INIT_CPU_TOPOLOGY_INVALID_NODES; + } + } + } + + return ERTS_INIT_CPU_TOPOLOGY_OK; +} + +int +erts_init_cpu_topology(char *topology_str) +{ + ErtsCpuTopEntry cput; + int need_size; + char *c; + int ix; + int error = ERTS_INIT_CPU_TOPOLOGY_OK; + + if (user_cpudata) + erts_free(ERTS_ALC_T_CPUDATA, user_cpudata); + user_cpudata_size = 10; + + user_cpudata = erts_alloc(ERTS_ALC_T_CPUDATA, + (sizeof(erts_cpu_topology_t) + * user_cpudata_size)); + + init_cpu_top_entry(&cput); + + ix = 0; + need_size = 0; + + c = topology_str; + if (*c == '\0') { + error = ERTS_INIT_CPU_TOPOLOGY_MISSING; + goto fail; + } + do { + int r; + error = get_cput_entry(&cput, &c); + if (error != ERTS_INIT_CPU_TOPOLOGY_OK) + goto fail; + need_size += cput.logical.used; + if (user_cpudata_size < need_size) { + user_cpudata_size = need_size + 10; + user_cpudata = erts_realloc(ERTS_ALC_T_CPUDATA, + user_cpudata, + (sizeof(erts_cpu_topology_t) + * user_cpudata_size)); + } + + ASSERT(cput.thread.used == 1 + || cput.thread.used == cput.logical.used); + ASSERT(cput.core.used == 1 + || cput.core.used == cput.logical.used); + ASSERT(cput.processor_node.used == 1 + || cput.processor_node.used == cput.logical.used); + ASSERT(cput.processor.used == 1 + || cput.processor.used == cput.logical.used); + ASSERT(cput.node.used == 1 + || cput.node.used == cput.logical.used); + + for (r = 0; r < cput.logical.used; r++) { + user_cpudata[ix].logical = cput.logical.id[r]; + user_cpudata[ix].thread = + cput.thread.id[cput.thread.used == 1 ? 0 : r]; + user_cpudata[ix].core = + cput.core.id[cput.core.used == 1 ? 0 : r]; + user_cpudata[ix].processor_node = + cput.processor_node.id[cput.processor_node.used == 1 ? 0 : r]; + user_cpudata[ix].processor = + cput.processor.id[cput.processor.used == 1 ? 0 : r]; + user_cpudata[ix].node = + cput.node.id[cput.node.used == 1 ? 0 : r]; + ix++; + } + } while (*c != '\0'); + + if (user_cpudata_size != ix) { + user_cpudata_size = ix; + user_cpudata = erts_realloc(ERTS_ALC_T_CPUDATA, + user_cpudata, + (sizeof(erts_cpu_topology_t) + * user_cpudata_size)); + } + + error = verify_topology(user_cpudata, user_cpudata_size); + if (error == ERTS_INIT_CPU_TOPOLOGY_OK) { + destroy_cpu_top_entry(&cput); + return ERTS_INIT_CPU_TOPOLOGY_OK; + } + + fail: + if (user_cpudata) + erts_free(ERTS_ALC_T_CPUDATA, user_cpudata); + user_cpudata_size = 0; + destroy_cpu_top_entry(&cput); + return error; +} + +#define ERTS_GET_CPU_TOPOLOGY_ERROR -1 +#define ERTS_GET_USED_CPU_TOPOLOGY 0 +#define ERTS_GET_DETECTED_CPU_TOPOLOGY 1 +#define ERTS_GET_DEFINED_CPU_TOPOLOGY 2 + +static Eterm get_cpu_topology_term(Process *c_p, int type); + +Eterm +erts_set_cpu_topology(Process *c_p, Eterm term) +{ + erts_cpu_topology_t *cpudata = NULL; + int cpudata_size = 0; + Eterm res; + + erts_smp_rwmtx_rwlock(&erts_cpu_bind_rwmtx); + res = get_cpu_topology_term(c_p, ERTS_GET_USED_CPU_TOPOLOGY); + if (term == am_undefined) { + if (user_cpudata) + erts_free(ERTS_ALC_T_CPUDATA, user_cpudata); + user_cpudata = NULL; + user_cpudata_size = 0; + + if (cpu_bind_order != ERTS_CPU_BIND_NONE && system_cpudata) { + cpudata_size = system_cpudata_size; + cpudata = erts_alloc(ERTS_ALC_T_TMP, + (sizeof(erts_cpu_topology_t) + * cpudata_size)); + + sys_memcpy((void *) cpudata, + (void *) system_cpudata, + sizeof(erts_cpu_topology_t)*cpudata_size); + } + } + else if (is_not_list(term)) { + error: + res = THE_NON_VALUE; + goto done; + } + else { + Eterm list = term; + int ix = 0; + + cpudata_size = 100; + cpudata = erts_alloc(ERTS_ALC_T_TMP, + (sizeof(erts_cpu_topology_t) + * cpudata_size)); + + while (is_list(list)) { + Eterm *lp = list_val(list); + Eterm cpu = CAR(lp); + Eterm* tp; + Sint id; + + if (is_not_tuple(cpu)) + goto error; + + tp = tuple_val(cpu); + + if (arityval(tp[0]) != 7 || tp[1] != am_cpu) + goto error; + + if (ix >= cpudata_size) { + cpudata_size += 100; + cpudata = erts_realloc(ERTS_ALC_T_TMP, + cpudata, + (sizeof(erts_cpu_topology_t) + * cpudata_size)); + } + + id = signed_val(tp[2]); + if (id < -1 || ERTS_MAX_CPU_TOPOLOGY_ID < id) + goto error; + cpudata[ix].node = (int) id; + + id = signed_val(tp[3]); + if (id < -1 || ERTS_MAX_CPU_TOPOLOGY_ID < id) + goto error; + cpudata[ix].processor = (int) id; + + id = signed_val(tp[4]); + if (id < -1 || ERTS_MAX_CPU_TOPOLOGY_ID < id) + goto error; + cpudata[ix].processor_node = (int) id; + + id = signed_val(tp[5]); + if (id < -1 || ERTS_MAX_CPU_TOPOLOGY_ID < id) + goto error; + cpudata[ix].core = (int) id; + + id = signed_val(tp[6]); + if (id < -1 || ERTS_MAX_CPU_TOPOLOGY_ID < id) + goto error; + cpudata[ix].thread = (int) id; + + id = signed_val(tp[7]); + if (id < -1 || ERTS_MAX_CPU_TOPOLOGY_ID < id) + goto error; + cpudata[ix].logical = (int) id; + + list = CDR(lp); + ix++; + } + + if (is_not_nil(list)) + goto error; + + cpudata_size = ix; + + if (ERTS_INIT_CPU_TOPOLOGY_OK != verify_topology(cpudata, cpudata_size)) + goto error; + + if (user_cpudata_size != cpudata_size) { + if (user_cpudata) + erts_free(ERTS_ALC_T_CPUDATA, user_cpudata); + user_cpudata = erts_alloc(ERTS_ALC_T_CPUDATA, + sizeof(erts_cpu_topology_t)*cpudata_size); + user_cpudata_size = cpudata_size; + } + + sys_memcpy((void *) user_cpudata, + (void *) cpudata, + sizeof(erts_cpu_topology_t)*cpudata_size); + } + + signal_schedulers_bind_change(cpudata, cpudata_size); + + done: + erts_smp_rwmtx_rwunlock(&erts_cpu_bind_rwmtx); + + if (cpudata) + erts_free(ERTS_ALC_T_TMP, cpudata); + + return res; +} + +static Eterm +bound_schedulers_term(ErtsCpuBindOrder order) +{ + switch (order) { + case ERTS_CPU_BIND_SPREAD: { + ERTS_DECL_AM(spread); + return AM_spread; + } + case ERTS_CPU_BIND_PROCESSOR_SPREAD: { + ERTS_DECL_AM(processor_spread); + return AM_processor_spread; + } + case ERTS_CPU_BIND_THREAD_SPREAD: { + ERTS_DECL_AM(thread_spread); + return AM_thread_spread; + } + case ERTS_CPU_BIND_THREAD_NO_NODE_PROCESSOR_SPREAD: { + ERTS_DECL_AM(thread_no_node_processor_spread); + return AM_thread_no_node_processor_spread; + } + case ERTS_CPU_BIND_NO_NODE_PROCESSOR_SPREAD: { + ERTS_DECL_AM(no_node_processor_spread); + return AM_no_node_processor_spread; + } + case ERTS_CPU_BIND_NO_NODE_THREAD_SPREAD: { + ERTS_DECL_AM(no_node_thread_spread); + return AM_no_node_thread_spread; + } + case ERTS_CPU_BIND_NO_SPREAD: { + ERTS_DECL_AM(no_spread); + return AM_no_spread; + } + case ERTS_CPU_BIND_NONE: { + ERTS_DECL_AM(unbound); + return AM_unbound; + } + default: + ASSERT(0); + return THE_NON_VALUE; + } +} + +Eterm +erts_bound_schedulers_term(Process *c_p) +{ + ErtsCpuBindOrder order; + erts_smp_rwmtx_rlock(&erts_cpu_bind_rwmtx); + order = cpu_bind_order; + erts_smp_rwmtx_runlock(&erts_cpu_bind_rwmtx); + return bound_schedulers_term(order); +} + +static void +create_tmp_cpu_topology_copy(erts_cpu_topology_t **cpudata, int *cpudata_size) +{ + if (user_cpudata) { + *cpudata_size = user_cpudata_size; + *cpudata = erts_alloc(ERTS_ALC_T_TMP, + (sizeof(erts_cpu_topology_t) + * (*cpudata_size))); + sys_memcpy((void *) *cpudata, + (void *) user_cpudata, + sizeof(erts_cpu_topology_t)*(*cpudata_size)); + } + else if (system_cpudata) { + *cpudata_size = system_cpudata_size; + *cpudata = erts_alloc(ERTS_ALC_T_TMP, + (sizeof(erts_cpu_topology_t) + * (*cpudata_size))); + sys_memcpy((void *) *cpudata, + (void *) system_cpudata, + sizeof(erts_cpu_topology_t)*(*cpudata_size)); + } + else { + *cpudata = NULL; + *cpudata_size = 0; + } +} + +static void +destroy_tmp_cpu_topology_copy(erts_cpu_topology_t *cpudata) +{ + if (cpudata) + erts_free(ERTS_ALC_T_TMP, cpudata); +} + +Eterm +erts_bind_schedulers(Process *c_p, Eterm how) +{ + Eterm res; + erts_cpu_topology_t *cpudata; + int cpudata_size; + ErtsCpuBindOrder old_cpu_bind_order; + + erts_smp_rwmtx_rwlock(&erts_cpu_bind_rwmtx); + + if (erts_bind_to_cpu(erts_cpuinfo, -1) == -ENOTSUP) { + ERTS_BIF_PREP_ERROR(res, c_p, EXC_NOTSUP); + } + else { + + old_cpu_bind_order = cpu_bind_order; + + if (ERTS_IS_ATOM_STR("spread", how)) + cpu_bind_order = ERTS_CPU_BIND_SPREAD; + else if (ERTS_IS_ATOM_STR("processor_spread", how)) + cpu_bind_order = ERTS_CPU_BIND_PROCESSOR_SPREAD; + else if (ERTS_IS_ATOM_STR("thread_spread", how)) + cpu_bind_order = ERTS_CPU_BIND_THREAD_SPREAD; + else if (ERTS_IS_ATOM_STR("default_bind", how) + || ERTS_IS_ATOM_STR("thread_no_node_processor_spread", how)) + cpu_bind_order = ERTS_CPU_BIND_THREAD_NO_NODE_PROCESSOR_SPREAD; + else if (ERTS_IS_ATOM_STR("no_node_processor_spread", how)) + cpu_bind_order = ERTS_CPU_BIND_NO_NODE_PROCESSOR_SPREAD; + else if (ERTS_IS_ATOM_STR("no_node_thread_spread", how)) + cpu_bind_order = ERTS_CPU_BIND_NO_NODE_THREAD_SPREAD; + else if (ERTS_IS_ATOM_STR("no_spread", how)) + cpu_bind_order = ERTS_CPU_BIND_NO_SPREAD; + else if (ERTS_IS_ATOM_STR("unbound", how)) + cpu_bind_order = ERTS_CPU_BIND_NONE; + else { + cpu_bind_order = old_cpu_bind_order; + ERTS_BIF_PREP_ERROR(res, c_p, BADARG); + goto done; + } + + create_tmp_cpu_topology_copy(&cpudata, &cpudata_size); + + if (!cpudata) { + cpu_bind_order = old_cpu_bind_order; + ERTS_BIF_PREP_ERROR(res, c_p, BADARG); + goto done; + } + + signal_schedulers_bind_change(cpudata, cpudata_size); + + destroy_tmp_cpu_topology_copy(cpudata); + + res = bound_schedulers_term(old_cpu_bind_order); + } + + done: + + erts_smp_rwmtx_rwunlock(&erts_cpu_bind_rwmtx); + + return res; +} + +Eterm +erts_fake_scheduler_bindings(Process *p, Eterm how) +{ + ErtsCpuBindOrder fake_cpu_bind_order; + erts_cpu_topology_t *cpudata; + int cpudata_size; + Eterm res; + + if (ERTS_IS_ATOM_STR("spread", how)) + fake_cpu_bind_order = ERTS_CPU_BIND_SPREAD; + else if (ERTS_IS_ATOM_STR("processor_spread", how)) + fake_cpu_bind_order = ERTS_CPU_BIND_PROCESSOR_SPREAD; + else if (ERTS_IS_ATOM_STR("thread_spread", how)) + fake_cpu_bind_order = ERTS_CPU_BIND_THREAD_SPREAD; + else if (ERTS_IS_ATOM_STR("default_bind", how) + || ERTS_IS_ATOM_STR("thread_no_node_processor_spread", how)) + fake_cpu_bind_order = ERTS_CPU_BIND_THREAD_NO_NODE_PROCESSOR_SPREAD; + else if (ERTS_IS_ATOM_STR("no_node_processor_spread", how)) + fake_cpu_bind_order = ERTS_CPU_BIND_NO_NODE_PROCESSOR_SPREAD; + else if (ERTS_IS_ATOM_STR("no_node_thread_spread", how)) + fake_cpu_bind_order = ERTS_CPU_BIND_NO_NODE_THREAD_SPREAD; + else if (ERTS_IS_ATOM_STR("no_spread", how)) + fake_cpu_bind_order = ERTS_CPU_BIND_NO_SPREAD; + else if (ERTS_IS_ATOM_STR("unbound", how)) + fake_cpu_bind_order = ERTS_CPU_BIND_NONE; + else { + ERTS_BIF_PREP_ERROR(res, p, BADARG); + return res; + } + + erts_smp_rwmtx_rlock(&erts_cpu_bind_rwmtx); + create_tmp_cpu_topology_copy(&cpudata, &cpudata_size); + erts_smp_rwmtx_runlock(&erts_cpu_bind_rwmtx); + + if (!cpudata || fake_cpu_bind_order == ERTS_CPU_BIND_NONE) + ERTS_BIF_PREP_RET(res, am_false); + else { + int i; + Eterm *hp; + + cpu_bind_order_sort(cpudata, cpudata_size, fake_cpu_bind_order, 1); + +#ifdef ERTS_FAKE_SCHED_BIND_PRINT_SORTED_CPU_DATA + + erts_fprintf(stderr, "node: "); + for (i = 0; i < cpudata_size; i++) + erts_fprintf(stderr, " %2d", cpudata[i].node); + erts_fprintf(stderr, "\n"); + erts_fprintf(stderr, "processor: "); + for (i = 0; i < cpudata_size; i++) + erts_fprintf(stderr, " %2d", cpudata[i].processor); + erts_fprintf(stderr, "\n"); + if (fake_cpu_bind_order != ERTS_CPU_BIND_THREAD_NO_NODE_PROCESSOR_SPREAD + && fake_cpu_bind_order != ERTS_CPU_BIND_NO_NODE_PROCESSOR_SPREAD + && fake_cpu_bind_order != ERTS_CPU_BIND_NO_NODE_THREAD_SPREAD) { + erts_fprintf(stderr, "processor_node:"); + for (i = 0; i < cpudata_size; i++) + erts_fprintf(stderr, " %2d", cpudata[i].processor_node); + erts_fprintf(stderr, "\n"); + } + erts_fprintf(stderr, "core: "); + for (i = 0; i < cpudata_size; i++) + erts_fprintf(stderr, " %2d", cpudata[i].core); + erts_fprintf(stderr, "\n"); + erts_fprintf(stderr, "thread: "); + for (i = 0; i < cpudata_size; i++) + erts_fprintf(stderr, " %2d", cpudata[i].thread); + erts_fprintf(stderr, "\n"); + erts_fprintf(stderr, "logical: "); + for (i = 0; i < cpudata_size; i++) + erts_fprintf(stderr, " %2d", cpudata[i].logical); + erts_fprintf(stderr, "\n"); +#endif + + hp = HAlloc(p, cpudata_size+1); + ERTS_BIF_PREP_RET(res, make_tuple(hp)); + *hp++ = make_arityval((Uint) cpudata_size); + for (i = 0; i < cpudata_size; i++) + *hp++ = make_small((Uint) cpudata[i].logical); + } + + destroy_tmp_cpu_topology_copy(cpudata); + + return res; +} + +Eterm +erts_get_schedulers_binds(Process *c_p) +{ + int ix; + ERTS_DECL_AM(unbound); + Eterm *hp = HAlloc(c_p, erts_no_schedulers+1); + Eterm res = make_tuple(hp); + + *(hp++) = make_arityval(erts_no_schedulers); + erts_smp_rwmtx_rlock(&erts_cpu_bind_rwmtx); + for (ix = 1; ix <= erts_no_schedulers; ix++) + *(hp++) = (scheduler2cpu_map[ix].bound_id >= 0 + ? make_small(scheduler2cpu_map[ix].bound_id) + : AM_unbound); + erts_smp_rwmtx_runlock(&erts_cpu_bind_rwmtx); + return res; +} + +static Eterm +bld_topology_term(Eterm **hpp, + Uint *hszp, + erts_cpu_topology_t *cpudata, + int size) +{ + Eterm res = NIL; + int i; + + if (size == 0) + return am_undefined; + + for (i = size-1; i >= 0; i--) { + res = erts_bld_cons(hpp, + hszp, + erts_bld_tuple(hpp, + hszp, + 7, + am_cpu, + make_small(cpudata[i].node), + make_small(cpudata[i].processor), + make_small(cpudata[i].processor_node), + make_small(cpudata[i].core), + make_small(cpudata[i].thread), + make_small(cpudata[i].logical)), + res); + } + return res; +} + +static Eterm +get_cpu_topology_term(Process *c_p, int type) +{ +#ifdef DEBUG + Eterm *hp_end; +#endif + Eterm *hp; + Uint hsz; + Eterm res = THE_NON_VALUE; + erts_cpu_topology_t *cpudata = NULL; + int size = 0; + + switch (type) { + case ERTS_GET_USED_CPU_TOPOLOGY: + if (user_cpudata) + goto defined; + else + goto detected; + case ERTS_GET_DETECTED_CPU_TOPOLOGY: + detected: + if (!system_cpudata) + res = am_undefined; + else { + size = system_cpudata_size; + cpudata = erts_alloc(ERTS_ALC_T_TMP, + (sizeof(erts_cpu_topology_t) + * size)); + sys_memcpy((void *) cpudata, + (void *) system_cpudata, + sizeof(erts_cpu_topology_t)*size); + } + break; + case ERTS_GET_DEFINED_CPU_TOPOLOGY: + defined: + if (!user_cpudata) + res = am_undefined; + else { + size = user_cpudata_size; + cpudata = user_cpudata; + } + break; + default: + erl_exit(ERTS_ABORT_EXIT, "Bad cpu topology type: %d\n", type); + break; + } + + if (res == am_undefined) { + ASSERT(!cpudata); + return res; + } + + hsz = 0; + + bld_topology_term(NULL, &hsz, + cpudata, size); + + hp = HAlloc(c_p, hsz); + +#ifdef DEBUG + hp_end = hp + hsz; +#endif + + res = bld_topology_term(&hp, NULL, + cpudata, size); + + ASSERT(hp_end == hp); + + if (cpudata && cpudata != system_cpudata && cpudata != user_cpudata) + erts_free(ERTS_ALC_T_TMP, cpudata); + + return res; +} + +Eterm +erts_get_cpu_topology_term(Process *c_p, Eterm which) +{ + Eterm res; + int type; + erts_smp_rwmtx_rlock(&erts_cpu_bind_rwmtx); + if (ERTS_IS_ATOM_STR("used", which)) + type = ERTS_GET_USED_CPU_TOPOLOGY; + else if (ERTS_IS_ATOM_STR("detected", which)) + type = ERTS_GET_DETECTED_CPU_TOPOLOGY; + else if (ERTS_IS_ATOM_STR("defined", which)) + type = ERTS_GET_DEFINED_CPU_TOPOLOGY; + else + type = ERTS_GET_CPU_TOPOLOGY_ERROR; + if (type == ERTS_GET_CPU_TOPOLOGY_ERROR) + res = THE_NON_VALUE; + else + res = get_cpu_topology_term(c_p, type); + erts_smp_rwmtx_runlock(&erts_cpu_bind_rwmtx); + return res; +} + +static void +early_cpu_bind_init(void) +{ + user_cpudata = NULL; + user_cpudata_size = 0; + + system_cpudata_size = erts_get_cpu_topology_size(erts_cpuinfo); + system_cpudata = erts_alloc(ERTS_ALC_T_CPUDATA, + (sizeof(erts_cpu_topology_t) + * system_cpudata_size)); + + cpu_bind_order = ERTS_CPU_BIND_NONE; + + if (!erts_get_cpu_topology(erts_cpuinfo, system_cpudata) + || ERTS_INIT_CPU_TOPOLOGY_OK != verify_topology(system_cpudata, + system_cpudata_size)) { + erts_free(ERTS_ALC_T_CPUDATA, system_cpudata); + system_cpudata = NULL; + system_cpudata_size = 0; + } +} + +static void +late_cpu_bind_init(void) +{ + int ix; + + erts_smp_rwmtx_init(&erts_cpu_bind_rwmtx, "cpu_bind"); + + scheduler2cpu_map = erts_alloc(ERTS_ALC_T_CPUDATA, + (sizeof(ErtsCpuBindData) + * (erts_no_schedulers+1))); + for (ix = 1; ix <= erts_no_schedulers; ix++) { + scheduler2cpu_map[ix].bind_id = -1; + scheduler2cpu_map[ix].bound_id = -1; + } + + if (cpu_bind_order != ERTS_CPU_BIND_NONE) { + erts_cpu_topology_t *cpudata; + int cpudata_size; + create_tmp_cpu_topology_copy(&cpudata, &cpudata_size); + ASSERT(cpudata); + signal_schedulers_bind_change(cpudata, cpudata_size); + destroy_tmp_cpu_topology_copy(cpudata); + } +} + +#ifdef ERTS_SMP + +static void +add_pend_suspend(Process *suspendee, + Eterm originator_pid, + void (*handle_func)(Process *, + ErtsProcLocks, + int, + Eterm)) +{ + ErtsPendingSuspend *psp = erts_alloc(ERTS_ALC_T_PEND_SUSPEND, + sizeof(ErtsPendingSuspend)); + psp->next = NULL; +#ifdef DEBUG +#ifdef ARCH_64 + psp->end = (ErtsPendingSuspend *) 0xdeaddeaddeaddead; +#else + psp->end = (ErtsPendingSuspend *) 0xdeaddead; +#endif +#endif + psp->pid = originator_pid; + psp->handle_func = handle_func; + + if (suspendee->pending_suspenders) + suspendee->pending_suspenders->end->next = psp; + else + suspendee->pending_suspenders = psp; + suspendee->pending_suspenders->end = psp; +} + +static void +handle_pending_suspend(Process *p, ErtsProcLocks p_locks) +{ + ErtsPendingSuspend *psp; + int is_alive = !ERTS_PROC_IS_EXITING(p); + + ERTS_SMP_LC_ASSERT(p_locks & ERTS_PROC_LOCK_STATUS); + + /* + * New pending suspenders might appear while we are processing + * (since we may release the status lock on p while processing). + */ + while (p->pending_suspenders) { + psp = p->pending_suspenders; + p->pending_suspenders = NULL; + while (psp) { + ErtsPendingSuspend *free_psp; + (*psp->handle_func)(p, p_locks, is_alive, psp->pid); + free_psp = psp; + psp = psp->next; + erts_free(ERTS_ALC_T_PEND_SUSPEND, (void *) free_psp); + } + } + +} + +static ERTS_INLINE void +cancel_suspend_of_suspendee(Process *p, ErtsProcLocks p_locks) +{ + if (is_not_nil(p->suspendee)) { + Process *rp; + if (!(p_locks & ERTS_PROC_LOCK_STATUS)) + erts_smp_proc_lock(p, ERTS_PROC_LOCK_STATUS); + rp = erts_pid2proc(p, p_locks|ERTS_PROC_LOCK_STATUS, + p->suspendee, ERTS_PROC_LOCK_STATUS); + if (rp) { + erts_resume(rp, ERTS_PROC_LOCK_STATUS); + erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_STATUS); + } + if (!(p_locks & ERTS_PROC_LOCK_STATUS)) + erts_smp_proc_unlock(p, ERTS_PROC_LOCK_STATUS); + p->suspendee = NIL; + } +} + +static void +handle_pend_sync_suspend(Process *suspendee, + ErtsProcLocks suspendee_locks, + int suspendee_alive, + Eterm suspender_pid) +{ + Process *suspender; + + ERTS_SMP_LC_ASSERT(suspendee_locks & ERTS_PROC_LOCK_STATUS); + + suspender = erts_pid2proc(suspendee, + suspendee_locks, + suspender_pid, + ERTS_PROC_LOCK_STATUS); + if (suspender) { + ASSERT(is_nil(suspender->suspendee)); + if (suspendee_alive) { + ErtsRunQueue *rq = erts_get_runq_proc(suspendee); + erts_smp_runq_lock(rq); + suspend_process(rq, suspendee); + erts_smp_runq_unlock(rq); + suspender->suspendee = suspendee->id; + } + /* suspender is suspended waiting for suspendee to suspend; + resume suspender */ + resume_process(suspender); + erts_smp_proc_unlock(suspender, ERTS_PROC_LOCK_STATUS); + } +} + +/* + * Like erts_pid2proc() but: + * + * * At least ERTS_PROC_LOCK_MAIN have to be held on c_p. + * * At least ERTS_PROC_LOCK_MAIN have to be taken on pid. + * * It also waits for proc to be in a state != running and garbing. + * * If ERTS_PROC_LOCK_BUSY is returned, the calling process has to + * yield (ERTS_BIF_YIELD[0-3]()). c_p might in this case have been + * suspended. + */ + + +Process * +erts_pid2proc_not_running(Process *c_p, ErtsProcLocks c_p_locks, + Eterm pid, ErtsProcLocks pid_locks) +{ + Process *rp; + int unlock_c_p_status; + + ERTS_SMP_LC_ASSERT(c_p_locks == erts_proc_lc_my_proc_locks(c_p)); + + ERTS_SMP_LC_ASSERT(c_p_locks & ERTS_PROC_LOCK_MAIN); + ERTS_SMP_LC_ASSERT(pid_locks & (ERTS_PROC_LOCK_MAIN|ERTS_PROC_LOCK_STATUS)); + + if (c_p->id == pid) + return erts_pid2proc(c_p, c_p_locks, pid, pid_locks); + + if (c_p_locks & ERTS_PROC_LOCK_STATUS) + unlock_c_p_status = 0; + else { + unlock_c_p_status = 1; + erts_smp_proc_lock(c_p, ERTS_PROC_LOCK_STATUS); + } + + if (c_p->suspendee == pid) { + /* Process previously suspended by c_p (below)... */ + ErtsProcLocks rp_locks = pid_locks|ERTS_PROC_LOCK_STATUS; + rp = erts_pid2proc(c_p, c_p_locks|ERTS_PROC_LOCK_STATUS, pid, rp_locks); + c_p->suspendee = NIL; + ASSERT(c_p->flags & F_P2PNR_RESCHED); + c_p->flags &= ~F_P2PNR_RESCHED; + if (rp) + resume_process(rp); + } + else { + ErtsRunQueue *cp_rq, *rp_rq; + + rp = erts_pid2proc(c_p, c_p_locks|ERTS_PROC_LOCK_STATUS, + pid, ERTS_PROC_LOCK_STATUS); + + if (!rp) { + c_p->flags &= ~F_P2PNR_RESCHED; + goto done; + } + + ASSERT(!(c_p->flags & F_P2PNR_RESCHED)); + + cp_rq = erts_get_runq_proc(c_p); + rp_rq = erts_get_runq_proc(rp); + erts_smp_runqs_lock(cp_rq, rp_rq); + if (rp->runq_flags & ERTS_PROC_RUNQ_FLG_RUNNING) { + running: + /* Phiu... */ + + /* + * If we got pending suspenders and suspend ourselves waiting + * to suspend another process we might deadlock. + * In this case we have to yield, be suspended by + * someone else and then do it all over again. + */ + if (!c_p->pending_suspenders) { + /* Mark rp pending for suspend by c_p */ + add_pend_suspend(rp, c_p->id, handle_pend_sync_suspend); + ASSERT(is_nil(c_p->suspendee)); + + /* Suspend c_p; when rp is suspended c_p will be resumed. */ + suspend_process(cp_rq, c_p); + c_p->flags |= F_P2PNR_RESCHED; + } + /* Yield (caller is assumed to yield immediately in bif). */ + erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_STATUS); + rp = ERTS_PROC_LOCK_BUSY; + } + else { + ErtsProcLocks need_locks = pid_locks & ~ERTS_PROC_LOCK_STATUS; + if (need_locks && erts_smp_proc_trylock(rp, need_locks) == EBUSY) { + erts_smp_runqs_unlock(cp_rq, rp_rq); + erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_STATUS); + rp = erts_pid2proc(c_p, c_p_locks|ERTS_PROC_LOCK_STATUS, + pid, pid_locks|ERTS_PROC_LOCK_STATUS); + if (!rp) + goto done; + /* run-queues may have changed */ + cp_rq = erts_get_runq_proc(c_p); + rp_rq = erts_get_runq_proc(rp); + erts_smp_runqs_lock(cp_rq, rp_rq); + if (rp->runq_flags & ERTS_PROC_RUNQ_FLG_RUNNING) { + /* Ahh... */ + erts_smp_proc_unlock(rp, + pid_locks & ~ERTS_PROC_LOCK_STATUS); + goto running; + } + } + + /* rp is not running and we got the locks we want... */ + } + erts_smp_runqs_unlock(cp_rq, rp_rq); + } + + done: + if (rp && rp != ERTS_PROC_LOCK_BUSY && !(pid_locks & ERTS_PROC_LOCK_STATUS)) + erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_STATUS); + if (unlock_c_p_status) + erts_smp_proc_unlock(c_p, ERTS_PROC_LOCK_STATUS); + return rp; +} + +/* + * erts_pid2proc_nropt() is normally the same as + * erts_pid2proc_not_running(). However it is only + * to be used when 'not running' is a pure optimization, + * not a requirement. + */ + +Process * +erts_pid2proc_nropt(Process *c_p, ErtsProcLocks c_p_locks, + Eterm pid, ErtsProcLocks pid_locks) +{ + if (erts_disable_proc_not_running_opt) + return erts_pid2proc(c_p, c_p_locks, pid, pid_locks); + else + return erts_pid2proc_not_running(c_p, c_p_locks, pid, pid_locks); +} + +static ERTS_INLINE void +do_bif_suspend_process(ErtsSuspendMonitor *smon, + Process *suspendee, + ErtsRunQueue *locked_runq) +{ + ASSERT(suspendee); + ASSERT(!suspendee->is_exiting); + ERTS_SMP_LC_ASSERT(ERTS_PROC_LOCK_STATUS + & erts_proc_lc_my_proc_locks(suspendee)); + if (smon) { + if (!smon->active) { + ErtsRunQueue *rq; + + if (locked_runq) + rq = locked_runq; + else { + rq = erts_get_runq_proc(suspendee); + erts_smp_runq_lock(rq); + } + + suspend_process(rq, suspendee); + + if (!locked_runq) + erts_smp_runq_unlock(rq); + } + smon->active += smon->pending; + ASSERT(smon->active); + smon->pending = 0; + } + +} + +static void +handle_pend_bif_sync_suspend(Process *suspendee, + ErtsProcLocks suspendee_locks, + int suspendee_alive, + Eterm suspender_pid) +{ + Process *suspender; + + ERTS_SMP_LC_ASSERT(suspendee_locks & ERTS_PROC_LOCK_STATUS); + + suspender = erts_pid2proc(suspendee, + suspendee_locks, + suspender_pid, + ERTS_PROC_LOCK_LINK|ERTS_PROC_LOCK_STATUS); + if (suspender) { + ASSERT(is_nil(suspender->suspendee)); + if (!suspendee_alive) + erts_delete_suspend_monitor(&suspender->suspend_monitors, + suspendee->id); + else { + ErtsSuspendMonitor *smon; + smon = erts_lookup_suspend_monitor(suspender->suspend_monitors, + suspendee->id); + do_bif_suspend_process(smon, suspendee, NULL); + suspender->suspendee = suspendee->id; + } + /* suspender is suspended waiting for suspendee to suspend; + resume suspender */ + resume_process(suspender); + erts_smp_proc_unlock(suspender, + ERTS_PROC_LOCK_LINK|ERTS_PROC_LOCK_STATUS); + } +} + +static void +handle_pend_bif_async_suspend(Process *suspendee, + ErtsProcLocks suspendee_locks, + int suspendee_alive, + Eterm suspender_pid) +{ + + Process *suspender; + + ERTS_SMP_LC_ASSERT(suspendee_locks & ERTS_PROC_LOCK_STATUS); + + suspender = erts_pid2proc(suspendee, + suspendee_locks, + suspender_pid, + ERTS_PROC_LOCK_LINK); + if (suspender) { + ASSERT(is_nil(suspender->suspendee)); + if (!suspendee_alive) + erts_delete_suspend_monitor(&suspender->suspend_monitors, + suspendee->id); + else { + ErtsSuspendMonitor *smon; + smon = erts_lookup_suspend_monitor(suspender->suspend_monitors, + suspendee->id); + do_bif_suspend_process(smon, suspendee, NULL); + } + erts_smp_proc_unlock(suspender, ERTS_PROC_LOCK_LINK); + } +} + +#endif /* ERTS_SMP */ + +/* + * The erlang:suspend_process/2 BIF + */ + +BIF_RETTYPE +suspend_process_2(BIF_ALIST_2) +{ + Eterm res; + Process* suspendee = NULL; + ErtsSuspendMonitor *smon; + ErtsProcLocks xlocks = (ErtsProcLocks) 0; + + /* Options and default values: */ + int asynchronous = 0; + int unless_suspending = 0; + + + if (BIF_P->id == BIF_ARG_1) + goto badarg; /* We are not allowed to suspend ourselves */ + + if (is_not_nil(BIF_ARG_2)) { + /* Parse option list */ + Eterm arg = BIF_ARG_2; + + while (is_list(arg)) { + Eterm *lp = list_val(arg); + arg = CAR(lp); + switch (arg) { + case am_unless_suspending: + unless_suspending = 1; + break; + case am_asynchronous: + asynchronous = 1; + break; + default: + goto badarg; + } + arg = CDR(lp); + } + if (is_not_nil(arg)) + goto badarg; + } + + xlocks = ERTS_PROC_LOCK_LINK | (asynchronous + ? (ErtsProcLocks) 0 + : ERTS_PROC_LOCK_STATUS); + + erts_smp_proc_lock(BIF_P, xlocks); + + suspendee = erts_pid2proc(BIF_P, + ERTS_PROC_LOCK_MAIN|xlocks, + BIF_ARG_1, + ERTS_PROC_LOCK_STATUS); + if (!suspendee) + goto no_suspendee; + + smon = erts_add_or_lookup_suspend_monitor(&BIF_P->suspend_monitors, + BIF_ARG_1); +#ifndef ERTS_SMP /* no ERTS_SMP */ + + /* This is really a piece of cake without SMP support... */ + if (!smon->active) { + suspend_process(erts_common_run_queue, suspendee); + smon->active++; + res = am_true; + } + else if (unless_suspending) + res = am_false; + else if (smon->active == INT_MAX) + goto system_limit; + else { + smon->active++; + res = am_true; + } + +#else /* ERTS_SMP */ + + /* ... but a little trickier with SMP support ... */ + + if (asynchronous) { + /* --- Asynchronous suspend begin ---------------------------------- */ + + ERTS_SMP_LC_ASSERT(ERTS_PROC_LOCK_LINK + & erts_proc_lc_my_proc_locks(BIF_P)); + ERTS_SMP_LC_ASSERT(ERTS_PROC_LOCK_STATUS + == erts_proc_lc_my_proc_locks(suspendee)); + + if (smon->active) { + smon->active += smon->pending; + smon->pending = 0; + if (unless_suspending) + res = am_false; + else if (smon->active == INT_MAX) + goto system_limit; + else { + smon->active++; + res = am_true; + } + /* done */ + } + else { + /* We havn't got any active suspends on the suspendee */ + if (smon->pending && unless_suspending) + res = am_false; + else { + ErtsRunQueue *rq; + if (smon->pending == INT_MAX) + goto system_limit; + + smon->pending++; + rq = erts_get_runq_proc(suspendee); + erts_smp_runq_lock(rq); + + if (suspendee->runq_flags & ERTS_PROC_RUNQ_FLG_RUNNING) + add_pend_suspend(suspendee, + BIF_P->id, + handle_pend_bif_async_suspend); + else + do_bif_suspend_process(smon, suspendee, rq); + erts_smp_runq_unlock(rq); + + res = am_true; + } + /* done */ + } + /* --- Asynchronous suspend end ------------------------------------ */ + } + else /* if (!asynchronous) */ { + /* --- Synchronous suspend begin ----------------------------------- */ + + ERTS_SMP_LC_ASSERT(((ERTS_PROC_LOCK_LINK|ERTS_PROC_LOCK_STATUS) + & erts_proc_lc_my_proc_locks(BIF_P)) + == (ERTS_PROC_LOCK_LINK|ERTS_PROC_LOCK_STATUS)); + ERTS_SMP_LC_ASSERT(ERTS_PROC_LOCK_STATUS + == erts_proc_lc_my_proc_locks(suspendee)); + + if (BIF_P->suspendee == BIF_ARG_1) { + /* We are back after a yield and the suspendee + has been suspended on behalf of us. */ + ASSERT(smon->active >= 1); + BIF_P->suspendee = NIL; + res = (!unless_suspending || smon->active == 1 + ? am_true + : am_false); + /* done */ + } + else if (smon->active) { + if (unless_suspending) + res = am_false; + else { + smon->active++; + res = am_true; + } + /* done */ + } + else { + ErtsRunQueue *cp_rq, *s_rq; + /* We haven't got any active suspends on the suspendee */ + + /* + * If we have pending suspenders and suspend ourselves waiting + * to suspend another process, or suspend another process + * we might deadlock. In this case we have to yield, + * be suspended by someone else, and then do it all over again. + */ + if (BIF_P->pending_suspenders) + goto yield; + + if (!unless_suspending && smon->pending == INT_MAX) + goto system_limit; + if (!unless_suspending || smon->pending == 0) + smon->pending++; + + cp_rq = erts_get_runq_proc(BIF_P); + s_rq = erts_get_runq_proc(suspendee); + erts_smp_runqs_lock(cp_rq, s_rq); + if (!(suspendee->runq_flags & ERTS_PROC_RUNQ_FLG_RUNNING)) { + do_bif_suspend_process(smon, suspendee, s_rq); + erts_smp_runqs_unlock(cp_rq, s_rq); + res = (!unless_suspending || smon->active == 1 + ? am_true + : am_false); + /* done */ + } + else { + /* Mark suspendee pending for suspend by BIF_P */ + add_pend_suspend(suspendee, + BIF_P->id, + handle_pend_bif_sync_suspend); + + ASSERT(is_nil(BIF_P->suspendee)); + + /* + * Suspend BIF_P; when suspendee is suspended, BIF_P + * will be resumed and this BIF will be called again. + * This time with BIF_P->suspendee == BIF_ARG_1 (see + * above). + */ + suspend_process(cp_rq, BIF_P); + erts_smp_runqs_unlock(cp_rq, s_rq); + goto yield; + } + } + /* --- Synchronous suspend end ------------------------------------- */ + } + +#endif /* ERTS_SMP */ + + ASSERT(suspendee->status == P_SUSPENDED || (asynchronous && smon->pending)); + ASSERT(suspendee->status == P_SUSPENDED || !smon->active); + + erts_smp_proc_unlock(suspendee, ERTS_PROC_LOCK_STATUS); + erts_smp_proc_unlock(BIF_P, xlocks); + BIF_RET(res); + + system_limit: + ERTS_BIF_PREP_ERROR(res, BIF_P, SYSTEM_LIMIT); + goto do_return; + + no_suspendee: +#ifdef ERTS_SMP + BIF_P->suspendee = NIL; +#endif + erts_delete_suspend_monitor(&BIF_P->suspend_monitors, BIF_ARG_1); + + badarg: + ERTS_BIF_PREP_ERROR(res, BIF_P, BADARG); +#ifdef ERTS_SMP + goto do_return; + + yield: + ERTS_BIF_PREP_YIELD2(res, bif_export[BIF_suspend_process_2], + BIF_P, BIF_ARG_1, BIF_ARG_2); +#endif + + do_return: + if (suspendee) + erts_smp_proc_unlock(suspendee, ERTS_PROC_LOCK_STATUS); + if (xlocks) + erts_smp_proc_unlock(BIF_P, xlocks); + return res; + +} + + +/* + * The erlang:resume_process/1 BIF + */ + +BIF_RETTYPE +resume_process_1(BIF_ALIST_1) +{ + ErtsSuspendMonitor *smon; + Process *suspendee; + int is_active; + + if (BIF_P->id == BIF_ARG_1) + BIF_ERROR(BIF_P, BADARG); + + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_LINK); + smon = erts_lookup_suspend_monitor(BIF_P->suspend_monitors, BIF_ARG_1); + + if (!smon) { + /* No previous suspend or dead suspendee */ + goto error; + } + else if (smon->pending) { + smon->pending--; + ASSERT(smon->pending >= 0); + if (smon->active) { + smon->active += smon->pending; + smon->pending = 0; + } + is_active = smon->active; + } + else if (smon->active) { + smon->active--; + ASSERT(smon->pending >= 0); + is_active = 1; + } + else { + /* No previous suspend or dead suspendee */ + goto error; + } + + if (smon->active || smon->pending || !is_active) { + /* Leave the suspendee as it is; just verify that it is still alive */ + suspendee = erts_pid2proc(BIF_P, + ERTS_PROC_LOCK_MAIN|ERTS_PROC_LOCK_LINK, + BIF_ARG_1, + 0); + if (!suspendee) + goto no_suspendee; + + } + else { + /* Resume */ + suspendee = erts_pid2proc(BIF_P, + ERTS_PROC_LOCK_MAIN|ERTS_PROC_LOCK_LINK, + BIF_ARG_1, + ERTS_PROC_LOCK_STATUS); + if (!suspendee) + goto no_suspendee; + + ASSERT(suspendee->status == P_SUSPENDED + || (suspendee->status == P_GARBING + && suspendee->gcstatus == P_SUSPENDED)); + resume_process(suspendee); + + erts_smp_proc_unlock(suspendee, ERTS_PROC_LOCK_STATUS); + } + + if (!smon->active && !smon->pending) + erts_delete_suspend_monitor(&BIF_P->suspend_monitors, BIF_ARG_1); + + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_LINK); + + BIF_RET(am_true); + + no_suspendee: + /* cleanup */ + erts_delete_suspend_monitor(&BIF_P->suspend_monitors, BIF_ARG_1); + + error: + erts_smp_proc_unlock(BIF_P, ERTS_PROC_LOCK_LINK); + BIF_ERROR(BIF_P, BADARG); +} + +Uint +erts_run_queues_len(Uint *qlen) +{ + int i = 0; + Uint len = 0; + ERTS_ATOMIC_FOREACH_RUNQ(rq, + { + if (qlen) + qlen[i++] = rq->procs.len; + len += rq->procs.len; + } + ); + return len; +} + +#ifdef HARDDEBUG_RUNQS +static void +check_procs_runq(ErtsRunQueue *runq, Process *p_in_q, Process *p_not_in_q) +{ + int len[ERTS_NO_PROC_PRIO_LEVELS] = {0}; + int tot_len; + int prioq, prio; + int found_p_in_q; + Process *p, *prevp; + + found_p_in_q = 0; + for (prioq = 0; prioq < ERTS_NO_PROC_PRIO_LEVELS - 1; prioq++) { + prevp = NULL; + for (p = runq->procs.prio[prioq].first; p; p = p->next) { + ASSERT(p != p_not_in_q); + if (p == p_in_q) + found_p_in_q = 1; + switch (p->prio) { + case PRIORITY_MAX: + case PRIORITY_HIGH: + case PRIORITY_NORMAL: + ASSERT(prioq == p->prio); + break; + case PRIORITY_LOW: + ASSERT(prioq == PRIORITY_NORMAL); + break; + default: + ASSERT(!"Bad prio on process"); + } + len[p->prio]++; + ASSERT(prevp == p->prev); + if (p->prev) { + ASSERT(p->prev->next == p); + } + else { + ASSERT(runq->procs.prio[prioq].first == p); + } + if (p->next) { + ASSERT(p->next->prev == p); + } + else { + ASSERT(runq->procs.prio[prioq].last == p); + } + ASSERT(p->run_queue == runq); + prevp = p; + } + } + + ASSERT(!p_in_q || found_p_in_q); + + tot_len = 0; + for (prio = 0; prio < ERTS_NO_PROC_PRIO_LEVELS; prio++) { + ASSERT(len[prio] == runq->procs.prio_info[prio].len); + if (len[prio]) { + ASSERT(runq->flags & (1 << prio)); + } + else { + ASSERT(!(runq->flags & (1 << prio))); + } + tot_len += len[prio]; + } + ASSERT(runq->procs.len == tot_len); +} +# define ERTS_DBG_CHK_PROCS_RUNQ(RQ) check_procs_runq((RQ), NULL, NULL) +# define ERTS_DBG_CHK_PROCS_RUNQ_PROC(RQ, P) check_procs_runq((RQ), (P), NULL) +# define ERTS_DBG_CHK_PROCS_RUNQ_NOPROC(RQ, P) check_procs_runq((RQ), NULL, (P)) +#else +# define ERTS_DBG_CHK_PROCS_RUNQ(RQ) +# define ERTS_DBG_CHK_PROCS_RUNQ_PROC(RQ, P) +# define ERTS_DBG_CHK_PROCS_RUNQ_NOPROC(RQ, P) +#endif + + +static ERTS_INLINE void +enqueue_process(ErtsRunQueue *runq, Process *p) +{ + ErtsRunPrioQueue *rpq; + ErtsRunQueueInfo *rqi; + + ERTS_SMP_LC_ASSERT(erts_smp_lc_runq_is_locked(runq)); + ERTS_SMP_LC_ASSERT(ERTS_PROC_LOCK_STATUS & erts_proc_lc_my_proc_locks(p)); + + ASSERT(p->bound_runq || !(runq->flags & ERTS_RUNQ_FLG_SUSPENDED)); + + rqi = &runq->procs.prio_info[p->prio]; + rqi->len++; + if (rqi->max_len < rqi->len) + rqi->max_len = rqi->len; + + runq->procs.len++; + runq->len++; + if (runq->max_len < runq->len) + runq->max_len = runq->len; + + runq->flags |= (1 << p->prio); + + rpq = (p->prio == PRIORITY_LOW + ? &runq->procs.prio[PRIORITY_NORMAL] + : &runq->procs.prio[p->prio]); + + p->next = NULL; + p->prev = rpq->last; + if (rpq->last) + rpq->last->next = p; + else + rpq->first = p; + rpq->last = p; + + switch (p->status) { + case P_EXITING: + break; + case P_GARBING: + p->gcstatus = P_RUNABLE; + break; + default: + p->status = P_RUNABLE; + break; + } + +#ifdef ERTS_SMP + p->status_flags |= ERTS_PROC_SFLG_INRUNQ; +#endif + + ERTS_DBG_CHK_PROCS_RUNQ_PROC(runq, p); +} + + +static ERTS_INLINE int +dequeue_process(ErtsRunQueue *runq, Process *p) +{ + ErtsRunPrioQueue *rpq; + int res = 1; + + ERTS_SMP_LC_ASSERT(erts_smp_lc_runq_is_locked(runq)); + ERTS_SMP_LC_ASSERT(ERTS_PROC_LOCK_STATUS & erts_proc_lc_my_proc_locks(p)); + + ERTS_DBG_CHK_PROCS_RUNQ(runq); + + rpq = &runq->procs.prio[p->prio == PRIORITY_LOW ? PRIORITY_NORMAL : p->prio]; + if (p->prev) { + p->prev->next = p->next; + } + else if (rpq->first == p) { + rpq->first = p->next; + } + else { + res = 0; + } + if (p->next) { + p->next->prev = p->prev; + } + else if (rpq->last == p) { + rpq->last = p->prev; + } + else { + ASSERT(res == 0); + } + + if (res) { + + if (--runq->procs.prio_info[p->prio].len == 0) + runq->flags &= ~(1 << p->prio); + runq->procs.len--; + runq->len--; + +#ifdef ERTS_SMP + p->status_flags &= ~ERTS_PROC_SFLG_INRUNQ; +#endif + } + + ERTS_DBG_CHK_PROCS_RUNQ_NOPROC(runq, p); + return res; +} + +/* schedule a process */ +static ERTS_INLINE void +internal_add_to_runq(ErtsRunQueue *runq, Process *p) +{ + Uint32 prev_status = p->status; + ErtsRunQueue *add_runq; +#ifdef ERTS_SMP + + ERTS_SMP_LC_ASSERT(ERTS_PROC_LOCK_STATUS & erts_proc_lc_my_proc_locks(p)); + ERTS_SMP_LC_ASSERT(erts_smp_lc_runq_is_locked(runq)); + + if (p->status_flags & ERTS_PROC_SFLG_INRUNQ) + return; + else if (p->runq_flags & ERTS_PROC_RUNQ_FLG_RUNNING) { + ASSERT(p->status != P_SUSPENDED); + ERTS_DBG_CHK_PROCS_RUNQ_NOPROC(runq, p); + p->status_flags |= ERTS_PROC_SFLG_PENDADD2SCHEDQ; + return; + } + ASSERT(!p->scheduler_data); +#endif + + ERTS_DBG_CHK_PROCS_RUNQ_NOPROC(runq, p); +#ifndef ERTS_SMP + /* Never schedule a suspended process (ok in smp case) */ + ASSERT(p->status != P_SUSPENDED); + add_runq = runq; + +#else + ASSERT(!p->bound_runq || p->bound_runq == p->run_queue); + if (p->bound_runq) { + if (p->bound_runq == runq) + add_runq = runq; + else { + add_runq = p->bound_runq; + erts_smp_xrunq_lock(runq, add_runq); + } + } + else { + add_runq = erts_check_emigration_need(runq, p->prio); + if (!add_runq) + add_runq = runq; + else /* Process emigrated */ + p->run_queue = add_runq; + } +#endif + + /* Enqueue the process */ + enqueue_process(add_runq, p); + + if ((erts_system_profile_flags.runnable_procs) + && (prev_status == P_WAITING + || prev_status == P_SUSPENDED)) { + profile_runnable_proc(p, am_active); + } + + smp_notify_inc_runq(add_runq); + + if (add_runq != runq) + erts_smp_runq_unlock(add_runq); +} + + +void +erts_add_to_runq(Process *p) +{ + ErtsRunQueue *runq = erts_get_runq_proc(p); + erts_smp_runq_lock(runq); + internal_add_to_runq(runq, p); + erts_smp_runq_unlock(runq); +} + +/* Possibly remove a scheduled process we need to suspend */ + +static int +remove_proc_from_runq(ErtsRunQueue *rq, Process *p, int to_inactive) +{ + int res; + + ERTS_SMP_LC_ASSERT(ERTS_PROC_LOCK_STATUS & erts_proc_lc_my_proc_locks(p)); + +#ifdef ERTS_SMP + if (p->status_flags & ERTS_PROC_SFLG_PENDADD2SCHEDQ) { + p->status_flags &= ~ERTS_PROC_SFLG_PENDADD2SCHEDQ; + ASSERT(!remove_proc_from_runq(rq, p, 0)); + return 1; + } +#endif + + res = dequeue_process(rq, p); + + if (res && erts_system_profile_flags.runnable_procs && to_inactive) + profile_runnable_proc(p, am_inactive); + +#ifdef ERTS_SMP + ASSERT(!(p->status_flags & ERTS_PROC_SFLG_INRUNQ)); +#endif + + return res; +} + +#ifdef ERTS_SMP + +ErtsMigrateResult +erts_proc_migrate(Process *p, ErtsProcLocks *plcks, + ErtsRunQueue *from_rq, int *from_locked, + ErtsRunQueue *to_rq, int *to_locked) +{ + ERTS_SMP_LC_ASSERT(*plcks == erts_proc_lc_my_proc_locks(p)); + ERTS_SMP_LC_ASSERT((ERTS_PROC_LOCK_STATUS & *plcks) + || from_locked); + ERTS_SMP_LC_CHK_RUNQ_LOCK(from_rq, *from_locked); + ERTS_SMP_LC_CHK_RUNQ_LOCK(to_rq, *to_locked); + + ASSERT(!erts_common_run_queue); + + /* + * If we have the lock on the run queue to migrate to, + * check that it isn't suspended. If it is suspended, + * we will refuse to migrate to it anyway. + */ + if (*to_locked && (to_rq->flags & ERTS_RUNQ_FLG_SUSPENDED)) + return ERTS_MIGRATE_FAILED_RUNQ_SUSPENDED; + + /* We need status lock on process and locks on both run queues */ + + if (!(ERTS_PROC_LOCK_STATUS & *plcks)) { + if (erts_smp_proc_trylock(p, ERTS_PROC_LOCK_STATUS) == EBUSY) { + ErtsProcLocks lcks = *plcks; + Eterm pid = p->id; + Process *proc = *plcks ? p : NULL; + + if (*from_locked) { + *from_locked = 0; + erts_smp_runq_unlock(from_rq); + } + if (*to_locked) { + *to_locked = 0; + erts_smp_runq_unlock(to_rq); + } + + proc = erts_pid2proc_opt(proc, + lcks, + pid, + lcks|ERTS_PROC_LOCK_STATUS, + ERTS_P2P_FLG_ALLOW_OTHER_X); + if (!proc) { + *plcks = 0; + return ERTS_MIGRATE_FAILED_NOT_IN_RUNQ; + } + ASSERT(proc == p); + } + *plcks |= ERTS_PROC_LOCK_STATUS; + } + + ASSERT(!p->bound_runq); + + ERTS_SMP_LC_CHK_RUNQ_LOCK(from_rq, *from_locked); + ERTS_SMP_LC_CHK_RUNQ_LOCK(to_rq, *to_locked); + + if (p->run_queue != from_rq) + return ERTS_MIGRATE_FAILED_RUNQ_CHANGED; + + if (!*from_locked || !*to_locked) { + if (from_rq < to_rq) { + if (!*to_locked) { + if (!*from_locked) + erts_smp_runq_lock(from_rq); + erts_smp_runq_lock(to_rq); + } + else if (erts_smp_runq_trylock(from_rq) == EBUSY) { + erts_smp_runq_unlock(to_rq); + erts_smp_runq_lock(from_rq); + erts_smp_runq_lock(to_rq); + } + } + else { + if (!*from_locked) { + if (!*to_locked) + erts_smp_runq_lock(to_rq); + erts_smp_runq_lock(from_rq); + } + else if (erts_smp_runq_trylock(to_rq) == EBUSY) { + erts_smp_runq_unlock(from_rq); + erts_smp_runq_lock(to_rq); + erts_smp_runq_lock(from_rq); + } + } + *to_locked = *from_locked = 1; + } + + ERTS_SMP_LC_CHK_RUNQ_LOCK(from_rq, *from_locked); + ERTS_SMP_LC_CHK_RUNQ_LOCK(to_rq, *to_locked); + + /* Ok we now got all locks we need; do it... */ + + /* Refuse to migrate to a suspended run queue */ + if (to_rq->flags & ERTS_RUNQ_FLG_SUSPENDED) + return ERTS_MIGRATE_FAILED_RUNQ_SUSPENDED; + + if ((p->runq_flags & ERTS_PROC_RUNQ_FLG_RUNNING) + || !(p->status_flags & ERTS_PROC_SFLG_INRUNQ)) + return ERTS_MIGRATE_FAILED_NOT_IN_RUNQ; + + dequeue_process(from_rq, p); + p->run_queue = to_rq; + enqueue_process(to_rq, p); + + return ERTS_MIGRATE_SUCCESS; +} +#endif /* ERTS_SMP */ + +Eterm +erts_process_status(Process *c_p, ErtsProcLocks c_p_locks, + Process *rp, Eterm rpid) +{ + Eterm res = am_undefined; + Process *p; + + if (rp) { + ERTS_SMP_LC_ASSERT(ERTS_PROC_LOCK_STATUS + & erts_proc_lc_my_proc_locks(rp)); + p = rp; + } + else { + p = erts_pid2proc_opt(c_p, c_p_locks, + rpid, ERTS_PROC_LOCK_STATUS, + ERTS_P2P_FLG_ALLOW_OTHER_X); + } + + if (p) { + switch (p->status) { + case P_RUNABLE: + res = am_runnable; + break; + case P_WAITING: + res = am_waiting; + break; + case P_RUNNING: + res = am_running; + break; + case P_EXITING: + res = am_exiting; + break; + case P_GARBING: + res = am_garbage_collecting; + break; + case P_SUSPENDED: + res = am_suspended; + break; + case P_FREE: /* We cannot look up a process in P_FREE... */ + default: /* Not a valid status... */ + erl_exit(1, "Bad status (%b32u) found for process %T\n", + p->status, p->id); + break; + } + +#ifdef ERTS_SMP + if (!rp && (p != c_p || !(ERTS_PROC_LOCK_STATUS & c_p_locks))) + erts_smp_proc_unlock(p, ERTS_PROC_LOCK_STATUS); + } + else { + int i; + ErtsSchedulerData *esdp; + + if (erts_common_run_queue) + erts_smp_runq_lock(erts_common_run_queue); + + for (i = 0; i < erts_no_schedulers; i++) { + esdp = ERTS_SCHEDULER_IX(i); + if (!erts_common_run_queue) + erts_smp_runq_lock(esdp->run_queue); + if (esdp->free_process && esdp->free_process->id == rpid) { + res = am_free; + if (!erts_common_run_queue) + erts_smp_runq_unlock(esdp->run_queue); + break; + } + if (!erts_common_run_queue) + erts_smp_runq_unlock(esdp->run_queue); + } + + if (erts_common_run_queue) + erts_smp_runq_unlock(erts_common_run_queue); +#endif + + } + + return res; +} + +/* +** Suspend a process +** If we are to suspend on a port the busy_port is the thing +** otherwise busy_port is NIL +*/ + +void +erts_suspend(Process* process, ErtsProcLocks process_locks, Port *busy_port) +{ + ErtsRunQueue *rq; + + ERTS_SMP_LC_ASSERT(process_locks == erts_proc_lc_my_proc_locks(process)); + if (!(process_locks & ERTS_PROC_LOCK_STATUS)) + erts_smp_proc_lock(process, ERTS_PROC_LOCK_STATUS); + + rq = erts_get_runq_proc(process); + + erts_smp_runq_lock(rq); + + suspend_process(rq, process); + + erts_smp_runq_unlock(rq); + + if (busy_port) + erts_wake_process_later(busy_port, process); + + if (!(process_locks & ERTS_PROC_LOCK_STATUS)) + erts_smp_proc_unlock(process, ERTS_PROC_LOCK_STATUS); + +} + +void +erts_resume(Process* process, ErtsProcLocks process_locks) +{ + ERTS_SMP_LC_ASSERT(process_locks == erts_proc_lc_my_proc_locks(process)); + if (!(process_locks & ERTS_PROC_LOCK_STATUS)) + erts_smp_proc_lock(process, ERTS_PROC_LOCK_STATUS); + resume_process(process); + if (!(process_locks & ERTS_PROC_LOCK_STATUS)) + erts_smp_proc_unlock(process, ERTS_PROC_LOCK_STATUS); +} + +int +erts_resume_processes(ErtsProcList *plp) +{ + int nresumed = 0; + while (plp) { + Process *proc; + ErtsProcList *fplp; + ASSERT(is_internal_pid(plp->pid)); + proc = erts_pid2proc(NULL, 0, plp->pid, ERTS_PROC_LOCK_STATUS); + if (proc) { + if (proclist_same(plp, proc)) { + resume_process(proc); + nresumed++; + } + erts_smp_proc_unlock(proc, ERTS_PROC_LOCK_STATUS); + } + fplp = plp; + plp = plp->next; + proclist_destroy(fplp); + } + return nresumed; +} + +Eterm +erts_get_process_priority(Process *p) +{ + ErtsRunQueue *rq; + Eterm value; + ERTS_SMP_LC_ASSERT(ERTS_PROC_LOCK_STATUS & erts_proc_lc_my_proc_locks(p)); + rq = erts_get_runq_proc(p); + erts_smp_runq_lock(rq); + switch(p->prio) { + case PRIORITY_MAX: value = am_max; break; + case PRIORITY_HIGH: value = am_high; break; + case PRIORITY_NORMAL: value = am_normal; break; + case PRIORITY_LOW: value = am_low; break; + default: ASSERT(0); value = am_undefined; break; + } + erts_smp_runq_unlock(rq); + return value; +} + +Eterm +erts_set_process_priority(Process *p, Eterm new_value) +{ + ErtsRunQueue *rq; + Eterm old_value; + ERTS_SMP_LC_ASSERT(ERTS_PROC_LOCK_STATUS & erts_proc_lc_my_proc_locks(p)); + rq = erts_get_runq_proc(p); +#ifdef ERTS_SMP + ASSERT(!(p->status_flags & ERTS_PROC_SFLG_INRUNQ)); +#endif + erts_smp_runq_lock(rq); + switch(p->prio) { + case PRIORITY_MAX: old_value = am_max; break; + case PRIORITY_HIGH: old_value = am_high; break; + case PRIORITY_NORMAL: old_value = am_normal; break; + case PRIORITY_LOW: old_value = am_low; break; + default: ASSERT(0); old_value = am_undefined; break; + } + switch (new_value) { + case am_max: p->prio = PRIORITY_MAX; break; + case am_high: p->prio = PRIORITY_HIGH; break; + case am_normal: p->prio = PRIORITY_NORMAL; break; + case am_low: p->prio = PRIORITY_LOW; break; + default: old_value = THE_NON_VALUE; break; + } + erts_smp_runq_unlock(rq); + return old_value; +} + +#ifdef ERTS_SMP + +static ERTS_INLINE int +prepare_for_sys_schedule(void) +{ + while (!erts_port_task_have_outstanding_io_tasks() + && !erts_smp_atomic_xchg(&doing_sys_schedule, 1)) { + if (!erts_port_task_have_outstanding_io_tasks()) + return 1; + erts_smp_atomic_set(&doing_sys_schedule, 0); + } + return 0; +} + +#else + +static ERTS_INLINE int +prepare_for_sys_schedule(void) +{ + return !erts_port_task_have_outstanding_io_tasks(); +} + +#endif + +/* note that P_RUNNING is only set so that we don't try to remove +** running processes from the schedule queue if they exit - a running +** process not being in the schedule queue!! +** Schedule for up to INPUT_REDUCTIONS context switches, +** return 1 if more to do. +*/ + +/* + * schedule() is called from BEAM (process_main()) or HiPE + * (hipe_mode_switch()) when the current process is to be + * replaced by a new process. 'calls' is the number of reduction + * steps the current process consumed. + * schedule() returns the new process, and the new process' + * ->fcalls field is initialised with its allowable number of + * reduction steps. + * + * When no process is runnable, or when sufficiently many reduction + * steps have been made, schedule() calls erl_sys_schedule() to + * schedule system-level activities. + * + * We use the same queue for normal and low prio processes. + * We reschedule low prio processes a certain number of times + * so that normal processes get to run more frequently. + */ + +Process *schedule(Process *p, int calls) +{ + ErtsRunQueue *rq; + ErtsRunPrioQueue *rpq; + long dt; + ErtsSchedulerData *esdp; + int context_reds; + long fcalls; + int input_reductions; + int actual_reds; + int reds; + + if (ERTS_USE_MODIFIED_TIMING()) { + context_reds = ERTS_MODIFIED_TIMING_CONTEXT_REDS; + input_reductions = ERTS_MODIFIED_TIMING_INPUT_REDS; + } + else { + context_reds = CONTEXT_REDS; + input_reductions = INPUT_REDUCTIONS; + } + + ERTS_SMP_LC_ASSERT(!ERTS_LC_IS_BLOCKING); + + /* + * Clean up after the process being scheduled out. + */ + if (!p) { /* NULL in the very first schedule() call */ + esdp = erts_get_scheduler_data(); + rq = erts_get_runq_current(esdp); + ASSERT(esdp); + fcalls = erts_smp_atomic_read(&function_calls); + actual_reds = reds = 0; + erts_smp_runq_lock(rq); + } else { +#ifdef ERTS_SMP + ERTS_SMP_CHK_HAVE_ONLY_MAIN_PROC_LOCK(p); + esdp = p->scheduler_data; + ASSERT(esdp->current_process == p + || esdp->free_process == p); +#else + esdp = erts_scheduler_data; + ASSERT(esdp->current_process == p); +#endif + reds = actual_reds = calls - esdp->virtual_reds; + if (reds < ERTS_PROC_MIN_CONTEXT_SWITCH_REDS_COST) + reds = ERTS_PROC_MIN_CONTEXT_SWITCH_REDS_COST; + esdp->virtual_reds = 0; + + fcalls = erts_smp_atomic_addtest(&function_calls, reds); + ASSERT(esdp && esdp == erts_get_scheduler_data()); + + rq = erts_get_runq_current(esdp); + + p->reds += actual_reds; + + erts_smp_proc_lock(p, ERTS_PROC_LOCK_STATUS); + + if ((erts_system_profile_flags.runnable_procs) + && (p->status == P_WAITING)) { + profile_runnable_proc(p, am_inactive); + } + + if (IS_TRACED(p)) { + switch (p->status) { + case P_EXITING: + if (ARE_TRACE_FLAGS_ON(p, F_TRACE_SCHED_EXIT)) + trace_sched(p, am_out_exiting); + break; + case P_FREE: + if (ARE_TRACE_FLAGS_ON(p, F_TRACE_SCHED_EXIT)) + trace_sched(p, am_out_exited); + break; + default: + if (ARE_TRACE_FLAGS_ON(p, F_TRACE_SCHED)) + trace_sched(p, am_out); + else if (ARE_TRACE_FLAGS_ON(p, F_TRACE_SCHED_PROCS)) + trace_virtual_sched(p, am_out); + break; + } + } + +#ifdef ERTS_SMP + if (ERTS_PROC_PENDING_EXIT(p)) { + erts_handle_pending_exit(p, + ERTS_PROC_LOCK_MAIN|ERTS_PROC_LOCK_STATUS); + p->status_flags |= ERTS_PROC_SFLG_PENDADD2SCHEDQ; + } + + if (p->pending_suspenders) { + handle_pending_suspend(p, + ERTS_PROC_LOCK_MAIN|ERTS_PROC_LOCK_STATUS); + ASSERT(!(p->status_flags & ERTS_PROC_SFLG_PENDADD2SCHEDQ) + || p->status != P_SUSPENDED); + } +#endif + erts_smp_runq_lock(rq); + + ERTS_PROC_REDUCTIONS_EXECUTED(rq, p->prio, reds, actual_reds); + + esdp->current_process = NULL; +#ifdef ERTS_SMP + p->scheduler_data = NULL; + p->runq_flags &= ~ERTS_PROC_RUNQ_FLG_RUNNING; + p->status_flags &= ~ERTS_PROC_SFLG_RUNNING; + + if (p->status_flags & ERTS_PROC_SFLG_PENDADD2SCHEDQ) { + p->status_flags &= ~ERTS_PROC_SFLG_PENDADD2SCHEDQ; + internal_add_to_runq(rq, p); + } +#endif + + + if (p->status == P_FREE) { +#ifdef ERTS_SMP + ASSERT(esdp->free_process == p); + esdp->free_process = NULL; + erts_smp_proc_unlock(p, ERTS_PROC_LOCK_MAIN|ERTS_PROC_LOCK_STATUS); + erts_smp_proc_dec_refc(p); +#else + erts_free_proc(p); +#endif + } else { + erts_smp_proc_unlock(p, ERTS_PROC_LOCK_MAIN|ERTS_PROC_LOCK_STATUS); + } + +#ifdef ERTS_SMP + { + ErtsProcList *pnd_xtrs = rq->procs.pending_exiters; + rq->procs.pending_exiters = NULL; + + if (pnd_xtrs) { + erts_smp_runq_unlock(rq); + handle_pending_exiters(pnd_xtrs); + erts_smp_runq_lock(rq); + } + + } + ASSERT(!esdp->free_process); +#endif + ASSERT(!esdp->current_process); + + ERTS_SMP_CHK_NO_PROC_LOCKS; + + dt = do_time_read_and_reset(); + if (dt) { + erts_smp_runq_unlock(rq); + bump_timer(dt); + erts_smp_runq_lock(rq); + } + BM_STOP_TIMER(system); + + } + + ERTS_SMP_LC_ASSERT(!ERTS_LC_IS_BLOCKING); + check_activities_to_run: { + +#ifdef ERTS_SMP + + if (!(rq->flags & ERTS_RUNQ_FLG_SHARED_RUNQ) + && rq->check_balance_reds <= 0) { + check_balance(rq); + } + + ERTS_SMP_LC_ASSERT(!ERTS_LC_IS_BLOCKING); + ERTS_SMP_LC_ASSERT(erts_smp_lc_runq_is_locked(rq)); + + if (rq->flags & ERTS_RUNQ_FLGS_IMMIGRATE_QMASK) + immigrate(rq); + + continue_check_activities_to_run: + + if (rq->flags & (ERTS_RUNQ_FLG_SHARED_RUNQ + | ERTS_RUNQ_FLG_CHK_CPU_BIND + | ERTS_RUNQ_FLG_SUSPENDED)) { + if ((rq->flags & ERTS_RUNQ_FLG_SUSPENDED) + || erts_smp_atomic_read(&esdp->suspended)) { + suspend_scheduler(esdp); + } + if ((rq->flags & ERTS_RUNQ_FLG_CHK_CPU_BIND) + || erts_smp_atomic_read(&esdp->chk_cpu_bind)) { + check_cpu_bind(esdp); + } + } + +#ifdef ERTS_SMP_SCHEDULERS_NEED_TO_CHECK_CHILDREN + if (esdp->check_children) { + esdp->check_children = 0; + erts_smp_runq_unlock(rq); + erts_check_children(); + erts_smp_runq_lock(rq); + } +#endif + + erts_smp_chk_system_block(prepare_for_block, + resume_after_block, + (void *) rq); + + ERTS_SMP_LC_ASSERT(!ERTS_LC_IS_BLOCKING); + ERTS_SMP_LC_ASSERT(erts_smp_lc_runq_is_locked(rq)); + +#endif + + ASSERT(rq->len == rq->procs.len + rq->ports.info.len); + +#ifndef ERTS_SMP + + if (rq->len == 0 && !rq->misc.start) + goto do_sys_schedule; + +#else /* ERTS_SMP */ + if (rq->len == 0 && !rq->misc.start) { + ERTS_SMP_LC_ASSERT(erts_smp_lc_runq_is_locked(rq)); + + rq->wakeup_other = 0; + rq->wakeup_other_reds = 0; + + empty_runq(rq); + + if (rq->flags & (ERTS_RUNQ_FLG_SHARED_RUNQ + | ERTS_RUNQ_FLG_SUSPENDED)) { + if ((rq->flags & ERTS_RUNQ_FLG_SUSPENDED) + || erts_smp_atomic_read(&esdp->suspended)) { + non_empty_runq(rq); + goto continue_check_activities_to_run; + } + } + else if (!(rq->flags & ERTS_RUNQ_FLG_INACTIVE)) { + /* + * Check for ERTS_RUNQ_FLG_SUSPENDED has to be done + * after trying to steal a task. + */ + if (try_steal_task(rq) + || (rq->flags & ERTS_RUNQ_FLG_SUSPENDED)) { + non_empty_runq(rq); + goto continue_check_activities_to_run; + } + } + + if (prepare_for_sys_schedule()) { + erts_smp_atomic_set(&function_calls, 0); + fcalls = 0; + sched_sys_wait(esdp->no, rq); + erts_smp_atomic_set(&doing_sys_schedule, 0); + } + else { + /* If all schedulers are waiting, one of them *should* + be waiting in erl_sys_schedule() */ + sched_cnd_wait(esdp->no, rq); + } + + non_empty_runq(rq); + + goto check_activities_to_run; + } + else +#endif /* ERTS_SMP */ + if (fcalls > input_reductions && prepare_for_sys_schedule()) { + int runnable; + +#ifdef ERTS_SMP + runnable = 1; +#else + do_sys_schedule: + runnable = rq->len != 0; + if (!runnable) + sched_waiting_sys(esdp->no, rq); +#endif + + /* + * Schedule system-level activities. + */ + + erts_smp_atomic_set(&function_calls, 0); + fcalls = 0; + ASSERT(!erts_port_task_have_outstanding_io_tasks()); +#ifdef ERTS_SMP + /* erts_sys_schedule_interrupt(0); */ +#endif + erts_smp_runq_unlock(rq); + erl_sys_schedule(runnable); + dt = do_time_read_and_reset(); + if (dt) bump_timer(dt); +#ifdef ERTS_SMP + erts_smp_runq_lock(rq); + erts_smp_atomic_set(&doing_sys_schedule, 0); + goto continue_check_activities_to_run; +#else + if (!runnable) + sched_active_sys(esdp->no, rq); + goto check_activities_to_run; +#endif + } + + if (rq->misc.start) + exec_misc_ops(rq); + +#ifdef ERTS_SMP + { + int wo_reds = rq->wakeup_other_reds; + if (wo_reds) { + if (rq->len < 2) { + rq->wakeup_other -= ERTS_WAKEUP_OTHER_DEC*wo_reds; + if (rq->wakeup_other < 0) + rq->wakeup_other = 0; + } + else if (rq->wakeup_other < ERTS_WAKEUP_OTHER_LIMIT) + rq->wakeup_other += rq->len*wo_reds + ERTS_WAKEUP_OTHER_FIXED_INC; + else { + if (erts_common_run_queue) { + if (erts_common_run_queue->waiting) + wake_one_scheduler(); + } + else if (erts_smp_atomic_read(&no_empty_run_queues) != 0) { + wake_scheduler_on_empty_runq(rq); + rq->wakeup_other = 0; + } + rq->wakeup_other = 0; + } + } + rq->wakeup_other_reds = 0; + } +#endif + + /* + * Find a new port to run. + */ + + if (rq->ports.info.len) { + int have_outstanding_io; + have_outstanding_io = erts_port_task_execute(rq, &esdp->current_port); + if (have_outstanding_io && fcalls > 2*input_reductions) { + /* + * If we have performed more than 2*INPUT_REDUCTIONS since + * last call to erl_sys_schedule() and we still haven't + * handled all I/O tasks we stop running processes and + * focus completely on ports. + * + * One could argue that this is a strange behavior. The + * reason for doing it this way is that it is similar + * to the behavior before port tasks were introduced. + * We don't want to change the behavior too much, at + * least not at the time of writing. This behavior + * might change in the future. + * + * /rickard + */ + goto check_activities_to_run; + } + } + + /* + * Find a new process to run. + */ + pick_next_process: + + ERTS_DBG_CHK_PROCS_RUNQ(rq); + + switch (rq->flags & ERTS_RUNQ_FLGS_PROCS_QMASK) { + case MAX_BIT: + case MAX_BIT|HIGH_BIT: + case MAX_BIT|NORMAL_BIT: + case MAX_BIT|LOW_BIT: + case MAX_BIT|HIGH_BIT|NORMAL_BIT: + case MAX_BIT|HIGH_BIT|LOW_BIT: + case MAX_BIT|NORMAL_BIT|LOW_BIT: + case MAX_BIT|HIGH_BIT|NORMAL_BIT|LOW_BIT: + rpq = &rq->procs.prio[PRIORITY_MAX]; + break; + case HIGH_BIT: + case HIGH_BIT|NORMAL_BIT: + case HIGH_BIT|LOW_BIT: + case HIGH_BIT|NORMAL_BIT|LOW_BIT: + rpq = &rq->procs.prio[PRIORITY_HIGH]; + break; + case NORMAL_BIT: + rpq = &rq->procs.prio[PRIORITY_NORMAL]; + break; + case LOW_BIT: + rpq = &rq->procs.prio[PRIORITY_NORMAL]; + break; + case NORMAL_BIT|LOW_BIT: + rpq = &rq->procs.prio[PRIORITY_NORMAL]; + ASSERT(rpq->first != NULL); + p = rpq->first; + if (p->prio == PRIORITY_LOW) { + if (p == rpq->last || p->skipped >= RESCHEDULE_LOW-1) + p->skipped = 0; + else { + /* skip it */ + p->skipped++; + rpq->first = p->next; + rpq->first->prev = NULL; + rpq->last->next = p; + p->prev = rpq->last; + p->next = NULL; + rpq->last = p; + goto pick_next_process; + } + } + break; + case 0: /* No process at all */ + default: + ASSERT((rq->flags & ERTS_RUNQ_FLGS_PROCS_QMASK) == 0); + ASSERT(rq->procs.len == 0); + goto check_activities_to_run; + } + + BM_START_TIMER(system); + + /* + * Take the chosen process out of the queue. + */ + ASSERT(rpq->first); /* Wrong qmask in rq->flags? */ + p = rpq->first; +#ifdef ERTS_SMP + ERTS_SMP_LC_ASSERT(rq == p->run_queue); +#endif + rpq->first = p->next; + if (!rpq->first) + rpq->last = NULL; + else + rpq->first->prev = NULL; + + p->next = p->prev = NULL; + + if (--rq->procs.prio_info[p->prio].len == 0) + rq->flags &= ~(1 << p->prio); + ASSERT(rq->procs.len > 0); + rq->procs.len--; + ASSERT(rq->len > 0); + rq->len--; + + { + Uint32 ee_flgs = (ERTS_RUNQ_FLG_EVACUATE(p->prio) + | ERTS_RUNQ_FLG_EMIGRATE(p->prio)); + + if ((rq->flags & (ERTS_RUNQ_FLG_SUSPENDED|ee_flgs)) == ee_flgs) + ERTS_UNSET_RUNQ_FLG_EVACUATE(rq->flags, p->prio); + } + + ERTS_DBG_CHK_PROCS_RUNQ_NOPROC(rq, p); + + rq->procs.context_switches++; + + esdp->current_process = p; + +#ifdef ERTS_SMP + p->runq_flags |= ERTS_PROC_RUNQ_FLG_RUNNING; + erts_smp_runq_unlock(rq); + + ERTS_SMP_CHK_NO_PROC_LOCKS; + + erts_smp_proc_lock(p, ERTS_PROC_LOCK_MAIN|ERTS_PROC_LOCK_STATUS); + + if (erts_sched_stat.enabled) { + Uint old = ERTS_PROC_SCHED_ID(p, + (ERTS_PROC_LOCK_MAIN + | ERTS_PROC_LOCK_STATUS), + esdp->no); + int migrated = old && old != esdp->no; + + erts_smp_spin_lock(&erts_sched_stat.lock); + erts_sched_stat.prio[p->prio].total_executed++; + erts_sched_stat.prio[p->prio].executed++; + if (migrated) { + erts_sched_stat.prio[p->prio].total_migrated++; + erts_sched_stat.prio[p->prio].migrated++; + } + erts_smp_spin_unlock(&erts_sched_stat.lock); + } + + p->status_flags |= ERTS_PROC_SFLG_RUNNING; + p->status_flags &= ~ERTS_PROC_SFLG_INRUNQ; + if (ERTS_PROC_PENDING_EXIT(p)) { + erts_handle_pending_exit(p, + ERTS_PROC_LOCK_MAIN|ERTS_PROC_LOCK_STATUS); + } + ASSERT(!p->scheduler_data); + p->scheduler_data = esdp; + +#endif + ASSERT(p->status != P_SUSPENDED); /* Never run a suspended process */ + + ACTIVATE(p); + reds = context_reds; + + if (IS_TRACED(p)) { + switch (p->status) { + case P_EXITING: + if (ARE_TRACE_FLAGS_ON(p, F_TRACE_SCHED_EXIT)) + trace_sched(p, am_in_exiting); + break; + default: + if (ARE_TRACE_FLAGS_ON(p, F_TRACE_SCHED)) + trace_sched(p, am_in); + else if (ARE_TRACE_FLAGS_ON(p, F_TRACE_SCHED_PROCS)) + trace_virtual_sched(p, am_in); + break; + } + } + if (p->status != P_EXITING) + p->status = P_RUNNING; + + erts_smp_proc_unlock(p, ERTS_PROC_LOCK_STATUS); + +#ifdef ERTS_SMP + if (is_not_nil(p->tracer_proc)) + erts_check_my_tracer_proc(p); +#endif + + if ((FLAGS(p) & F_FORCE_GC) || (MSO(p).overhead >= BIN_VHEAP_SZ(p))) { + reds -= erts_garbage_collect(p, 0, p->arg_reg, p->arity); + if (reds < 0) { + reds = 1; + } + } + + p->fcalls = reds; + ASSERT(IS_ACTIVE(p)); + ERTS_SMP_CHK_HAVE_ONLY_MAIN_PROC_LOCK(p); + return p; + } +} + +void +erts_sched_stat_modify(int what) +{ + int ix; + switch (what) { + case ERTS_SCHED_STAT_MODIFY_ENABLE: + erts_smp_block_system(0); + erts_sched_stat.enabled = 1; + erts_smp_release_system(); + break; + case ERTS_SCHED_STAT_MODIFY_DISABLE: + erts_smp_block_system(0); + erts_sched_stat.enabled = 1; + erts_smp_release_system(); + break; + case ERTS_SCHED_STAT_MODIFY_CLEAR: + erts_smp_spin_lock(&erts_sched_stat.lock); + for (ix = 0; ix < ERTS_NO_PRIO_LEVELS; ix++) { + erts_sched_stat.prio[ix].total_executed = 0; + erts_sched_stat.prio[ix].executed = 0; + erts_sched_stat.prio[ix].total_migrated = 0; + erts_sched_stat.prio[ix].migrated = 0; + } + erts_smp_spin_unlock(&erts_sched_stat.lock); + break; + } +} + +Eterm +erts_sched_stat_term(Process *p, int total) +{ + Uint sz; + Uint *hp; + Eterm prio[ERTS_NO_PRIO_LEVELS]; + Uint executed[ERTS_NO_PRIO_LEVELS]; + Uint migrated[ERTS_NO_PRIO_LEVELS]; + + erts_smp_spin_lock(&erts_sched_stat.lock); + if (total) { + int i; + for (i = 0; i < ERTS_NO_PRIO_LEVELS; i++) { + prio[i] = erts_sched_stat.prio[i].name; + executed[i] = erts_sched_stat.prio[i].total_executed; + migrated[i] = erts_sched_stat.prio[i].total_migrated; + } + } + else { + int i; + for (i = 0; i < ERTS_NO_PRIO_LEVELS; i++) { + prio[i] = erts_sched_stat.prio[i].name; + executed[i] = erts_sched_stat.prio[i].executed; + erts_sched_stat.prio[i].executed = 0; + migrated[i] = erts_sched_stat.prio[i].migrated; + erts_sched_stat.prio[i].migrated = 0; + } + } + erts_smp_spin_unlock(&erts_sched_stat.lock); + + sz = 0; + (void) erts_bld_atom_2uint_3tup_list(NULL, &sz, ERTS_NO_PRIO_LEVELS, + prio, executed, migrated); + hp = HAlloc(p, sz); + return erts_bld_atom_2uint_3tup_list(&hp, NULL, ERTS_NO_PRIO_LEVELS, + prio, executed, migrated); +} + +/* + * Scheduling of misc stuff + */ + +void +erts_schedule_misc_op(void (*func)(void *), void *arg) +{ + ErtsRunQueue *rq = erts_get_runq_current(NULL); + ErtsMiscOpList *molp = misc_op_list_alloc(); + + erts_smp_runq_lock(rq); + + while (rq->misc.evac_runq) { + ErtsRunQueue *tmp_rq = rq->misc.evac_runq; + erts_smp_runq_unlock(rq); + rq = tmp_rq; + erts_smp_runq_lock(rq); + } + + ASSERT(!(rq->flags & ERTS_RUNQ_FLG_SUSPENDED)); + + molp->next = NULL; + molp->func = func; + molp->arg = arg; + if (rq->misc.end) + rq->misc.end->next = molp; + else + rq->misc.start = molp; + rq->misc.end = molp; + smp_notify_inc_runq(rq); + erts_smp_runq_unlock(rq); +} + +static void +exec_misc_ops(ErtsRunQueue *rq) +{ + int i; + ErtsMiscOpList *molp = rq->misc.start; + ErtsMiscOpList *tmp_molp = molp; + + for (i = 0; i < ERTS_MAX_MISC_OPS-1; i++) { + if (!tmp_molp) + goto mtq; + tmp_molp = tmp_molp->next; + } + + if (!tmp_molp) { + mtq: + rq->misc.start = NULL; + rq->misc.end = NULL; + } + else { + rq->misc.start = tmp_molp->next; + tmp_molp->next = NULL; + if (!rq->misc.start) + rq->misc.end = NULL; + } + + erts_smp_runq_unlock(rq); + + while (molp) { + tmp_molp = molp; + (*molp->func)(molp->arg); + molp = molp->next; + misc_op_list_free(tmp_molp); + } + + erts_smp_runq_lock(rq); +} + +Uint +erts_get_total_context_switches(void) +{ + Uint res = 0; + ERTS_ATOMIC_FOREACH_RUNQ(rq, res += rq->procs.context_switches); + return res; +} + +void +erts_get_total_reductions(Uint *redsp, Uint *diffp) +{ + Uint reds = 0; + ERTS_ATOMIC_FOREACH_RUNQ_X(rq, + + reds += rq->procs.reductions, + + if (redsp) *redsp = reds; + if (diffp) *diffp = reds - last_reductions; + last_reductions = reds); +} + +void +erts_get_exact_total_reductions(Process *c_p, Uint *redsp, Uint *diffp) +{ + Uint reds = erts_current_reductions(c_p, c_p); + int ix; + erts_smp_proc_unlock(c_p, ERTS_PROC_LOCK_MAIN); + /* + * Wait for other schedulers to schedule out their processes + * and update 'reductions'. + */ + erts_smp_block_system(0); + for (reds = 0, ix = 0; ix < erts_no_run_queues; ix++) + reds += ERTS_RUNQ_IX(ix)->procs.reductions; + if (redsp) + *redsp = reds; + if (diffp) + *diffp = reds - last_exact_reductions; + last_exact_reductions = reds; + erts_smp_release_system(); + erts_smp_proc_lock(c_p, ERTS_PROC_LOCK_MAIN); +} + +/* + * erts_test_next_pid() is only used for testing. + */ +Sint +erts_test_next_pid(int set, Uint next) +{ + Sint res; + Sint p_prev; + + + erts_smp_mtx_lock(&proc_tab_mtx); + + if (!set) { + res = p_next < 0 ? -1 : (p_serial << p_serial_shift | p_next); + } + else { + + p_serial = (Sint) ((next >> p_serial_shift) & p_serial_mask); + p_next = (Sint) (erts_process_tab_index_mask & next); + + if (p_next >= erts_max_processes) { + p_next = 0; + p_serial++; + p_serial &= p_serial_mask; + } + + p_prev = p_next; + + do { + if (!process_tab[p_next]) + break; + p_next++; + if(p_next >= erts_max_processes) { + p_next = 0; + p_serial++; + p_serial &= p_serial_mask; + } + } while (p_prev != p_next); + + res = process_tab[p_next] ? -1 : (p_serial << p_serial_shift | p_next); + + } + + erts_smp_mtx_unlock(&proc_tab_mtx); + + return res; + +} + +Uint erts_process_count(void) +{ + long res = erts_smp_atomic_read(&process_count); + ASSERT(res >= 0); + return (Uint) res; +} + +void +erts_free_proc(Process *p) +{ +#if defined(ERTS_ENABLE_LOCK_COUNT) && defined(ERTS_SMP) + erts_lcnt_proc_lock_destroy(p); +#endif + erts_free(ERTS_ALC_T_PROC, (void *) p); +} + + +/* +** Allocate process and find out where to place next process. +*/ +static Process* +alloc_process(void) +{ +#ifdef ERTS_SMP + erts_pix_lock_t *pix_lock; +#endif + Process* p; + int p_prev; + + erts_smp_mtx_lock(&proc_tab_mtx); + + if (p_next == -1) { + p = NULL; + goto error; /* Process table full! */ + } + + p = (Process*) erts_alloc_fnf(ERTS_ALC_T_PROC, sizeof(Process)); + if (!p) + goto error; /* ENOMEM */ + + p_last = p_next; + + erts_get_emu_time(&p->started); + +#ifdef ERTS_SMP + pix_lock = ERTS_PIX2PIXLOCK(p_next); + erts_pix_lock(pix_lock); +#endif + ASSERT(!process_tab[p_next]); + + process_tab[p_next] = p; + erts_smp_atomic_inc(&process_count); + p->id = make_internal_pid(p_serial << p_serial_shift | p_next); + if (p->id == ERTS_INVALID_PID) { + /* Do not use the invalid pid; change serial */ + p_serial++; + p_serial &= p_serial_mask; + p->id = make_internal_pid(p_serial << p_serial_shift | p_next); + ASSERT(p->id != ERTS_INVALID_PID); + } + ASSERT(internal_pid_serial(p->id) <= (erts_use_r9_pids_ports + ? ERTS_MAX_PID_R9_SERIAL + : ERTS_MAX_PID_SERIAL)); + +#ifdef ERTS_SMP + erts_proc_lock_init(p); /* All locks locked */ + erts_pix_unlock(pix_lock); +#endif + + p->rstatus = P_FREE; + p->rcount = 0; + + /* + * set p_next to the next available slot + */ + + p_prev = p_next; + + while (1) { + p_next++; + if(p_next >= erts_max_processes) { + p_serial++; + p_serial &= p_serial_mask; + p_next = 0; + } + + if (p_prev == p_next) { + p_next = -1; + break; /* Table full! */ + } + + if (!process_tab[p_next]) + break; /* found a free slot */ + } + + error: + + erts_smp_mtx_unlock(&proc_tab_mtx); + + return p; + +} + +Eterm +erl_create_process(Process* parent, /* Parent of process (default group leader). */ + Eterm mod, /* Tagged atom for module. */ + Eterm func, /* Tagged atom for function. */ + Eterm args, /* Arguments for function (must be well-formed list). */ + ErlSpawnOpts* so) /* Options for spawn. */ +{ + ErtsRunQueue *rq; + Process *p; + Sint arity; /* Number of arguments. */ +#ifndef HYBRID + Uint arg_size; /* Size of arguments. */ +#endif + Uint sz; /* Needed words on heap. */ + Uint heap_need; /* Size needed on heap. */ + Eterm res = THE_NON_VALUE; + +#ifdef ERTS_SMP + erts_smp_proc_lock(parent, ERTS_PROC_LOCKS_ALL_MINOR); +#endif + +#ifdef HYBRID + /* + * Copy the arguments to the global heap + * Since global GC might occur we want to do this before adding the + * new process to the process_tab. + */ + BM_SWAP_TIMER(system,copy); + LAZY_COPY(parent,args); + BM_SWAP_TIMER(copy,system); + heap_need = 0; +#endif /* HYBRID */ + /* + * Check for errors. + */ + + if (is_not_atom(mod) || is_not_atom(func) || ((arity = list_length(args)) < 0)) { + so->error_code = BADARG; + goto error; + } + p = alloc_process(); /* All proc locks are locked by this thread + on success */ + if (!p) { + erts_send_error_to_logger_str(parent->group_leader, + "Too many processes\n"); + so->error_code = SYSTEM_LIMIT; + goto error; + } + + processes_busy++; + BM_COUNT(processes_spawned); + +#ifndef HYBRID + BM_SWAP_TIMER(system,size); + arg_size = size_object(args); + BM_SWAP_TIMER(size,system); + heap_need = arg_size; +#endif + + p->flags = erts_default_process_flags; + + /* Scheduler queue mutex should be locked when changeing + * prio. In this case we don't have to lock it, since + * noone except us has access to the process. + */ + if (so->flags & SPO_USE_ARGS) { + p->min_heap_size = so->min_heap_size; + p->prio = so->priority; + p->max_gen_gcs = so->max_gen_gcs; + } else { + p->min_heap_size = H_MIN_SIZE; + p->prio = PRIORITY_NORMAL; + p->max_gen_gcs = (Uint16) erts_smp_atomic_read(&erts_max_gen_gcs); + } + p->skipped = 0; + ASSERT(p->min_heap_size == erts_next_heap_size(p->min_heap_size, 0)); + + p->initial[INITIAL_MOD] = mod; + p->initial[INITIAL_FUN] = func; + p->initial[INITIAL_ARI] = (Uint) arity; + + /* + * Must initialize binary lists here before copying binaries to process. + */ + p->off_heap.mso = NULL; +#ifndef HYBRID /* FIND ME! */ + p->off_heap.funs = NULL; +#endif + p->off_heap.externals = NULL; + p->off_heap.overhead = 0; + + heap_need += + IS_CONST(parent->group_leader) ? 0 : NC_HEAP_SIZE(parent->group_leader); + + if (heap_need < p->min_heap_size) { + sz = heap_need = p->min_heap_size; + } else { + sz = erts_next_heap_size(heap_need, 0); + } + +#ifdef HIPE + hipe_init_process(&p->hipe); +#ifdef ERTS_SMP + hipe_init_process_smp(&p->hipe_smp); +#endif +#endif + + p->heap = (Eterm *) ERTS_HEAP_ALLOC(ERTS_ALC_T_HEAP, sizeof(Eterm)*sz); + p->old_hend = p->old_htop = p->old_heap = NULL; + p->high_water = p->heap; +#ifdef INCREMENTAL + p->scan_top = p->high_water; +#endif + p->gen_gcs = 0; + p->stop = p->hend = p->heap + sz; + p->htop = p->heap; + p->heap_sz = sz; + p->catches = 0; + + p->bin_vheap_sz = H_MIN_SIZE; + p->bin_old_vheap_sz = H_MIN_SIZE; + p->bin_old_vheap = 0; + + /* No need to initialize p->fcalls. */ + + p->current = p->initial+INITIAL_MOD; + + p->i = (Eterm *) beam_apply; + p->cp = (Eterm *) beam_apply+1; + + p->arg_reg = p->def_arg_reg; + p->max_arg_reg = sizeof(p->def_arg_reg)/sizeof(p->def_arg_reg[0]); + p->arg_reg[0] = mod; + p->arg_reg[1] = func; + BM_STOP_TIMER(system); + BM_MESSAGE(args,p,parent); + BM_START_TIMER(system); +#ifdef HYBRID + p->arg_reg[2] = args; +#ifdef INCREMENTAL + p->active = 0; + if (ptr_val(args) >= inc_fromspc && ptr_val(args) < inc_fromend) + INC_ACTIVATE(p); +#endif +#else + BM_SWAP_TIMER(system,copy); + p->arg_reg[2] = copy_struct(args, arg_size, &p->htop, &p->off_heap); + BM_MESSAGE_COPIED(arg_size); + BM_SWAP_TIMER(copy,system); +#endif + p->arity = 3; + + p->fvalue = NIL; + p->freason = EXC_NULL; + p->ftrace = NIL; + p->reds = 0; + +#ifdef ERTS_SMP + p->u.ptimer = NULL; +#else + sys_memset(&p->u.tm, 0, sizeof(ErlTimer)); +#endif + + p->reg = NULL; + p->nlinks = NULL; + p->monitors = NULL; + p->nodes_monitors = NULL; + p->suspend_monitors = NULL; + + ASSERT(is_pid(parent->group_leader)); + + if (parent->group_leader == ERTS_INVALID_PID) + p->group_leader = p->id; + else { + /* Needs to be done after the heap has been set up */ + p->group_leader = + IS_CONST(parent->group_leader) + ? parent->group_leader + : STORE_NC(&p->htop, &p->off_heap.externals, parent->group_leader); + } + + erts_get_default_tracing(&p->trace_flags, &p->tracer_proc); + + p->msg.first = NULL; + p->msg.last = &p->msg.first; + p->msg.save = &p->msg.first; + p->msg.len = 0; +#ifdef ERTS_SMP + p->msg_inq.first = NULL; + p->msg_inq.last = &p->msg_inq.first; + p->msg_inq.len = 0; + p->bound_runq = NULL; +#endif + p->bif_timers = NULL; + p->mbuf = NULL; + p->mbuf_sz = 0; + p->psd = NULL; + p->dictionary = NULL; + p->seq_trace_lastcnt = 0; + p->seq_trace_clock = 0; + SEQ_TRACE_TOKEN(p) = NIL; + p->parent = parent->id == ERTS_INVALID_PID ? NIL : parent->id; + +#ifdef HYBRID + p->rrma = NULL; + p->rrsrc = NULL; + p->nrr = 0; + p->rrsz = 0; +#endif + + INIT_HOLE_CHECK(p); +#ifdef DEBUG + p->last_old_htop = NULL; +#endif + + if (IS_TRACED(parent)) { + if (parent->trace_flags & F_TRACE_SOS) { + p->trace_flags |= (parent->trace_flags & TRACEE_FLAGS); + p->tracer_proc = parent->tracer_proc; + } + if (ARE_TRACE_FLAGS_ON(parent, F_TRACE_PROCS)) { + trace_proc_spawn(parent, p->id, mod, func, args); + } + if (parent->trace_flags & F_TRACE_SOS1) { /* Overrides TRACE_CHILDREN */ + p->trace_flags |= (parent->trace_flags & TRACEE_FLAGS); + p->tracer_proc = parent->tracer_proc; + p->trace_flags &= ~(F_TRACE_SOS1 | F_TRACE_SOS); + parent->trace_flags &= ~(F_TRACE_SOS1 | F_TRACE_SOS); + } + } + + /* + * Check if this process should be initially linked to its parent. + */ + + if (so->flags & SPO_LINK) { +#ifdef DEBUG + int ret; +#endif + if (IS_TRACED_FL(parent, F_TRACE_PROCS)) { + trace_proc(parent, parent, am_link, p->id); + } + +#ifdef DEBUG + ret = erts_add_link(&(parent->nlinks), LINK_PID, p->id); + ASSERT(ret == 0); + ret = erts_add_link(&(p->nlinks), LINK_PID, parent->id); + ASSERT(ret == 0); +#else + erts_add_link(&(parent->nlinks), LINK_PID, p->id); + erts_add_link(&(p->nlinks), LINK_PID, parent->id); +#endif + + if (IS_TRACED(parent)) { + if (parent->trace_flags & (F_TRACE_SOL|F_TRACE_SOL1)) { + p->trace_flags |= (parent->trace_flags & TRACEE_FLAGS); + p->tracer_proc = parent->tracer_proc; /* maybe steal */ + + if (parent->trace_flags & F_TRACE_SOL1) { /* maybe override */ + p ->trace_flags &= ~(F_TRACE_SOL1 | F_TRACE_SOL); + parent->trace_flags &= ~(F_TRACE_SOL1 | F_TRACE_SOL); + } + } + } + } + + /* + * Test whether this process should be initially monitored by its parent. + */ + if (so->flags & SPO_MONITOR) { + Eterm mref; + + mref = erts_make_ref(parent); + erts_add_monitor(&(parent->monitors), MON_ORIGIN, mref, p->id, NIL); + erts_add_monitor(&(p->monitors), MON_TARGET, mref, parent->id, NIL); + so->mref = mref; + } + +#ifdef HYBRID + /* + * Add process to the array of active processes. + */ + ACTIVATE(p); + p->active_index = erts_num_active_procs++; + erts_active_procs[p->active_index] = p; +#endif + +#ifdef ERTS_SMP + p->scheduler_data = NULL; + p->is_exiting = 0; + p->status_flags = 0; + p->runq_flags = 0; + p->suspendee = NIL; + p->pending_suspenders = NULL; + p->pending_exit.reason = THE_NON_VALUE; + p->pending_exit.bp = NULL; +#endif + +#if !defined(NO_FPE_SIGNALS) + p->fp_exception = 0; +#endif + + /* + * Schedule process for execution. + */ + + if (!((so->flags & SPO_USE_ARGS) && so->scheduler)) + rq = erts_get_runq_proc(parent); + else { + int ix = so->scheduler-1; + ASSERT(0 <= ix && ix < erts_no_run_queues); + rq = ERTS_RUNQ_IX(ix); + p->bound_runq = rq; + } + + erts_smp_runq_lock(rq); + +#ifdef ERTS_SMP + p->run_queue = rq; +#endif + + p->status = P_WAITING; + internal_add_to_runq(rq, p); + + erts_smp_runq_unlock(rq); + + res = p->id; + erts_smp_proc_unlock(p, ERTS_PROC_LOCKS_ALL); + + VERBOSE(DEBUG_PROCESSES, ("Created a new process: %T\n",p->id)); + + error: + + erts_smp_proc_unlock(parent, ERTS_PROC_LOCKS_ALL_MINOR); + + return res; +} + +/* + * Initiates a pseudo process that can be used + * for arithmetic BIFs. + */ + +void erts_init_empty_process(Process *p) +{ + p->htop = NULL; + p->stop = NULL; + p->hend = NULL; + p->heap = NULL; + p->gen_gcs = 0; + p->max_gen_gcs = 0; + p->min_heap_size = 0; + p->status = P_RUNABLE; + p->gcstatus = P_RUNABLE; + p->rstatus = P_RUNABLE; + p->rcount = 0; + p->id = ERTS_INVALID_PID; + p->prio = PRIORITY_NORMAL; + p->reds = 0; + p->tracer_proc = NIL; + p->trace_flags = F_INITIAL_TRACE_FLAGS; + p->group_leader = ERTS_INVALID_PID; + p->flags = 0; + p->fvalue = NIL; + p->freason = EXC_NULL; + p->ftrace = NIL; + p->fcalls = 0; + + p->bin_vheap_sz=H_MIN_SIZE; + p->bin_old_vheap_sz=H_MIN_SIZE; + p->bin_old_vheap = 0; +#ifdef ERTS_SMP + p->u.ptimer = NULL; + p->bound_runq = NULL; +#else + memset(&(p->u.tm), 0, sizeof(ErlTimer)); +#endif + p->next = NULL; + p->off_heap.mso = NULL; +#ifndef HYBRID /* FIND ME! */ + p->off_heap.funs = NULL; +#endif + p->off_heap.externals = NULL; + p->off_heap.overhead = 0; + p->reg = NULL; + p->heap_sz = 0; + p->high_water = NULL; +#ifdef INCREMENTAL + p->scan_top = NULL; +#endif + p->old_hend = NULL; + p->old_htop = NULL; + p->old_heap = NULL; + p->mbuf = NULL; + p->mbuf_sz = 0; + p->psd = NULL; + p->monitors = NULL; + p->nlinks = NULL; /* List of links */ + p->nodes_monitors = NULL; + p->suspend_monitors = NULL; + p->msg.first = NULL; + p->msg.last = &p->msg.first; + p->msg.save = &p->msg.first; + p->msg.len = 0; + p->bif_timers = NULL; + p->dictionary = NULL; + p->seq_trace_clock = 0; + p->seq_trace_lastcnt = 0; + p->seq_trace_token = NIL; + p->initial[0] = 0; + p->initial[1] = 0; + p->initial[2] = 0; + p->catches = 0; + p->cp = NULL; + p->i = NULL; + p->current = NULL; + + /* + * Saved x registers. + */ + p->arity = 0; + p->arg_reg = NULL; + p->max_arg_reg = 0; + p->def_arg_reg[0] = 0; + p->def_arg_reg[1] = 0; + p->def_arg_reg[2] = 0; + p->def_arg_reg[3] = 0; + p->def_arg_reg[4] = 0; + p->def_arg_reg[5] = 0; + + p->parent = NIL; + p->started.tv_sec = 0; + p->started.tv_usec = 0; + +#ifdef HIPE + hipe_init_process(&p->hipe); +#ifdef ERTS_SMP + hipe_init_process_smp(&p->hipe_smp); +#endif +#endif + + ACTIVATE(p); + +#ifdef HYBRID + p->rrma = NULL; + p->rrsrc = NULL; + p->nrr = 0; + p->rrsz = 0; +#endif + INIT_HOLE_CHECK(p); +#ifdef DEBUG + p->last_old_htop = NULL; +#endif + + +#ifdef ERTS_SMP + p->scheduler_data = NULL; + p->is_exiting = 0; + p->status_flags = 0; + p->runq_flags = 0; + p->msg_inq.first = NULL; + p->msg_inq.last = &p->msg_inq.first; + p->msg_inq.len = 0; + p->suspendee = NIL; + p->pending_suspenders = NULL; + p->pending_exit.reason = THE_NON_VALUE; + p->pending_exit.bp = NULL; + erts_proc_lock_init(p); + erts_smp_proc_unlock(p, ERTS_PROC_LOCKS_ALL); + p->run_queue = ERTS_RUNQ_IX(0); +#endif + +#if !defined(NO_FPE_SIGNALS) + p->fp_exception = 0; +#endif + +} + +#ifdef DEBUG + +void +erts_debug_verify_clean_empty_process(Process* p) +{ + /* Things that erts_cleanup_empty_process() will *not* cleanup... */ + ASSERT(p->htop == NULL); + ASSERT(p->stop == NULL); + ASSERT(p->hend == NULL); + ASSERT(p->heap == NULL); + ASSERT(p->id == ERTS_INVALID_PID); + ASSERT(p->tracer_proc == NIL); + ASSERT(p->trace_flags == F_INITIAL_TRACE_FLAGS); + ASSERT(p->group_leader == ERTS_INVALID_PID); + ASSERT(p->next == NULL); + ASSERT(p->reg == NULL); + ASSERT(p->heap_sz == 0); + ASSERT(p->high_water == NULL); +#ifdef INCREMENTAL + ASSERT(p->scan_top == NULL); +#endif + ASSERT(p->old_hend == NULL); + ASSERT(p->old_htop == NULL); + ASSERT(p->old_heap == NULL); + + ASSERT(p->monitors == NULL); + ASSERT(p->nlinks == NULL); + ASSERT(p->nodes_monitors == NULL); + ASSERT(p->suspend_monitors == NULL); + ASSERT(p->msg.first == NULL); + ASSERT(p->msg.len == 0); + ASSERT(p->bif_timers == NULL); + ASSERT(p->dictionary == NULL); + ASSERT(p->catches == 0); + ASSERT(p->cp == NULL); + ASSERT(p->i == NULL); + ASSERT(p->current == NULL); + + ASSERT(p->parent == NIL); + +#ifdef ERTS_SMP + ASSERT(p->msg_inq.first == NULL); + ASSERT(p->msg_inq.len == 0); + ASSERT(p->suspendee == NIL); + ASSERT(p->pending_suspenders == NULL); + ASSERT(p->pending_exit.reason == THE_NON_VALUE); + ASSERT(p->pending_exit.bp == NULL); +#endif + + /* Thing that erts_cleanup_empty_process() cleans up */ + + ASSERT(p->off_heap.mso == NULL); +#ifndef HYBRID /* FIND ME! */ + ASSERT(p->off_heap.funs == NULL); +#endif + ASSERT(p->off_heap.externals == NULL); + ASSERT(p->off_heap.overhead == 0); + + ASSERT(p->mbuf == NULL); +} + +#endif + +void +erts_cleanup_empty_process(Process* p) +{ + ErlHeapFragment* mbufp; + + /* We only check fields that are known to be used... */ + + erts_cleanup_offheap(&p->off_heap); + p->off_heap.mso = NULL; +#ifndef HYBRID /* FIND ME! */ + p->off_heap.funs = NULL; +#endif + p->off_heap.externals = NULL; + p->off_heap.overhead = 0; + + mbufp = p->mbuf; + while (mbufp) { + ErlHeapFragment *next = mbufp->next; + free_message_buffer(mbufp); + mbufp = next; + } + p->mbuf = NULL; +#if defined(ERTS_ENABLE_LOCK_COUNT) && defined(ERTS_SMP) + erts_lcnt_proc_lock_destroy(p); +#endif +#ifdef DEBUG + erts_debug_verify_clean_empty_process(p); +#endif +} + +/* + * p must be the currently executing process. + */ +static void +delete_process(Process* p) +{ + ErlMessage* mp; + ErlHeapFragment* bp; + + VERBOSE(DEBUG_PROCESSES, ("Removing process: %T\n",p->id)); + + /* Cleanup psd */ + + if (p->psd) + erts_free(ERTS_ALC_T_PSD, p->psd); + + /* Clean binaries and funs */ + erts_cleanup_offheap(&p->off_heap); + + /* + * The mso list should not be used anymore, but if it is, make sure that + * we'll notice. + */ + p->off_heap.mso = (void *) 0x8DEFFACD; + + if (p->arg_reg != p->def_arg_reg) { + erts_free(ERTS_ALC_T_ARG_REG, p->arg_reg); + } + + /* + * Release heaps. Clobber contents in DEBUG build. + */ + + +#ifdef DEBUG + sys_memset(p->heap, DEBUG_BAD_BYTE, p->heap_sz*sizeof(Eterm)); +#endif + +#ifdef HIPE + hipe_delete_process(&p->hipe); +#endif + + ERTS_HEAP_FREE(ERTS_ALC_T_HEAP, (void*) p->heap, p->heap_sz*sizeof(Eterm)); + if (p->old_heap != NULL) { + +#ifdef DEBUG + sys_memset(p->old_heap, DEBUG_BAD_BYTE, + (p->old_hend-p->old_heap)*sizeof(Eterm)); +#endif + ERTS_HEAP_FREE(ERTS_ALC_T_OLD_HEAP, + p->old_heap, + (p->old_hend-p->old_heap)*sizeof(Eterm)); + } + + /* + * Free all pending message buffers. + */ + bp = p->mbuf; + while (bp != NULL) { + ErlHeapFragment* next_bp = bp->next; + free_message_buffer(bp); + bp = next_bp; + } + + erts_erase_dicts(p); + + /* free all pending messages */ + mp = p->msg.first; + while(mp != NULL) { + ErlMessage* next_mp = mp->next; + if (mp->data.attached) { + if (is_value(mp->m[0])) + free_message_buffer(mp->data.heap_frag); + else { + if (is_not_nil(mp->m[1])) { + ErlHeapFragment *heap_frag; + heap_frag = (ErlHeapFragment *) mp->data.dist_ext->ext_endp; + erts_cleanup_offheap(&heap_frag->off_heap); + } + erts_free_dist_ext_copy(mp->data.dist_ext); + } + } + free_message(mp); + mp = next_mp; + } + + ASSERT(!p->monitors); + ASSERT(!p->nlinks); + ASSERT(!p->nodes_monitors); + ASSERT(!p->suspend_monitors); + + p->fvalue = NIL; + +#ifdef HYBRID + erts_active_procs[p->active_index] = + erts_active_procs[--erts_num_active_procs]; + erts_active_procs[p->active_index]->active_index = p->active_index; +#ifdef INCREMENTAL + if (INC_IS_ACTIVE(p)) + INC_DEACTIVATE(p); +#endif + + if (p->rrma != NULL) { + erts_free(ERTS_ALC_T_ROOTSET,p->rrma); + erts_free(ERTS_ALC_T_ROOTSET,p->rrsrc); + } +#endif + +} + +static ERTS_INLINE void +set_proc_exiting(Process *p, Eterm reason, ErlHeapFragment *bp) +{ +#ifdef ERTS_SMP + erts_pix_lock_t *pix_lock = ERTS_PID2PIXLOCK(p->id); + ERTS_SMP_LC_ASSERT(erts_proc_lc_my_proc_locks(p) == ERTS_PROC_LOCKS_ALL); + /* + * You are required to have all proc locks and the pix lock when going + * to status P_EXITING. This makes it is enough to take any lock when + * looking up a process (pid2proc()) to prevent the looked up process + * from exiting until the lock has been released. + */ + + erts_pix_lock(pix_lock); + p->is_exiting = 1; +#endif + p->status = P_EXITING; +#ifdef ERTS_SMP + erts_pix_unlock(pix_lock); +#endif + p->fvalue = reason; + if (bp) + erts_link_mbuf_to_proc(p, bp); + /* + * We used to set freason to EXC_EXIT here, but there is no need to + * save the stack trace since this process irreversibly is going to + * exit. + */ + p->freason = EXTAG_EXIT; + KILL_CATCHES(p); + cancel_timer(p); + p->i = (Eterm *) beam_exit; +} + + +#ifdef ERTS_SMP + +void +erts_handle_pending_exit(Process *c_p, ErtsProcLocks locks) +{ + ErtsProcLocks xlocks; + ASSERT(is_value(c_p->pending_exit.reason)); + ERTS_SMP_LC_ASSERT(erts_proc_lc_my_proc_locks(c_p) == locks); + ERTS_SMP_LC_ASSERT(locks & ERTS_PROC_LOCK_MAIN); + ERTS_SMP_LC_ASSERT(c_p->status != P_EXITING); + ERTS_SMP_LC_ASSERT(c_p->status != P_FREE); + + /* Ensure that all locks on c_p are locked before proceeding... */ + if (locks == ERTS_PROC_LOCKS_ALL) + xlocks = 0; + else { + xlocks = ~locks & ERTS_PROC_LOCKS_ALL; + if (erts_smp_proc_trylock(c_p, xlocks) == EBUSY) { + erts_smp_proc_unlock(c_p, locks & ~ERTS_PROC_LOCK_MAIN); + erts_smp_proc_lock(c_p, ERTS_PROC_LOCKS_ALL_MINOR); + } + } + + set_proc_exiting(c_p, c_p->pending_exit.reason, c_p->pending_exit.bp); + c_p->pending_exit.reason = THE_NON_VALUE; + c_p->pending_exit.bp = NULL; + + if (xlocks) + erts_smp_proc_unlock(c_p, xlocks); +} + +static void +handle_pending_exiters(ErtsProcList *pnd_xtrs) +{ + ErtsProcList *plp = pnd_xtrs; + ErtsProcList *free_plp; + while (plp) { + Process *p = erts_pid2proc(NULL, 0, plp->pid, ERTS_PROC_LOCKS_ALL); + if (p) { + if (proclist_same(plp, p) + && !(p->status_flags & ERTS_PROC_SFLG_RUNNING)) { + ASSERT(p->status_flags & ERTS_PROC_SFLG_INRUNQ); + ASSERT(ERTS_PROC_PENDING_EXIT(p)); + erts_handle_pending_exit(p, ERTS_PROC_LOCKS_ALL); + } + erts_smp_proc_unlock(p, ERTS_PROC_LOCKS_ALL); + } + free_plp = plp; + plp = plp->next; + proclist_destroy(free_plp); + } +} + +static void +save_pending_exiter(Process *p) +{ + ErtsProcList *plp; + ErtsRunQueue *rq; + + ERTS_SMP_LC_ASSERT(ERTS_PROC_LOCK_STATUS & erts_proc_lc_my_proc_locks(p)); + + rq = erts_get_runq_current(NULL); + + plp = proclist_create(p); + + erts_smp_runq_lock(rq); + + plp->next = rq->procs.pending_exiters; + rq->procs.pending_exiters = plp; + + erts_smp_runq_unlock(rq); + +} + +#endif + +/* + * This function delivers an EXIT message to a process + * which is trapping EXITs. + */ + +static ERTS_INLINE void +send_exit_message(Process *to, ErtsProcLocks *to_locksp, + Eterm exit_term, Uint term_size, Eterm token) +{ + if (token == NIL) { + Eterm* hp; + Eterm mess; + ErlHeapFragment* bp; + ErlOffHeap *ohp; + + hp = erts_alloc_message_heap(term_size, &bp, &ohp, to, to_locksp); + mess = copy_struct(exit_term, term_size, &hp, ohp); + erts_queue_message(to, to_locksp, bp, mess, NIL); + } else { + ErlHeapFragment* bp; + Eterm* hp; + Eterm mess; + Eterm temp_token; + Uint sz_token; + + ASSERT(is_tuple(token)); + sz_token = size_object(token); + bp = new_message_buffer(term_size+sz_token); + hp = bp->mem; + mess = copy_struct(exit_term, term_size, &hp, &bp->off_heap); + /* the trace token must in this case be updated by the caller */ + seq_trace_output(token, mess, SEQ_TRACE_SEND, to->id, NULL); + temp_token = copy_struct(token, sz_token, &hp, &bp->off_heap); + erts_queue_message(to, to_locksp, bp, mess, temp_token); + } +} + +/* + * + * *** Exit signal behavior *** + * + * Exit signals are asynchronous (truly asynchronous in the + * SMP emulator). When the signal is received the receiver receives an + * 'EXIT' message if it is trapping exits; otherwise, it will either + * ignore the signal if the exit reason is normal, or go into an + * exiting state (status P_EXITING). When a process has gone into the + * exiting state it will not execute any more Erlang code, but it might + * take a while before it actually exits. The exit signal is being + * received when the 'EXIT' message is put in the message queue, the + * signal is dropped, or when it changes state into exiting. The time it + * is in the exiting state before actually exiting is undefined (it + * might take a really long time under certain conditions). The + * receiver of the exit signal does not break links or trigger monitors + * until it actually exits. + * + * Exit signals and other signals, e.g. messages, have to be received + * by a receiver in the same order as sent by a sender. + * + * + * + * Exit signal implementation in the SMP emulator: + * + * If the receiver is trapping exits, the signal is transformed + * into an 'EXIT' message and sent as a normal message, if the + * reason is normal the signal is dropped; otherwise, the process + * is determined to be exited. The interesting case is when the + * process is to be exited and this is what is described below. + * + * If it is possible, the receiver is set in the exiting state straight + * away and we are done; otherwise, the sender places the exit reason + * in the pending_exit field of the process struct and if necessary + * adds the receiver to the run queue. It is typically not possible + * to set a scheduled process or a process which we cannot get all locks + * on without releasing locks on it in an exiting state straight away. + * + * The receiver will poll the pending_exit field when it reach certain + * places during it's execution. When it discovers the pending exit + * it will change state into the exiting state. If the receiver wasn't + * scheduled when the pending exit was set, the first scheduler that + * schedules a new process will set the receiving process in the exiting + * state just before it schedules next process. + * + * When the exit signal is placed in the pending_exit field, the signal + * is considered as being in transit on the Erlang level. The signal is + * actually in some kind of semi transit state, since we have already + * determined how it should be received. It will exit the process no + * matter what if it is received (the process may exit by itself before + * reception of the exit signal). The signal is received when it is + * discovered in the pending_exit field by the receiver. + * + * The receiver have to poll the pending_exit field at least before: + * - moving messages from the message in queue to the private message + * queue. This in order to preserve signal order. + * - unlink. Otherwise the process might get exited on a link that + * have been removed. + * - changing the trap_exit flag to true. This in order to simplify the + * implementation; otherwise, we would have to transform the signal + * into an 'EXIT' message when setting the trap_exit flag to true. We + * would also have to maintain a queue of exit signals in transit. + * - being scheduled in or out. + */ + +static ERTS_INLINE int +send_exit_signal(Process *c_p, /* current process if and only + if reason is stored on it */ + Eterm from, /* Id of sender of signal */ + Process *rp, /* receiving process */ + ErtsProcLocks *rp_locks,/* current locks on receiver */ + Eterm reason, /* exit reason */ + Eterm exit_tuple, /* Prebuild exit tuple + or THE_NON_VALUE */ + Uint exit_tuple_sz, /* Size of prebuilt exit tuple + (if exit_tuple != THE_NON_VALUE) */ + Eterm token, /* token */ + Process *token_update, /* token updater */ + Uint32 flags /* flags */ + ) +{ + Eterm rsn = reason == am_kill ? am_killed : reason; + + ERTS_SMP_LC_ASSERT(*rp_locks == erts_proc_lc_my_proc_locks(rp)); + ERTS_SMP_LC_ASSERT((*rp_locks & ERTS_PROC_LOCKS_XSIG_SEND) + == ERTS_PROC_LOCKS_XSIG_SEND); + + ASSERT(reason != THE_NON_VALUE); + + if (ERTS_PROC_IS_TRAPPING_EXITS(rp) + && (reason != am_kill || (flags & ERTS_XSIG_FLG_IGN_KILL))) { + if (is_not_nil(token) && token_update) + seq_trace_update_send(token_update); + if (is_value(exit_tuple)) + send_exit_message(rp, rp_locks, exit_tuple, exit_tuple_sz, token); + else + erts_deliver_exit_message(from, rp, rp_locks, rsn, token); + return 1; /* Receiver will get a message */ + } + else if (reason != am_normal || (flags & ERTS_XSIG_FLG_NO_IGN_NORMAL)) { +#ifdef ERTS_SMP + if (!ERTS_PROC_PENDING_EXIT(rp) && !rp->is_exiting) { + ASSERT(rp->status != P_EXITING); + ASSERT(rp->status != P_FREE); + ASSERT(!rp->pending_exit.bp); + + if (rp == c_p && (*rp_locks & ERTS_PROC_LOCK_MAIN)) { + /* Ensure that all locks on c_p are locked before + proceeding... */ + if (*rp_locks != ERTS_PROC_LOCKS_ALL) { + ErtsProcLocks need_locks = (~(*rp_locks) + & ERTS_PROC_LOCKS_ALL); + if (erts_smp_proc_trylock(c_p, need_locks) == EBUSY) { + erts_smp_proc_unlock(c_p, + *rp_locks & ~ERTS_PROC_LOCK_MAIN); + erts_smp_proc_lock(c_p, ERTS_PROC_LOCKS_ALL_MINOR); + } + *rp_locks = ERTS_PROC_LOCKS_ALL; + } + set_proc_exiting(c_p, rsn, NULL); + } + else if (!(rp->status_flags & ERTS_PROC_SFLG_RUNNING)) { + /* Process not running ... */ + ErtsProcLocks need_locks = ~(*rp_locks) & ERTS_PROC_LOCKS_ALL; + if (need_locks + && erts_smp_proc_trylock(rp, need_locks) == EBUSY) { + /* ... but we havn't got all locks on it ... */ + save_pending_exiter(rp); + /* + * The pending exit will be discovered when next + * process is scheduled in + */ + goto set_pending_exit; + } + else { + /* ...and we have all locks on it... */ + *rp_locks = ERTS_PROC_LOCKS_ALL; + set_proc_exiting(rp, + (is_immed(rsn) + ? rsn + : copy_object(rsn, rp)), + NULL); + } + } + else { /* Process running... */ + + /* + * The pending exit will be discovered when the process + * is scheduled out if not discovered earlier. + */ + + set_pending_exit: + if (is_immed(rsn)) { + rp->pending_exit.reason = rsn; + } + else { + Eterm *hp; + Uint sz = size_object(rsn); + ErlHeapFragment *bp = new_message_buffer(sz); + + hp = &bp->mem[0]; + rp->pending_exit.reason = copy_struct(rsn, + sz, + &hp, + &bp->off_heap); + rp->pending_exit.bp = bp; + } + ASSERT(ERTS_PROC_PENDING_EXIT(rp)); + } + if (!(rp->status_flags + & (ERTS_PROC_SFLG_INRUNQ|ERTS_PROC_SFLG_RUNNING))) + erts_add_to_runq(rp); + } + /* else: + * + * The receiver already has a pending exit (or is exiting) + * so we drop this signal. + * + * NOTE: dropping this exit signal is based on the assumption + * that the receiver *will* exit; either on the pending + * exit or by itself before seeing the pending exit. + */ +#else /* !ERTS_SMP */ + if (c_p == rp) { + rp->status = P_EXITING; + c_p->fvalue = rsn; + } + else if (rp->status != P_EXITING) { /* No recursive process exits /PaN */ + Eterm old_status = rp->status; + set_proc_exiting(rp, + is_immed(rsn) ? rsn : copy_object(rsn, rp), + NULL); + ACTIVATE(rp); + if (old_status != P_RUNABLE && old_status != P_RUNNING) + erts_add_to_runq(rp); + } +#endif + return -1; /* Receiver will exit */ + } + + return 0; /* Receiver unaffected */ +} + + +int +erts_send_exit_signal(Process *c_p, + Eterm from, + Process *rp, + ErtsProcLocks *rp_locks, + Eterm reason, + Eterm token, + Process *token_update, + Uint32 flags) +{ + return send_exit_signal(c_p, + from, + rp, + rp_locks, + reason, + THE_NON_VALUE, + 0, + token, + token_update, + flags); +} + +typedef struct { + Eterm reason; + Process *p; +} ExitMonitorContext; + +static void doit_exit_monitor(ErtsMonitor *mon, void *vpcontext) +{ + ExitMonitorContext *pcontext = vpcontext; + DistEntry *dep; + ErtsMonitor *rmon; + Process *rp; + + if (mon->type == MON_ORIGIN) { + /* We are monitoring someone else, we need to demonitor that one.. */ + if (is_atom(mon->pid)) { /* remote by name */ + ASSERT(is_node_name_atom(mon->pid)); + dep = erts_sysname_to_connected_dist_entry(mon->pid); + if (dep) { + erts_smp_de_links_lock(dep); + rmon = erts_remove_monitor(&(dep->monitors), mon->ref); + erts_smp_de_links_unlock(dep); + if (rmon) { + ErtsDSigData dsd; + int code = erts_dsig_prepare(&dsd, dep, NULL, + ERTS_DSP_NO_LOCK, 0); + if (code == ERTS_DSIG_PREP_CONNECTED) { + code = erts_dsig_send_demonitor(&dsd, + rmon->pid, + mon->name, + mon->ref, + 1); + ASSERT(code == ERTS_DSIG_SEND_OK); + } + erts_destroy_monitor(rmon); + } + erts_deref_dist_entry(dep); + } + } else { + ASSERT(is_pid(mon->pid)); + if (is_internal_pid(mon->pid)) { /* local by pid or name */ + rp = erts_pid2proc(NULL, 0, mon->pid, ERTS_PROC_LOCK_LINK); + if (!rp) { + goto done; + } + rmon = erts_remove_monitor(&(rp->monitors),mon->ref); + erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_LINK); + if (rmon == NULL) { + goto done; + } + erts_destroy_monitor(rmon); + } else { /* remote by pid */ + ASSERT(is_external_pid(mon->pid)); + dep = external_pid_dist_entry(mon->pid); + ASSERT(dep != NULL); + if (dep) { + erts_smp_de_links_lock(dep); + rmon = erts_remove_monitor(&(dep->monitors), mon->ref); + erts_smp_de_links_unlock(dep); + if (rmon) { + ErtsDSigData dsd; + int code = erts_dsig_prepare(&dsd, dep, NULL, + ERTS_DSP_NO_LOCK, 0); + if (code == ERTS_DSIG_PREP_CONNECTED) { + code = erts_dsig_send_demonitor(&dsd, + rmon->pid, + mon->pid, + mon->ref, + 1); + ASSERT(code == ERTS_DSIG_SEND_OK); + } + erts_destroy_monitor(rmon); + } + } + } + } + } else { /* type == MON_TARGET */ + ASSERT(mon->type == MON_TARGET); + ASSERT(is_pid(mon->pid) || is_internal_port(mon->pid)); + if (is_internal_port(mon->pid)) { + Port *prt = erts_id2port(mon->pid, NULL, 0); + if (prt == NULL) { + goto done; + } + erts_fire_port_monitor(prt, mon->ref); + erts_port_release(prt); + } else if (is_internal_pid(mon->pid)) {/* local by name or pid */ + Eterm watched; + Eterm lhp[3]; + ErtsProcLocks rp_locks = (ERTS_PROC_LOCK_LINK + | ERTS_PROC_LOCKS_MSG_SEND); + rp = erts_pid2proc(NULL, 0, mon->pid, rp_locks); + if (rp == NULL) { + goto done; + } + rmon = erts_remove_monitor(&(rp->monitors),mon->ref); + if (rmon) { + erts_destroy_monitor(rmon); + watched = (is_atom(mon->name) + ? TUPLE2(lhp, mon->name, + erts_this_dist_entry->sysname) + : pcontext->p->id); + erts_queue_monitor_message(rp, &rp_locks, mon->ref, am_process, + watched, pcontext->reason); + } + /* else: demonitor while we exited, i.e. do nothing... */ + erts_smp_proc_unlock(rp, rp_locks); + } else { /* external by pid or name */ + ASSERT(is_external_pid(mon->pid)); + dep = external_pid_dist_entry(mon->pid); + ASSERT(dep != NULL); + if (dep) { + erts_smp_de_links_lock(dep); + rmon = erts_remove_monitor(&(dep->monitors), mon->ref); + erts_smp_de_links_unlock(dep); + if (rmon) { + ErtsDSigData dsd; + int code = erts_dsig_prepare(&dsd, dep, NULL, + ERTS_DSP_NO_LOCK, 0); + if (code == ERTS_DSIG_PREP_CONNECTED) { + code = erts_dsig_send_m_exit(&dsd, + mon->pid, + (rmon->name != NIL + ? rmon->name + : rmon->pid), + mon->ref, + pcontext->reason); + ASSERT(code == ERTS_DSIG_SEND_OK); + } + erts_destroy_monitor(rmon); + } + } + } + } + done: + /* As the monitors are previously removed from the process, + distribution operations will not cause monitors to disappear, + we can safely delete it. */ + + erts_destroy_monitor(mon); +} + +typedef struct { + Process *p; + Eterm reason; + Eterm exit_tuple; + Uint exit_tuple_sz; +} ExitLinkContext; + +static void doit_exit_link(ErtsLink *lnk, void *vpcontext) +{ + ExitLinkContext *pcontext = vpcontext; + /* Unpack context, it's readonly */ + Process *p = pcontext->p; + Eterm reason = pcontext->reason; + Eterm exit_tuple = pcontext->exit_tuple; + Uint exit_tuple_sz = pcontext->exit_tuple_sz; + Eterm item = lnk->pid; + ErtsLink *rlnk; + DistEntry *dep; + Process *rp; + + switch(lnk->type) { + case LINK_PID: + if(is_internal_port(item)) { + Port *prt = erts_id2port(item, NULL, 0); + if (prt) { + rlnk = erts_remove_link(&prt->nlinks, p->id); + if (rlnk) + erts_destroy_link(rlnk); + erts_do_exit_port(prt, p->id, reason); + erts_port_release(prt); + } + } + else if(is_external_port(item)) { + erts_dsprintf_buf_t *dsbufp = erts_create_logger_dsbuf(); + erts_dsprintf(dsbufp, + "Erroneous link between %T and external port %T " + "found\n", + p->id, + item); + erts_send_error_to_logger_nogl(dsbufp); + ASSERT(0); /* It isn't possible to setup such a link... */ + } + else if (is_internal_pid(item)) { + ErtsProcLocks rp_locks = (ERTS_PROC_LOCK_LINK + | ERTS_PROC_LOCKS_XSIG_SEND); + rp = erts_pid2proc(NULL, 0, item, rp_locks); + if (rp) { + rlnk = erts_remove_link(&(rp->nlinks), p->id); + /* If rlnk == NULL, we got unlinked while exiting, + i.e., do nothing... */ + if (rlnk) { + int xres; + erts_destroy_link(rlnk); + xres = send_exit_signal(NULL, + p->id, + rp, + &rp_locks, + reason, + exit_tuple, + exit_tuple_sz, + SEQ_TRACE_TOKEN(p), + p, + ERTS_XSIG_FLG_IGN_KILL); + if (xres >= 0 && IS_TRACED_FL(rp, F_TRACE_PROCS)) { + /* We didn't exit the process and it is traced */ + if (IS_TRACED_FL(rp, F_TRACE_PROCS)) { + trace_proc(p, rp, am_getting_unlinked, p->id); + } + } + } + ASSERT(rp != p); + erts_smp_proc_unlock(rp, rp_locks); + } + } + else if (is_external_pid(item)) { + dep = external_pid_dist_entry(item); + if(dep != erts_this_dist_entry) { + ErtsDSigData dsd; + int code; + ErtsDistLinkData dld; + erts_remove_dist_link(&dld, p->id, item, dep); + erts_smp_proc_lock(p, ERTS_PROC_LOCK_MAIN); + code = erts_dsig_prepare(&dsd, dep, p, ERTS_DSP_NO_LOCK, 0); + if (code == ERTS_DSIG_PREP_CONNECTED) { + code = erts_dsig_send_exit_tt(&dsd, p->id, item, reason, + SEQ_TRACE_TOKEN(p)); + ASSERT(code == ERTS_DSIG_SEND_OK); + } + erts_smp_proc_unlock(p, ERTS_PROC_LOCK_MAIN); + erts_destroy_dist_link(&dld); + } + } + break; + case LINK_NODE: + ASSERT(is_node_name_atom(item)); + dep = erts_sysname_to_connected_dist_entry(item); + if(dep) { + /* dist entries have node links in a separate structure to + avoid confusion */ + erts_smp_de_links_lock(dep); + rlnk = erts_remove_link(&(dep->node_links), p->id); + erts_smp_de_links_unlock(dep); + if (rlnk) + erts_destroy_link(rlnk); + erts_deref_dist_entry(dep); + } else { +#ifndef ERTS_SMP + /* XXX Is this possible? Shouldn't this link + previously have been removed if the node + had previously been disconnected. */ + ASSERT(0); +#endif + /* This is possible when smp support has been enabled, + and dist port and process exits simultaneously. */ + } + break; + + default: + erl_exit(1, "bad type in link list\n"); + break; + } + erts_destroy_link(lnk); +} + +static void +resume_suspend_monitor(ErtsSuspendMonitor *smon, void *vc_p) +{ + Process *suspendee = erts_pid2proc((Process *) vc_p, ERTS_PROC_LOCK_MAIN, + smon->pid, ERTS_PROC_LOCK_STATUS); + if (suspendee) { + if (smon->active) + resume_process(suspendee); + erts_smp_proc_unlock(suspendee, ERTS_PROC_LOCK_STATUS); + } + erts_destroy_suspend_monitor(smon); +} + +static void +continue_exit_process(Process *p +#ifdef ERTS_SMP + , erts_pix_lock_t *pix_lock +#endif + ); + +/* this function fishishes a process and propagates exit messages - called + by process_main when a process dies */ +void +erts_do_exit_process(Process* p, Eterm reason) +{ +#ifdef ERTS_SMP + erts_pix_lock_t *pix_lock = ERTS_PID2PIXLOCK(p->id); +#endif + + p->arity = 0; /* No live registers */ + p->fvalue = reason; + +#ifdef ERTS_SMP + ERTS_SMP_CHK_HAVE_ONLY_MAIN_PROC_LOCK(p); + /* By locking all locks (main lock is already locked) when going + to status P_EXITING, it is enough to take any lock when + looking up a process (erts_pid2proc()) to prevent the looked up + process from exiting until the lock has been released. */ + erts_smp_proc_lock(p, ERTS_PROC_LOCKS_ALL_MINOR); +#endif + + if (erts_system_profile_flags.runnable_procs && (p->status != P_WAITING)) { + profile_runnable_proc(p, am_inactive); + } + +#ifdef ERTS_SMP + erts_pix_lock(pix_lock); + p->is_exiting = 1; +#endif + + p->status = P_EXITING; + +#ifdef ERTS_SMP + erts_pix_unlock(pix_lock); + + if (ERTS_PROC_PENDING_EXIT(p)) { + /* Process exited before pending exit was received... */ + p->pending_exit.reason = THE_NON_VALUE; + if (p->pending_exit.bp) { + free_message_buffer(p->pending_exit.bp); + p->pending_exit.bp = NULL; + } + } + + cancel_suspend_of_suspendee(p, ERTS_PROC_LOCKS_ALL); + + ERTS_SMP_MSGQ_MV_INQ2PRIVQ(p); +#endif + + if (IS_TRACED_FL(p,F_TRACE_PROCS)) + trace_proc(p, p, am_exit, reason); + + erts_trace_check_exiting(p->id); + + ASSERT((p->trace_flags & F_INITIAL_TRACE_FLAGS) == F_INITIAL_TRACE_FLAGS); + + cancel_timer(p); /* Always cancel timer just in case */ + + /* + * The timer of this process can *not* be used anymore. The field used + * for the timer is now used for misc exiting data. + */ + p->u.exit_data = NULL; + + if (p->bif_timers) + erts_cancel_bif_timers(p, ERTS_PROC_LOCKS_ALL); + +#ifdef ERTS_SMP + if (p->flags & F_HAVE_BLCKD_MSCHED) + erts_block_multi_scheduling(p, ERTS_PROC_LOCKS_ALL, 0, 1); +#endif + + erts_smp_proc_unlock(p, ERTS_PROC_LOCKS_ALL_MINOR); + +#ifdef ERTS_SMP + continue_exit_process(p, pix_lock); +#else + continue_exit_process(p); +#endif +} + +void +erts_continue_exit_process(Process *c_p) +{ +#ifdef ERTS_SMP + continue_exit_process(c_p, ERTS_PID2PIXLOCK(c_p->id)); +#else + continue_exit_process(c_p); +#endif +} + +static void +continue_exit_process(Process *p +#ifdef ERTS_SMP + , erts_pix_lock_t *pix_lock +#endif + ) +{ + ErtsLink* lnk; + ErtsMonitor *mon; + ErtsProcLocks curr_locks = ERTS_PROC_LOCK_MAIN; + Eterm reason = p->fvalue; + DistEntry *dep; + struct saved_calls *scb; +#ifdef DEBUG + int yield_allowed = 1; +#endif + + ERTS_SMP_LC_ASSERT(ERTS_PROC_LOCK_MAIN == erts_proc_lc_my_proc_locks(p)); + +#ifdef DEBUG + erts_smp_proc_lock(p, ERTS_PROC_LOCK_STATUS); + ASSERT(p->status == P_EXITING); + erts_smp_proc_unlock(p, ERTS_PROC_LOCK_STATUS); +#endif + + if (p->flags & F_USING_DB) { + if (erts_db_process_exiting(p, ERTS_PROC_LOCK_MAIN)) + goto yield; + p->flags &= ~F_USING_DB; + } + + if (p->flags & F_USING_DDLL) { + erts_ddll_proc_dead(p, ERTS_PROC_LOCK_MAIN); + p->flags &= ~F_USING_DDLL; + } + + if (p->nodes_monitors) { + erts_delete_nodes_monitors(p, ERTS_PROC_LOCK_MAIN); + p->nodes_monitors = NULL; + } + + + if (p->suspend_monitors) { + erts_sweep_suspend_monitors(p->suspend_monitors, + resume_suspend_monitor, + p); + p->suspend_monitors = NULL; + } + + /* + * The registered name *should* be the last "erlang resource" to + * cleanup. + */ + if (p->reg) { + (void) erts_unregister_name(p, ERTS_PROC_LOCK_MAIN, NULL, THE_NON_VALUE); + ASSERT(!p->reg); + } + + erts_smp_proc_lock(p, ERTS_PROC_LOCKS_ALL_MINOR); + curr_locks = ERTS_PROC_LOCKS_ALL; + + /* + * From this point on we are no longer allowed to yield + * this process. + */ +#ifdef DEBUG + yield_allowed = 0; +#endif + + { + int pix; + /* Do *not* use erts_get_runq_proc() */ + ErtsRunQueue *rq; + rq = erts_get_runq_current(ERTS_GET_SCHEDULER_DATA_FROM_PROC(p)); + + ASSERT(internal_pid_index(p->id) < erts_max_processes); + pix = internal_pid_index(p->id); + + erts_smp_mtx_lock(&proc_tab_mtx); + erts_smp_runq_lock(rq); + +#ifdef ERTS_SMP + erts_pix_lock(pix_lock); + + ASSERT(p->scheduler_data); + ASSERT(p->scheduler_data->current_process == p); + ASSERT(p->scheduler_data->free_process == NULL); + + p->scheduler_data->current_process = NULL; + p->scheduler_data->free_process = p; + p->status_flags = 0; +#endif + process_tab[pix] = NULL; /* Time of death! */ + ASSERT(erts_smp_atomic_read(&process_count) > 0); + erts_smp_atomic_dec(&process_count); + +#ifdef ERTS_SMP + erts_pix_unlock(pix_lock); +#endif + erts_smp_runq_unlock(rq); + + if (p_next < 0) { + if (p_last >= p_next) { + p_serial++; + p_serial &= p_serial_mask; + } + p_next = pix; + } + + ERTS_MAYBE_SAVE_TERMINATING_PROCESS(p); + + erts_smp_mtx_unlock(&proc_tab_mtx); + } + + /* + * All "erlang resources" have to be deallocated before this point, + * e.g. registered name, so monitoring and linked processes can + * be sure that all interesting resources have been deallocated + * when the monitors and/or links hit. + */ + + mon = p->monitors; + p->monitors = NULL; /* to avoid recursive deletion during traversal */ + + lnk = p->nlinks; + p->nlinks = NULL; + p->status = P_FREE; + dep = ((p->flags & F_DISTRIBUTION) + ? ERTS_PROC_SET_DIST_ENTRY(p, ERTS_PROC_LOCKS_ALL, NULL) + : NULL); + scb = ERTS_PROC_SET_SAVED_CALLS_BUF(p, ERTS_PROC_LOCKS_ALL, NULL); + + erts_smp_proc_unlock(p, ERTS_PROC_LOCKS_ALL); + processes_busy--; + + if (dep) { + erts_do_net_exits(dep, reason); + if(dep) + erts_deref_dist_entry(dep); + } + + /* + * Pre-build the EXIT tuple if there are any links. + */ + if (lnk) { + Eterm tmp_heap[4]; + Eterm exit_tuple; + Uint exit_tuple_sz; + Eterm* hp; + + hp = &tmp_heap[0]; + + exit_tuple = TUPLE3(hp, am_EXIT, p->id, reason); + + exit_tuple_sz = size_object(exit_tuple); + + { + ExitLinkContext context = {p, reason, exit_tuple, exit_tuple_sz}; + erts_sweep_links(lnk, &doit_exit_link, &context); + } + } + + { + ExitMonitorContext context = {reason, p}; + erts_sweep_monitors(mon,&doit_exit_monitor,&context); + } + + if (scb) + erts_free(ERTS_ALC_T_CALLS_BUF, (void *) scb); + + delete_process(p); + + erts_smp_proc_lock(p, ERTS_PROC_LOCK_MAIN); + ERTS_SMP_CHK_HAVE_ONLY_MAIN_PROC_LOCK(p); + + return; + + yield: + +#ifdef DEBUG + ASSERT(yield_allowed); +#endif + + ERTS_SMP_LC_ASSERT(curr_locks == erts_proc_lc_my_proc_locks(p)); + ERTS_SMP_LC_ASSERT(ERTS_PROC_LOCK_MAIN & curr_locks); + + ASSERT(p->status == P_EXITING); + + p->i = (Eterm *) beam_continue_exit; + + if (!(curr_locks & ERTS_PROC_LOCK_STATUS)) { + erts_smp_proc_lock(p, ERTS_PROC_LOCK_STATUS); + curr_locks |= ERTS_PROC_LOCK_STATUS; + } + + erts_add_to_runq(p); + + if (curr_locks != ERTS_PROC_LOCK_MAIN) + erts_smp_proc_unlock(p, ~ERTS_PROC_LOCK_MAIN & curr_locks); + + ERTS_SMP_LC_ASSERT(ERTS_PROC_LOCK_MAIN == erts_proc_lc_my_proc_locks(p)); + +} + +/* Callback for process timeout */ +static void +timeout_proc(Process* p) +{ + p->i = (Eterm *) p->def_arg_reg[0]; + p->flags |= F_TIMO; + p->flags &= ~F_INSLPQUEUE; + + if (p->status == P_WAITING) + erts_add_to_runq(p); + if (p->status == P_SUSPENDED) + p->rstatus = P_RUNABLE; /* MUST set resume status to runnable */ +} + + +void +cancel_timer(Process* p) +{ + ERTS_SMP_LC_ASSERT(ERTS_PROC_LOCK_MAIN & erts_proc_lc_my_proc_locks(p)); + p->flags &= ~(F_INSLPQUEUE|F_TIMO); +#ifdef ERTS_SMP + erts_cancel_smp_ptimer(p->u.ptimer); +#else + erl_cancel_timer(&p->u.tm); +#endif +} + +/* + * Insert a process into the time queue, with a timeout 'timeout' in ms. + */ +void +set_timer(Process* p, Uint timeout) +{ + ERTS_SMP_LC_ASSERT(ERTS_PROC_LOCK_MAIN & erts_proc_lc_my_proc_locks(p)); + + /* check for special case timeout=0 DONT ADD TO time queue */ + if (timeout == 0) { + p->flags |= F_TIMO; + return; + } + p->flags |= F_INSLPQUEUE; + p->flags &= ~F_TIMO; + +#ifdef ERTS_SMP + erts_create_smp_ptimer(&p->u.ptimer, + p->id, + (ErlTimeoutProc) timeout_proc, + timeout); +#else + erl_set_timer(&p->u.tm, + (ErlTimeoutProc) timeout_proc, + NULL, + (void*) p, + timeout); +#endif +} + +/* + * Stack dump functions follow. + */ + +void +erts_stack_dump(int to, void *to_arg, Process *p) +{ + Eterm* sp; + int yreg = -1; + + if (p->trace_flags & F_SENSITIVE) { + return; + } + erts_program_counter_info(to, to_arg, p); + for (sp = p->stop; sp < STACK_START(p); sp++) { + yreg = stack_element_dump(to, to_arg, p, sp, yreg); + } +} + +void +erts_program_counter_info(int to, void *to_arg, Process *p) +{ + int i; + + erts_print(to, to_arg, "Program counter: %p (", p->i); + print_function_from_pc(to, to_arg, p->i); + erts_print(to, to_arg, ")\n"); + erts_print(to, to_arg, "CP: %p (", p->cp); + print_function_from_pc(to, to_arg, p->cp); + erts_print(to, to_arg, ")\n"); + if (!((p->status == P_RUNNING) || (p->status == P_GARBING))) { + erts_print(to, to_arg, "arity = %d\n",p->arity); + if (!ERTS_IS_CRASH_DUMPING) { + /* + * Only print the arguments if we are not writing a + * crash dump file. The arguments cannot be interpreted + * by the crashdump_viewer application and will therefore + * only cause problems. + */ + for (i = 0; i < p->arity; i++) + erts_print(to, to_arg, " %T\n", p->arg_reg[i]); + } + } +} + +static void +print_function_from_pc(int to, void *to_arg, Eterm* x) +{ + Eterm* addr = find_function_from_pc(x); + if (addr == NULL) { + if (x == beam_exit) { + erts_print(to, to_arg, ""); + } else if (x == beam_continue_exit) { + erts_print(to, to_arg, ""); + } else if (x == beam_apply+1) { + erts_print(to, to_arg, ""); + } else if (x == 0) { + erts_print(to, to_arg, "invalid"); + } else { + erts_print(to, to_arg, "unknown function"); + } + } else { + erts_print(to, to_arg, "%T:%T/%d + %d", + addr[0], addr[1], addr[2], ((x-addr)-2) * sizeof(Eterm)); + } +} + +static int +stack_element_dump(int to, void *to_arg, Process* p, Eterm* sp, int yreg) +{ + Eterm x = *sp; + + if (yreg < 0 || is_CP(x)) { + erts_print(to, to_arg, "\n%p ", sp); + } else { + char sbuf[16]; + sprintf(sbuf, "y(%d)", yreg); + erts_print(to, to_arg, "%-8s ", sbuf); + yreg++; + } + + if (is_CP(x)) { + erts_print(to, to_arg, "Return addr %p (", (Eterm *) x); + print_function_from_pc(to, to_arg, cp_val(x)); + erts_print(to, to_arg, ")\n"); + yreg = 0; + } else if is_catch(x) { + erts_print(to, to_arg, "Catch %p (", catch_pc(x)); + print_function_from_pc(to, to_arg, catch_pc(x)); + erts_print(to, to_arg, ")\n"); + } else { + erts_print(to, to_arg, "%T\n", x); + } + return yreg; +} + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *\ + * The processes/0 BIF implementation. * +\* */ + + +#define ERTS_PROCESSES_BIF_TAB_INSPECT_INDICES_PER_RED 25 +#define ERTS_PROCESSES_BIF_TAB_CHUNK_SIZE 1000 +#define ERTS_PROCESSES_BIF_MIN_START_REDS \ + (ERTS_PROCESSES_BIF_TAB_CHUNK_SIZE \ + / ERTS_PROCESSES_BIF_TAB_INSPECT_INDICES_PER_RED) + +#define ERTS_PROCESSES_BIF_TAB_FREE_TERM_PROC_REDS 1 + +#define ERTS_PROCESSES_BIF_INSPECT_TERM_PROC_PER_RED 10 + +#define ERTS_PROCESSES_INSPECT_TERM_PROC_MAX_REDS \ + (ERTS_PROCESSES_BIF_TAB_CHUNK_SIZE \ + / ERTS_PROCESSES_BIF_TAB_INSPECT_INDICES_PER_RED) + + +#define ERTS_PROCESSES_BIF_BUILD_RESULT_CONSES_PER_RED 75 + +#define ERTS_PROCS_DBG_DO_TRACE 0 + +#ifdef DEBUG +# define ERTS_PROCESSES_BIF_DEBUGLEVEL 100 +#else +# define ERTS_PROCESSES_BIF_DEBUGLEVEL 0 +#endif + +#define ERTS_PROCS_DBGLVL_CHK_HALLOC 1 +#define ERTS_PROCS_DBGLVL_CHK_FOUND_PIDS 5 +#define ERTS_PROCS_DBGLVL_CHK_PIDS 10 +#define ERTS_PROCS_DBGLVL_CHK_TERM_PROC_LIST 20 +#define ERTS_PROCS_DBGLVL_CHK_RESLIST 20 + +#if ERTS_PROCESSES_BIF_DEBUGLEVEL == 0 +# define ERTS_PROCS_ASSERT(EXP) +#else +# define ERTS_PROCS_ASSERT(EXP) \ + ((void) ((EXP) \ + ? 1 \ + : (debug_processes_assert_error(#EXP, __FILE__, __LINE__), 0))) +#endif + + +#if ERTS_PROCESSES_BIF_DEBUGLEVEL >= ERTS_PROCS_DBGLVL_CHK_HALLOC +# define ERTS_PROCS_DBG_SAVE_HEAP_ALLOC(PBDP, HP, SZ) \ +do { \ + ERTS_PROCS_ASSERT(!(PBDP)->debug.heap); \ + ERTS_PROCS_ASSERT(!(PBDP)->debug.heap_size); \ + (PBDP)->debug.heap = (HP); \ + (PBDP)->debug.heap_size = (SZ); \ +} while (0) +# define ERTS_PROCS_DBG_VERIFY_HEAP_ALLOC_USED(PBDP, HP) \ +do { \ + ERTS_PROCS_ASSERT((PBDP)->debug.heap); \ + ERTS_PROCS_ASSERT((PBDP)->debug.heap_size); \ + ERTS_PROCS_ASSERT((PBDP)->debug.heap + (PBDP)->debug.heap_size == (HP));\ + (PBDP)->debug.heap = NULL; \ + (PBDP)->debug.heap_size = 0; \ +} while (0) +# define ERTS_PROCS_DBG_HEAP_ALLOC_INIT(PBDP) \ +do { \ + (PBDP)->debug.heap = NULL; \ + (PBDP)->debug.heap_size = 0; \ +} while (0) +#else +# define ERTS_PROCS_DBG_SAVE_HEAP_ALLOC(PBDP, HP, SZ) +# define ERTS_PROCS_DBG_VERIFY_HEAP_ALLOC_USED(PBDP, HP) +# define ERTS_PROCS_DBG_HEAP_ALLOC_INIT(PBDP) +#endif + +#if ERTS_PROCESSES_BIF_DEBUGLEVEL >= ERTS_PROCS_DBGLVL_CHK_RESLIST +# define ERTS_PROCS_DBG_CHK_RESLIST(R) debug_processes_check_res_list((R)) +#else +# define ERTS_PROCS_DBG_CHK_RESLIST(R) +#endif + +#if ERTS_PROCESSES_BIF_DEBUGLEVEL >= ERTS_PROCS_DBGLVL_CHK_PIDS +# define ERTS_PROCS_DBG_SAVE_PIDS(PBDP) debug_processes_save_all_pids((PBDP)) +# define ERTS_PROCS_DBG_VERIFY_PIDS(PBDP) \ +do { \ + if (!(PBDP)->debug.correct_pids_verified) \ + debug_processes_verify_all_pids((PBDP)); \ +} while (0) +# define ERTS_PROCS_DBG_CLEANUP_CHK_PIDS(PBDP) \ +do { \ + if ((PBDP)->debug.correct_pids) { \ + erts_free(ERTS_ALC_T_PROCS_PIDS, \ + (PBDP)->debug.correct_pids); \ + (PBDP)->debug.correct_pids = NULL; \ + } \ +} while(0) +# define ERTS_PROCS_DBG_CHK_PIDS_INIT(PBDP) \ +do { \ + (PBDP)->debug.correct_pids_verified = 0; \ + (PBDP)->debug.correct_pids = NULL; \ +} while (0) +#else +# define ERTS_PROCS_DBG_SAVE_PIDS(PBDP) +# define ERTS_PROCS_DBG_VERIFY_PIDS(PBDP) +# define ERTS_PROCS_DBG_CLEANUP_CHK_PIDS(PBDP) +# define ERTS_PROCS_DBG_CHK_PIDS_INIT(PBDP) +#endif + +#if ERTS_PROCESSES_BIF_DEBUGLEVEL >= ERTS_PROCS_DBGLVL_CHK_FOUND_PIDS +# define ERTS_PROCS_DBG_CHK_PID_FOUND(PBDP, PID, TVP) \ + debug_processes_check_found_pid((PBDP), (PID), (TVP), 1) +# define ERTS_PROCS_DBG_CHK_PID_NOT_FOUND(PBDP, PID, TVP) \ + debug_processes_check_found_pid((PBDP), (PID), (TVP), 0) +#else +# define ERTS_PROCS_DBG_CHK_PID_FOUND(PBDP, PID, TVP) +# define ERTS_PROCS_DBG_CHK_PID_NOT_FOUND(PBDP, PID, TVP) +#endif + +#if ERTS_PROCESSES_BIF_DEBUGLEVEL >= ERTS_PROCS_DBGLVL_CHK_TERM_PROC_LIST +# define ERTS_PROCS_DBG_CHK_TPLIST() \ + debug_processes_check_term_proc_list() +# define ERTS_PROCS_DBG_CHK_FREELIST(FL) \ + debug_processes_check_term_proc_free_list(FL) +#else +# define ERTS_PROCS_DBG_CHK_TPLIST() +# define ERTS_PROCS_DBG_CHK_FREELIST(FL) +#endif + +#if ERTS_PROCESSES_BIF_DEBUGLEVEL == 0 +#if ERTS_PROCS_DBG_DO_TRACE +# define ERTS_PROCS_DBG_INIT(P, PBDP) (PBDP)->debug.caller = (P)->id +# else +# define ERTS_PROCS_DBG_INIT(P, PBDP) +# endif +# define ERTS_PROCS_DBG_CLEANUP(PBDP) +#else +# define ERTS_PROCS_DBG_INIT(P, PBDP) \ +do { \ + (PBDP)->debug.caller = (P)->id; \ + ERTS_PROCS_DBG_HEAP_ALLOC_INIT((PBDP)); \ + ERTS_PROCS_DBG_CHK_PIDS_INIT((PBDP)); \ +} while (0) +# define ERTS_PROCS_DBG_CLEANUP(PBDP) \ +do { \ + ERTS_PROCS_DBG_CLEANUP_CHK_PIDS((PBDP)); \ +} while (0) +#endif + +#if ERTS_PROCS_DBG_DO_TRACE +# define ERTS_PROCS_DBG_TRACE(PID, FUNC, WHAT) \ + erts_fprintf(stderr, "%T %s:%d:%s(): %s\n", \ + (PID), __FILE__, __LINE__, #FUNC, #WHAT) +#else +# define ERTS_PROCS_DBG_TRACE(PID, FUNC, WHAT) +#endif + +static Uint processes_bif_tab_chunks; +static Export processes_trap_export; + +typedef struct { + SysTimeval time; +} ErtsProcessesBifChunkInfo; + +typedef enum { + INITIALIZING, + INSPECTING_TABLE, + INSPECTING_TERMINATED_PROCESSES, + BUILDING_RESULT, + RETURN_RESULT +} ErtsProcessesBifState; + +typedef struct { + ErtsProcessesBifState state; + Eterm caller; + ErtsProcessesBifChunkInfo *chunk; + int tix; + int pid_ix; + int pid_sz; + Eterm *pid; + ErtsTermProcElement *bif_invocation; /* Only used when > 1 chunk */ + +#if ERTS_PROCESSES_BIF_DEBUGLEVEL != 0 || ERTS_PROCS_DBG_DO_TRACE + struct { + Eterm caller; +#if ERTS_PROCESSES_BIF_DEBUGLEVEL >= ERTS_PROCS_DBGLVL_CHK_FOUND_PIDS + SysTimeval *pid_started; +#endif +#if ERTS_PROCESSES_BIF_DEBUGLEVEL >= ERTS_PROCS_DBGLVL_CHK_HALLOC + Eterm *heap; + Uint heap_size; +#endif +#if ERTS_PROCESSES_BIF_DEBUGLEVEL >= ERTS_PROCS_DBGLVL_CHK_PIDS + int correct_pids_verified; + Eterm *correct_pids; +#endif + } debug; +#endif + +} ErtsProcessesBifData; + + +#if ERTS_PROCESSES_BIF_DEBUGLEVEL != 0 +static void debug_processes_assert_error(char* expr, char* file, int line); +#endif +#if ERTS_PROCESSES_BIF_DEBUGLEVEL >= ERTS_PROCS_DBGLVL_CHK_RESLIST +static void debug_processes_check_res_list(Eterm list); +#endif +#if ERTS_PROCESSES_BIF_DEBUGLEVEL >= ERTS_PROCS_DBGLVL_CHK_PIDS +static void debug_processes_save_all_pids(ErtsProcessesBifData *pbdp); +static void debug_processes_verify_all_pids(ErtsProcessesBifData *pbdp); +#endif +#if ERTS_PROCESSES_BIF_DEBUGLEVEL >= ERTS_PROCS_DBGLVL_CHK_FOUND_PIDS +static void debug_processes_check_found_pid(ErtsProcessesBifData *pbdp, + Eterm pid, + SysTimeval *started, + int pid_should_be_found); +#endif +#if ERTS_PROCESSES_BIF_DEBUGLEVEL >= ERTS_PROCS_DBGLVL_CHK_TERM_PROC_LIST +static SysTimeval debug_tv_start; +static void debug_processes_check_term_proc_list(void); +static void debug_processes_check_term_proc_free_list(ErtsTermProcElement *tpep); +#endif + +static void +save_terminating_process(Process *p) +{ + ErtsTermProcElement *tpep = erts_alloc(ERTS_ALC_T_PROCS_TPROC_EL, + sizeof(ErtsTermProcElement)); + ERTS_PROCS_ASSERT(saved_term_procs.start && saved_term_procs.end); + ERTS_SMP_LC_ASSERT(erts_lc_mtx_is_locked(&proc_tab_mtx)); + + ERTS_PROCS_DBG_CHK_TPLIST(); + + tpep->prev = saved_term_procs.end; + tpep->next = NULL; + tpep->ix = internal_pid_index(p->id); + tpep->u.process.pid = p->id; + tpep->u.process.spawned = p->started; + erts_get_emu_time(&tpep->u.process.exited); + + saved_term_procs.end->next = tpep; + saved_term_procs.end = tpep; + + ERTS_PROCS_DBG_CHK_TPLIST(); + + ERTS_PROCS_ASSERT((tpep->prev->ix >= 0 + ? erts_cmp_timeval(&tpep->u.process.exited, + &tpep->prev->u.process.exited) + : erts_cmp_timeval(&tpep->u.process.exited, + &tpep->prev->u.bif_invocation.time)) > 0); +} + +static void +cleanup_processes_bif_data(Binary *bp) +{ + ErtsProcessesBifData *pbdp = ERTS_MAGIC_BIN_DATA(bp); + + ERTS_PROCS_DBG_TRACE(pbdp->debug.caller, cleanup_processes_bif_data, call); + + if (pbdp->state != INITIALIZING) { + + if (pbdp->chunk) { + erts_free(ERTS_ALC_T_PROCS_CNKINF, pbdp->chunk); + pbdp->chunk = NULL; + } + if (pbdp->pid) { + erts_free(ERTS_ALC_T_PROCS_PIDS, pbdp->pid); + pbdp->pid = NULL; + } + +#if ERTS_PROCESSES_BIF_DEBUGLEVEL >= ERTS_PROCS_DBGLVL_CHK_FOUND_PIDS + if (pbdp->debug.pid_started) { + erts_free(ERTS_ALC_T_PROCS_PIDS, pbdp->debug.pid_started); + pbdp->debug.pid_started = NULL; + } +#endif + + if (pbdp->bif_invocation) { + ErtsTermProcElement *tpep; + + erts_smp_mtx_lock(&proc_tab_mtx); + + ERTS_PROCS_DBG_TRACE(pbdp->debug.caller, + cleanup_processes_bif_data, + term_proc_cleanup); + + tpep = pbdp->bif_invocation; + pbdp->bif_invocation = NULL; + + ERTS_PROCS_DBG_CHK_TPLIST(); + + if (tpep->prev) { + /* + * Only remove this bif invokation when we + * have preceding invokations. + */ + tpep->prev->next = tpep->next; + if (tpep->next) + tpep->next->prev = tpep->prev; + else { + /* + * At the time of writing this branch cannot be + * reached. I don't want to remove this code though + * since it may be possible to reach this line + * in the future if the cleanup order in + * erts_do_exit_process() is changed. The ASSERT(0) + * is only here to make us aware that the reorder + * has happened. /rickard + */ + ASSERT(0); + saved_term_procs.end = tpep->prev; + } + erts_free(ERTS_ALC_T_PROCS_TPROC_EL, tpep); + } + else { + /* + * Free all elements until next bif invokation + * is found. + */ + ERTS_PROCS_ASSERT(saved_term_procs.start == tpep); + do { + ErtsTermProcElement *ftpep = tpep; + tpep = tpep->next; + erts_free(ERTS_ALC_T_PROCS_TPROC_EL, ftpep); + } while (tpep && tpep->ix >= 0); + saved_term_procs.start = tpep; + if (tpep) + tpep->prev = NULL; + else + saved_term_procs.end = NULL; + } + + ERTS_PROCS_DBG_CHK_TPLIST(); + + erts_smp_mtx_unlock(&proc_tab_mtx); + + } + } + + ERTS_PROCS_DBG_TRACE(pbdp->debug.caller, + cleanup_processes_bif_data, + return); + ERTS_PROCS_DBG_CLEANUP(pbdp); +} + +static int +processes_bif_engine(Process *p, Eterm *res_accp, Binary *mbp) +{ + ErtsProcessesBifData *pbdp = ERTS_MAGIC_BIN_DATA(mbp); + int have_reds; + int reds; + int locked = 0; + + do { + switch (pbdp->state) { + case INITIALIZING: + pbdp->chunk = erts_alloc(ERTS_ALC_T_PROCS_CNKINF, + (sizeof(ErtsProcessesBifChunkInfo) + * processes_bif_tab_chunks)); + pbdp->tix = 0; + pbdp->pid_ix = 0; + + erts_smp_mtx_lock(&proc_tab_mtx); + locked = 1; + + ERTS_PROCS_DBG_TRACE(p->id, processes_bif_engine, init); + + pbdp->pid_sz = erts_process_count(); + pbdp->pid = erts_alloc(ERTS_ALC_T_PROCS_PIDS, + sizeof(Eterm)*pbdp->pid_sz); + +#if ERTS_PROCESSES_BIF_DEBUGLEVEL >= ERTS_PROCS_DBGLVL_CHK_FOUND_PIDS + pbdp->debug.pid_started = erts_alloc(ERTS_ALC_T_PROCS_PIDS, + sizeof(SysTimeval)*pbdp->pid_sz); +#endif + + ERTS_PROCS_DBG_SAVE_PIDS(pbdp); + + if (processes_bif_tab_chunks == 1) + pbdp->bif_invocation = NULL; + else { + /* + * We will have to access the table multiple times + * releasing the table lock in between chunks. + */ + pbdp->bif_invocation = erts_alloc(ERTS_ALC_T_PROCS_TPROC_EL, + sizeof(ErtsTermProcElement)); + pbdp->bif_invocation->ix = -1; + erts_get_emu_time(&pbdp->bif_invocation->u.bif_invocation.time); + ERTS_PROCS_DBG_CHK_TPLIST(); + + pbdp->bif_invocation->next = NULL; + if (saved_term_procs.end) { + pbdp->bif_invocation->prev = saved_term_procs.end; + saved_term_procs.end->next = pbdp->bif_invocation; + ERTS_PROCS_ASSERT(saved_term_procs.start); + } + else { + pbdp->bif_invocation->prev = NULL; + saved_term_procs.start = pbdp->bif_invocation; + } + saved_term_procs.end = pbdp->bif_invocation; + + ERTS_PROCS_DBG_CHK_TPLIST(); + + } + + pbdp->state = INSPECTING_TABLE; + /* Fall through */ + + case INSPECTING_TABLE: { + int ix = pbdp->tix; + int indices = ERTS_PROCESSES_BIF_TAB_CHUNK_SIZE; + int cix = ix / ERTS_PROCESSES_BIF_TAB_CHUNK_SIZE; + int end_ix = ix + indices; + SysTimeval *invocation_timep; + + invocation_timep = (pbdp->bif_invocation + ? &pbdp->bif_invocation->u.bif_invocation.time + : NULL); + + ERTS_PROCS_ASSERT(is_nil(*res_accp)); + if (!locked) { + erts_smp_mtx_lock(&proc_tab_mtx); + locked = 1; + } + + ERTS_SMP_LC_ASSERT(erts_lc_mtx_is_locked(&proc_tab_mtx)); + ERTS_PROCS_DBG_TRACE(p->id, processes_bif_engine, insp_table); + + if (cix != 0) + erts_get_emu_time(&pbdp->chunk[cix].time); + else if (pbdp->bif_invocation) + pbdp->chunk[0].time = *invocation_timep; + /* else: Time is irrelevant */ + + if (end_ix >= erts_max_processes) { + ERTS_PROCS_ASSERT(cix+1 == processes_bif_tab_chunks); + end_ix = erts_max_processes; + indices = end_ix - ix; + /* What to do when done with this chunk */ + pbdp->state = (processes_bif_tab_chunks == 1 + ? BUILDING_RESULT + : INSPECTING_TERMINATED_PROCESSES); + } + + for (; ix < end_ix; ix++) { + Process *rp = process_tab[ix]; + if (rp + && (!invocation_timep + || erts_cmp_timeval(&rp->started, + invocation_timep) < 0)) { + ERTS_PROCS_ASSERT(is_internal_pid(rp->id)); + pbdp->pid[pbdp->pid_ix] = rp->id; + +#if ERTS_PROCESSES_BIF_DEBUGLEVEL >= ERTS_PROCS_DBGLVL_CHK_FOUND_PIDS + pbdp->debug.pid_started[pbdp->pid_ix] = rp->started; +#endif + + pbdp->pid_ix++; + ERTS_PROCS_ASSERT(pbdp->pid_ix <= pbdp->pid_sz); + } + } + + pbdp->tix = end_ix; + + erts_smp_mtx_unlock(&proc_tab_mtx); + locked = 0; + + reds = indices/ERTS_PROCESSES_BIF_TAB_INSPECT_INDICES_PER_RED; + BUMP_REDS(p, reds); + + have_reds = ERTS_BIF_REDS_LEFT(p); + + if (have_reds && pbdp->state == INSPECTING_TABLE) { + ix = pbdp->tix; + indices = ERTS_PROCESSES_BIF_TAB_CHUNK_SIZE; + end_ix = ix + indices; + if (end_ix > erts_max_processes) { + end_ix = erts_max_processes; + indices = end_ix - ix; + } + + reds = indices/ERTS_PROCESSES_BIF_TAB_INSPECT_INDICES_PER_RED; + + /* Pretend we have no reds left if we haven't got enough + reductions to complete next chunk */ + if (reds > have_reds) + have_reds = 0; + } + + break; + } + + case INSPECTING_TERMINATED_PROCESSES: { + int i; + int max_reds; + int free_term_procs = 0; + SysTimeval *invocation_timep; + ErtsTermProcElement *tpep; + ErtsTermProcElement *free_list = NULL; + + tpep = pbdp->bif_invocation; + ERTS_PROCS_ASSERT(tpep); + invocation_timep = &tpep->u.bif_invocation.time; + + max_reds = have_reds = ERTS_BIF_REDS_LEFT(p); + if (max_reds > ERTS_PROCESSES_INSPECT_TERM_PROC_MAX_REDS) + max_reds = ERTS_PROCESSES_INSPECT_TERM_PROC_MAX_REDS; + + reds = 0; + erts_smp_mtx_lock(&proc_tab_mtx); + ERTS_PROCS_DBG_TRACE(p->id, processes_bif_engine, insp_term_procs); + + ERTS_PROCS_DBG_CHK_TPLIST(); + + if (tpep->prev) + tpep->prev->next = tpep->next; + else { + ERTS_PROCS_ASSERT(saved_term_procs.start == tpep); + saved_term_procs.start = tpep->next; + + if (saved_term_procs.start && saved_term_procs.start->ix >= 0) { + free_list = saved_term_procs.start; + free_term_procs = 1; + } + } + + if (tpep->next) + tpep->next->prev = tpep->prev; + else + saved_term_procs.end = tpep->prev; + + tpep = tpep->next; + + i = 0; + while (reds < max_reds && tpep) { + if (tpep->ix < 0) { + if (free_term_procs) { + ERTS_PROCS_ASSERT(free_list); + ERTS_PROCS_ASSERT(tpep->prev); + + tpep->prev->next = NULL; /* end of free_list */ + saved_term_procs.start = tpep; + tpep->prev = NULL; + free_term_procs = 0; + } + } + else { + int cix = tpep->ix/ERTS_PROCESSES_BIF_TAB_CHUNK_SIZE; + SysTimeval *chunk_timep = &pbdp->chunk[cix].time; + Eterm pid = tpep->u.process.pid; + ERTS_PROCS_ASSERT(is_internal_pid(pid)); + + if (erts_cmp_timeval(&tpep->u.process.spawned, + invocation_timep) < 0) { + if (erts_cmp_timeval(&tpep->u.process.exited, + chunk_timep) < 0) { + ERTS_PROCS_DBG_CHK_PID_NOT_FOUND(pbdp, + pid, + &tpep->u.process.spawned); + pbdp->pid[pbdp->pid_ix] = pid; +#if ERTS_PROCESSES_BIF_DEBUGLEVEL >= ERTS_PROCS_DBGLVL_CHK_FOUND_PIDS + pbdp->debug.pid_started[pbdp->pid_ix] = tpep->u.process.spawned; +#endif + pbdp->pid_ix++; + ERTS_PROCS_ASSERT(pbdp->pid_ix <= pbdp->pid_sz); + } + else { + ERTS_PROCS_DBG_CHK_PID_FOUND(pbdp, + pid, + &tpep->u.process.spawned); + } + } + else { + ERTS_PROCS_DBG_CHK_PID_NOT_FOUND(pbdp, + pid, + &tpep->u.process.spawned); + } + + i++; + if (i == ERTS_PROCESSES_BIF_INSPECT_TERM_PROC_PER_RED) { + reds++; + i = 0; + } + if (free_term_procs) + reds += ERTS_PROCESSES_BIF_TAB_FREE_TERM_PROC_REDS; + } + tpep = tpep->next; + } + + if (free_term_procs) { + ERTS_PROCS_ASSERT(free_list); + saved_term_procs.start = tpep; + if (!tpep) + saved_term_procs.end = NULL; + else { + ERTS_PROCS_ASSERT(tpep->prev); + tpep->prev->next = NULL; /* end of free_list */ + tpep->prev = NULL; + } + } + + if (!tpep) { + /* Done */ + ERTS_PROCS_ASSERT(pbdp->pid_ix == pbdp->pid_sz); + pbdp->state = BUILDING_RESULT; + pbdp->bif_invocation->next = free_list; + free_list = pbdp->bif_invocation; + pbdp->bif_invocation = NULL; + } + else { + /* Link in bif_invocation again where we left off */ + pbdp->bif_invocation->prev = tpep->prev; + pbdp->bif_invocation->next = tpep; + tpep->prev = pbdp->bif_invocation; + if (pbdp->bif_invocation->prev) + pbdp->bif_invocation->prev->next = pbdp->bif_invocation; + else { + ERTS_PROCS_ASSERT(saved_term_procs.start == tpep); + saved_term_procs.start = pbdp->bif_invocation; + } + } + + ERTS_PROCS_DBG_CHK_TPLIST(); + ERTS_PROCS_DBG_CHK_FREELIST(free_list); + erts_smp_mtx_unlock(&proc_tab_mtx); + + /* + * We do the actual free of term proc structures now when we + * have released the table lock instead of when we encountered + * them. This since free() isn't for free and we don't want to + * unnecessarily block other schedulers. + */ + while (free_list) { + tpep = free_list; + free_list = tpep->next; + erts_free(ERTS_ALC_T_PROCS_TPROC_EL, tpep); + } + + have_reds -= reds; + if (have_reds < 0) + have_reds = 0; + BUMP_REDS(p, reds); + break; + } + + case BUILDING_RESULT: { + int conses, ix, min_ix; + Eterm *hp; + Eterm res = *res_accp; + + ERTS_PROCS_DBG_VERIFY_PIDS(pbdp); + ERTS_PROCS_DBG_CHK_RESLIST(res); + + ERTS_PROCS_DBG_TRACE(p->id, processes_bif_engine, begin_build_res); + + have_reds = ERTS_BIF_REDS_LEFT(p); + conses = ERTS_PROCESSES_BIF_BUILD_RESULT_CONSES_PER_RED*have_reds; + min_ix = pbdp->pid_ix - conses; + if (min_ix < 0) { + min_ix = 0; + conses = pbdp->pid_ix; + } + + hp = HAlloc(p, conses*2); + ERTS_PROCS_DBG_SAVE_HEAP_ALLOC(pbdp, hp, conses*2); + + for (ix = pbdp->pid_ix - 1; ix >= min_ix; ix--) { + ERTS_PROCS_ASSERT(is_internal_pid(pbdp->pid[ix])); + res = CONS(hp, pbdp->pid[ix], res); + hp += 2; + } + + ERTS_PROCS_DBG_VERIFY_HEAP_ALLOC_USED(pbdp, hp); + + pbdp->pid_ix = min_ix; + if (min_ix == 0) + pbdp->state = RETURN_RESULT; + else { + pbdp->pid_sz = min_ix; + pbdp->pid = erts_realloc(ERTS_ALC_T_PROCS_PIDS, + pbdp->pid, + sizeof(Eterm)*pbdp->pid_sz); +#if ERTS_PROCESSES_BIF_DEBUGLEVEL >= ERTS_PROCS_DBGLVL_CHK_FOUND_PIDS + pbdp->debug.pid_started = erts_realloc(ERTS_ALC_T_PROCS_PIDS, + pbdp->debug.pid_started, + sizeof(SysTimeval)*pbdp->pid_sz); +#endif + } + reds = conses/ERTS_PROCESSES_BIF_BUILD_RESULT_CONSES_PER_RED; + BUMP_REDS(p, reds); + have_reds -= reds; + + ERTS_PROCS_DBG_CHK_RESLIST(res); + ERTS_PROCS_DBG_TRACE(p->id, processes_bif_engine, end_build_res); + *res_accp = res; + break; + } + case RETURN_RESULT: + cleanup_processes_bif_data(mbp); + return 1; + + default: + erl_exit(ERTS_ABORT_EXIT, + "erlang:processes/0: Invalid state: %d\n", + (int) pbdp->state); + } + + + } while (have_reds || pbdp->state == RETURN_RESULT); + + return 0; +} + +/* + * processes_trap/2 is a hidden BIF that processes/0 traps to. + */ + +static BIF_RETTYPE processes_trap(BIF_ALIST_2) +{ + Eterm res_acc; + Binary *mbp; + + /* + * This bif cannot be called from erlang code. It can only be + * trapped to from processes/0; therefore, a bad argument + * is a processes/0 internal error. + */ + + ERTS_PROCS_DBG_TRACE(BIF_P->id, processes_trap, call); + ERTS_PROCS_ASSERT(is_nil(BIF_ARG_1) || is_list(BIF_ARG_1)); + + res_acc = BIF_ARG_1; + + ERTS_PROCS_ASSERT(ERTS_TERM_IS_MAGIC_BINARY(BIF_ARG_2)); + + mbp = ((ProcBin *) binary_val(BIF_ARG_2))->val; + + ERTS_PROCS_ASSERT(ERTS_MAGIC_BIN_DESTRUCTOR(mbp) + == cleanup_processes_bif_data); + ERTS_PROCS_ASSERT( + ((ErtsProcessesBifData *) ERTS_MAGIC_BIN_DATA(mbp))->debug.caller + == BIF_P->id); + + if (processes_bif_engine(BIF_P, &res_acc, mbp)) { + ERTS_PROCS_DBG_TRACE(BIF_P->id, processes_trap, return); + BIF_RET(res_acc); + } + else { + ERTS_PROCS_DBG_TRACE(BIF_P->id, processes_trap, trap); + ERTS_BIF_YIELD2(&processes_trap_export, BIF_P, res_acc, BIF_ARG_2); + } +} + + + +/* + * The actual processes/0 BIF. + */ + +BIF_RETTYPE processes_0(BIF_ALIST_0) +{ + /* + * A requirement: The list of pids returned should be a consistent + * snapshot of all processes existing at some point + * in time during the execution of processes/0. Since + * processes might terminate while processes/0 is + * executing, we have to keep track of terminated + * processes and add them to the result. We also + * ignore processes created after processes/0 has + * begun executing. + */ + Eterm res_acc = NIL; + Binary *mbp = erts_create_magic_binary(sizeof(ErtsProcessesBifData), + cleanup_processes_bif_data); + ErtsProcessesBifData *pbdp = ERTS_MAGIC_BIN_DATA(mbp); + + ERTS_PROCS_DBG_TRACE(BIF_P->id, processes_0, call); + pbdp->state = INITIALIZING; + ERTS_PROCS_DBG_INIT(BIF_P, pbdp); + + if (ERTS_BIF_REDS_LEFT(BIF_P) >= ERTS_PROCESSES_BIF_MIN_START_REDS + && processes_bif_engine(BIF_P, &res_acc, mbp)) { + erts_bin_free(mbp); + ERTS_PROCS_DBG_CHK_RESLIST(res_acc); + ERTS_PROCS_DBG_TRACE(BIF_P->id, processes_0, return); + BIF_RET(res_acc); + } + else { + Eterm *hp; + Eterm magic_bin; + ERTS_PROCS_DBG_CHK_RESLIST(res_acc); + hp = HAlloc(BIF_P, PROC_BIN_SIZE); + ERTS_PROCS_DBG_SAVE_HEAP_ALLOC(pbdp, hp, PROC_BIN_SIZE); + magic_bin = erts_mk_magic_binary_term(&hp, &MSO(BIF_P), mbp); + ERTS_PROCS_DBG_VERIFY_HEAP_ALLOC_USED(pbdp, hp); + ERTS_PROCS_DBG_TRACE(BIF_P->id, processes_0, trap); + ERTS_BIF_YIELD2(&processes_trap_export, BIF_P, res_acc, magic_bin); + } +} + +static void +init_processes_bif(void) +{ + saved_term_procs.start = NULL; + saved_term_procs.end = NULL; + processes_bif_tab_chunks = (((erts_max_processes - 1) + / ERTS_PROCESSES_BIF_TAB_CHUNK_SIZE) + + 1); + + /* processes_trap/2 is a hidden BIF that the processes/0 BIF traps to. */ + sys_memset((void *) &processes_trap_export, 0, sizeof(Export)); + processes_trap_export.address = &processes_trap_export.code[3]; + processes_trap_export.code[0] = am_erlang; + processes_trap_export.code[1] = am_processes_trap; + processes_trap_export.code[2] = 2; + processes_trap_export.code[3] = (Eterm) em_apply_bif; + processes_trap_export.code[4] = (Eterm) &processes_trap; + +#if ERTS_PROCESSES_BIF_DEBUGLEVEL >= ERTS_PROCS_DBGLVL_CHK_TERM_PROC_LIST + erts_get_emu_time(&debug_tv_start); +#endif + +} + +/* + * Debug stuff + */ + +Eterm +erts_debug_processes(Process *c_p) +{ + /* This is the old processes/0 BIF. */ + int i; + Uint need; + Eterm res; + Eterm* hp; + Process *p; +#ifdef DEBUG + Eterm *hp_end; +#endif + + erts_smp_mtx_lock(&proc_tab_mtx); + + res = NIL; + need = erts_process_count() * 2; + hp = HAlloc(c_p, need); /* we need two heap words for each pid */ +#ifdef DEBUG + hp_end = hp + need; +#endif + + /* make the list by scanning bakward */ + + + for (i = erts_max_processes-1; i >= 0; i--) { + if ((p = process_tab[i]) != NULL) { + res = CONS(hp, process_tab[i]->id, res); + hp += 2; + } + } + ASSERT(hp == hp_end); + + erts_smp_mtx_unlock(&proc_tab_mtx); + + return res; +} + +Eterm +erts_debug_processes_bif_info(Process *c_p) +{ + ERTS_DECL_AM(processes_bif_info); + Eterm elements[] = { + AM_processes_bif_info, + make_small((Uint) ERTS_PROCESSES_BIF_MIN_START_REDS), + make_small((Uint) processes_bif_tab_chunks), + make_small((Uint) ERTS_PROCESSES_BIF_TAB_CHUNK_SIZE), + make_small((Uint) ERTS_PROCESSES_BIF_TAB_INSPECT_INDICES_PER_RED), + make_small((Uint) ERTS_PROCESSES_BIF_TAB_FREE_TERM_PROC_REDS), + make_small((Uint) ERTS_PROCESSES_BIF_INSPECT_TERM_PROC_PER_RED), + make_small((Uint) ERTS_PROCESSES_INSPECT_TERM_PROC_MAX_REDS), + make_small((Uint) ERTS_PROCESSES_BIF_BUILD_RESULT_CONSES_PER_RED), + make_small((Uint) ERTS_PROCESSES_BIF_DEBUGLEVEL) + }; + Uint sz = 0; + Eterm *hp; + (void) erts_bld_tuplev(NULL, &sz, sizeof(elements)/sizeof(Eterm), elements); + hp = HAlloc(c_p, sz); + return erts_bld_tuplev(&hp, NULL, sizeof(elements)/sizeof(Eterm), elements); +} + +#if ERTS_PROCESSES_BIF_DEBUGLEVEL >= ERTS_PROCS_DBGLVL_CHK_FOUND_PIDS +static void +debug_processes_check_found_pid(ErtsProcessesBifData *pbdp, + Eterm pid, + SysTimeval *tvp, + int pid_should_be_found) +{ + int i; + for (i = 0; i < pbdp->pid_ix; i++) { + if (pbdp->pid[i] == pid + && pbdp->debug.pid_started[i].tv_sec == tvp->tv_sec + && pbdp->debug.pid_started[i].tv_usec == tvp->tv_usec) { + ERTS_PROCS_ASSERT(pid_should_be_found); + return; + } + } + ERTS_PROCS_ASSERT(!pid_should_be_found); +} +#endif + +#if ERTS_PROCESSES_BIF_DEBUGLEVEL >= ERTS_PROCS_DBGLVL_CHK_RESLIST +static void +debug_processes_check_res_list(Eterm list) +{ + while (is_list(list)) { + Eterm* consp = list_val(list); + Eterm hd = CAR(consp); + ERTS_PROCS_ASSERT(is_internal_pid(hd)); + list = CDR(consp); + } + + ERTS_PROCS_ASSERT(is_nil(list)); +} +#endif + +#if ERTS_PROCESSES_BIF_DEBUGLEVEL >= ERTS_PROCS_DBGLVL_CHK_PIDS + +static void +debug_processes_save_all_pids(ErtsProcessesBifData *pbdp) +{ + int ix, tix, cpix; + pbdp->debug.correct_pids_verified = 0; + pbdp->debug.correct_pids = erts_alloc(ERTS_ALC_T_PROCS_PIDS, + sizeof(Eterm)*pbdp->pid_sz); + + for (tix = 0, cpix = 0; tix < erts_max_processes; tix++) { + Process *rp = process_tab[tix]; + if (rp) { + ERTS_PROCS_ASSERT(is_internal_pid(rp->id)); + pbdp->debug.correct_pids[cpix++] = rp->id; + ERTS_PROCS_ASSERT(cpix <= pbdp->pid_sz); + } + } + ERTS_PROCS_ASSERT(cpix == pbdp->pid_sz); + + for (ix = 0; ix < pbdp->pid_sz; ix++) + pbdp->pid[ix] = make_small(ix); +} + +static void +debug_processes_verify_all_pids(ErtsProcessesBifData *pbdp) +{ + int ix, cpix; + + ERTS_PROCS_ASSERT(pbdp->pid_ix == pbdp->pid_sz); + + for (ix = 0; ix < pbdp->pid_sz; ix++) { + int found = 0; + Eterm pid = pbdp->pid[ix]; + ERTS_PROCS_ASSERT(is_internal_pid(pid)); + for (cpix = ix; cpix < pbdp->pid_sz; cpix++) { + if (pbdp->debug.correct_pids[cpix] == pid) { + pbdp->debug.correct_pids[cpix] = NIL; + found = 1; + break; + } + } + if (!found) { + for (cpix = 0; cpix < ix; cpix++) { + if (pbdp->debug.correct_pids[cpix] == pid) { + pbdp->debug.correct_pids[cpix] = NIL; + found = 1; + break; + } + } + } + ERTS_PROCS_ASSERT(found); + } + pbdp->debug.correct_pids_verified = 1; + + erts_free(ERTS_ALC_T_PROCS_PIDS, pbdp->debug.correct_pids); + pbdp->debug.correct_pids = NULL; +} +#endif /* ERTS_PROCESSES_BIF_DEBUGLEVEL >= ERTS_PROCS_DBGLVL_CHK_PIDS */ + +#if ERTS_PROCESSES_BIF_DEBUGLEVEL >= ERTS_PROCS_DBGLVL_CHK_TERM_PROC_LIST +static void +debug_processes_check_term_proc_list(void) +{ + ERTS_SMP_LC_ASSERT(erts_lc_mtx_is_locked(&proc_tab_mtx)); + if (!saved_term_procs.start) + ERTS_PROCS_ASSERT(!saved_term_procs.end); + else { + SysTimeval tv_now; + SysTimeval *prev_xtvp = NULL; + ErtsTermProcElement *tpep; + erts_get_emu_time(&tv_now); + + for (tpep = saved_term_procs.start; tpep; tpep = tpep->next) { + if (!tpep->prev) + ERTS_PROCS_ASSERT(saved_term_procs.start == tpep); + else + ERTS_PROCS_ASSERT(tpep->prev->next == tpep); + if (!tpep->next) + ERTS_PROCS_ASSERT(saved_term_procs.end == tpep); + else + ERTS_PROCS_ASSERT(tpep->next->prev == tpep); + if (tpep->ix < 0) { + SysTimeval *tvp = &tpep->u.bif_invocation.time; + ERTS_PROCS_ASSERT(erts_cmp_timeval(&debug_tv_start, tvp) < 0 + && erts_cmp_timeval(tvp, &tv_now) < 0); + } + else { + SysTimeval *stvp = &tpep->u.process.spawned; + SysTimeval *xtvp = &tpep->u.process.exited; + + ERTS_PROCS_ASSERT(erts_cmp_timeval(&debug_tv_start, + stvp) < 0); + ERTS_PROCS_ASSERT(erts_cmp_timeval(stvp, xtvp) < 0); + if (prev_xtvp) + ERTS_PROCS_ASSERT(erts_cmp_timeval(prev_xtvp, xtvp) < 0); + prev_xtvp = xtvp; + ERTS_PROCS_ASSERT(is_internal_pid(tpep->u.process.pid)); + ERTS_PROCS_ASSERT(tpep->ix + == internal_pid_index(tpep->u.process.pid)); + } + } + + } +} + +static void +debug_processes_check_term_proc_free_list(ErtsTermProcElement *free_list) +{ + if (saved_term_procs.start) { + ErtsTermProcElement *ftpep; + ErtsTermProcElement *tpep; + + for (ftpep = free_list; ftpep; ftpep = ftpep->next) { + for (tpep = saved_term_procs.start; tpep; tpep = tpep->next) + ERTS_PROCS_ASSERT(ftpep != tpep); + } + } +} + +#endif + +#if ERTS_PROCESSES_BIF_DEBUGLEVEL != 0 + +static void +debug_processes_assert_error(char* expr, char* file, int line) +{ + fflush(stdout); + erts_fprintf(stderr, "%s:%d: Assertion failed: %s\n", file, line, expr); + fflush(stderr); + abort(); +} + +#endif + +/* *\ + * End of the processes/0 BIF implementation. * +\* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ diff --git a/erts/emulator/beam/erl_process.h b/erts/emulator/beam/erl_process.h new file mode 100644 index 0000000000..7bae1e4efc --- /dev/null +++ b/erts/emulator/beam/erl_process.h @@ -0,0 +1,1495 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifndef __PROCESS_H__ +#define __PROCESS_H__ + +#undef ERTS_INCLUDE_SCHEDULER_INTERNALS +#if (defined(ERL_PROCESS_C__) \ + || defined(ERL_PORT_TASK_C__) \ + || (ERTS_GLB_INLINE_INCL_FUNC_DEF \ + && defined(ERTS_DO_INCL_GLB_INLINE_FUNC_DEF))) +#define ERTS_INCLUDE_SCHEDULER_INTERNALS +#endif + +typedef struct process Process; + +#include "sys.h" + +#define ERTS_PROCESS_LOCK_ONLY_PROC_LOCK_TYPE__ +#include "erl_process_lock.h" /* Only pull out important types... */ +#undef ERTS_PROCESS_LOCK_ONLY_PROC_LOCK_TYPE__ + +#include "erl_vm.h" +#include "erl_smp.h" +#include "erl_message.h" +#include "erl_process_dict.h" +#include "erl_node_container_utils.h" +#include "erl_node_tables.h" +#include "erl_monitors.h" +#include "erl_bif_timer.h" +#include "erl_time.h" +#include "erl_atom_table.h" +#include "external.h" + +#ifdef HIPE +#include "hipe_process.h" +#endif + +struct ErtsNodesMonitor_; +struct port; + +#define ERTS_MAX_NO_OF_SCHEDULERS 1024 + +#define ERTS_DEFAULT_MAX_PROCESSES (1 << 15) + +#define ERTS_HEAP_ALLOC(Type, Size) \ + erts_alloc((Type), (Size)) + +#define ERTS_HEAP_REALLOC(Type, Ptr, OldSize, NewSize) \ + erts_realloc((Type), (Ptr), (NewSize)) + +#define ERTS_HEAP_FREE(Type, Ptr, Size) \ + erts_free((Type), (Ptr)) + +#define INITIAL_MOD 0 +#define INITIAL_FUN 1 +#define INITIAL_ARI 2 + +#include "export.h" + +struct saved_calls { + int len; + int n; + int cur; + Export *ct[1]; +}; + +extern Export exp_send, exp_receive, exp_timeout; +extern Uint erts_no_schedulers; +extern Uint erts_no_run_queues; +extern int erts_sched_thread_suggested_stack_size; +#define ERTS_SCHED_THREAD_MIN_STACK_SIZE 4 /* Kilo words */ +#define ERTS_SCHED_THREAD_MAX_STACK_SIZE 8192 /* Kilo words */ + +#ifdef ERTS_SMP +#include "erl_bits.h" +#endif + +/* process priorities */ +#define PRIORITY_MAX 0 +#define PRIORITY_HIGH 1 +#define PRIORITY_NORMAL 2 +#define PRIORITY_LOW 3 +#define ERTS_NO_PROC_PRIO_LEVELS 4 + +#define ERTS_PORT_PRIO_LEVEL ERTS_NO_PROC_PRIO_LEVELS + +#define ERTS_RUNQ_FLGS_PROCS_QMASK \ + ((((Uint32) 1) << ERTS_NO_PROC_PRIO_LEVELS) - 1) + +#define ERTS_NO_PRIO_LEVELS (ERTS_NO_PROC_PRIO_LEVELS + 1) +#define ERTS_RUNQ_FLGS_MIGRATE_QMASK \ + ((((Uint32) 1) << ERTS_NO_PRIO_LEVELS) - 1) + +#define ERTS_RUNQ_FLGS_EMIGRATE_SHFT \ + ERTS_NO_PROC_PRIO_LEVELS +#define ERTS_RUNQ_FLGS_IMMIGRATE_SHFT \ + (ERTS_RUNQ_FLGS_EMIGRATE_SHFT + ERTS_NO_PRIO_LEVELS) +#define ERTS_RUNQ_FLGS_EVACUATE_SHFT \ + (ERTS_RUNQ_FLGS_IMMIGRATE_SHFT + ERTS_NO_PRIO_LEVELS) +#define ERTS_RUNQ_FLGS_EMIGRATE_QMASK \ + (ERTS_RUNQ_FLGS_MIGRATE_QMASK << ERTS_RUNQ_FLGS_EMIGRATE_SHFT) +#define ERTS_RUNQ_FLGS_IMMIGRATE_QMASK \ + (ERTS_RUNQ_FLGS_MIGRATE_QMASK << ERTS_RUNQ_FLGS_IMMIGRATE_SHFT) +#define ERTS_RUNQ_FLGS_EVACUATE_QMASK \ + (ERTS_RUNQ_FLGS_MIGRATE_QMASK << ERTS_RUNQ_FLGS_EVACUATE_SHFT) + +#define ERTS_RUNQ_FLG_BASE2 \ + (ERTS_RUNQ_FLGS_EVACUATE_SHFT + ERTS_NO_PRIO_LEVELS) + +#define ERTS_RUNQ_FLG_OUT_OF_WORK \ + (((Uint32) 1) << (ERTS_RUNQ_FLG_BASE2 + 0)) +#define ERTS_RUNQ_FLG_HALFTIME_OUT_OF_WORK \ + (((Uint32) 1) << (ERTS_RUNQ_FLG_BASE2 + 1)) +#define ERTS_RUNQ_FLG_SUSPENDED \ + (((Uint32) 1) << (ERTS_RUNQ_FLG_BASE2 + 2)) +#define ERTS_RUNQ_FLG_SHARED_RUNQ \ + (((Uint32) 1) << (ERTS_RUNQ_FLG_BASE2 + 3)) +#define ERTS_RUNQ_FLG_CHK_CPU_BIND \ + (((Uint32) 1) << (ERTS_RUNQ_FLG_BASE2 + 4)) +#define ERTS_RUNQ_FLG_INACTIVE \ + (((Uint32) 1) << (ERTS_RUNQ_FLG_BASE2 + 5)) + +#define ERTS_RUNQ_FLGS_MIGRATION_QMASKS \ + (ERTS_RUNQ_FLGS_EMIGRATE_QMASK \ + | ERTS_RUNQ_FLGS_IMMIGRATE_QMASK \ + | ERTS_RUNQ_FLGS_EVACUATE_QMASK) +#define ERTS_RUNQ_FLGS_MIGRATION_INFO \ + (ERTS_RUNQ_FLGS_MIGRATION_QMASKS \ + | ERTS_RUNQ_FLG_INACTIVE \ + | ERTS_RUNQ_FLG_OUT_OF_WORK \ + | ERTS_RUNQ_FLG_HALFTIME_OUT_OF_WORK) + +#define ERTS_RUNQ_FLG_EMIGRATE(PRIO) \ + (((Uint32) 1) << (ERTS_RUNQ_FLGS_EMIGRATE_SHFT + (PRIO))) +#define ERTS_CHK_RUNQ_FLG_EMIGRATE(FLGS, PRIO) \ + ((FLGS) & ERTS_RUNQ_FLG_EMIGRATE((PRIO))) +#define ERTS_SET_RUNQ_FLG_EMIGRATE(FLGS, PRIO) \ + ((FLGS) |= ERTS_RUNQ_FLG_EMIGRATE((PRIO))) +#define ERTS_UNSET_RUNQ_FLG_EMIGRATE(FLGS, PRIO) \ + ((FLGS) &= ~ERTS_RUNQ_FLG_EMIGRATE((PRIO))) + +#define ERTS_RUNQ_FLG_IMMIGRATE(PRIO) \ + (((Uint32) 1) << (ERTS_RUNQ_FLGS_IMMIGRATE_SHFT + (PRIO))) +#define ERTS_CHK_RUNQ_FLG_IMMIGRATE(FLGS, PRIO) \ + ((FLGS) & ERTS_RUNQ_FLG_IMMIGRATE((PRIO))) +#define ERTS_SET_RUNQ_FLG_IMMIGRATE(FLGS, PRIO) \ + ((FLGS) |= ERTS_RUNQ_FLG_IMMIGRATE((PRIO))) +#define ERTS_UNSET_RUNQ_FLG_IMMIGRATE(FLGS, PRIO) \ + ((FLGS) &= ~ERTS_RUNQ_FLG_IMMIGRATE((PRIO))) + +#define ERTS_RUNQ_FLG_EVACUATE(PRIO) \ + (((Uint32) 1) << (ERTS_RUNQ_FLGS_EVACUATE_SHFT + (PRIO))) +#define ERTS_CHK_RUNQ_FLG_EVACUATE(FLGS, PRIO) \ + ((FLGS) & ERTS_RUNQ_FLG_EVACUATE((PRIO))) +#define ERTS_SET_RUNQ_FLG_EVACUATE(FLGS, PRIO) \ + ((FLGS) |= ERTS_RUNQ_FLG_EVACUATE((PRIO))) +#define ERTS_UNSET_RUNQ_FLG_EVACUATE(FLGS, PRIO) \ + ((FLGS) &= ~ERTS_RUNQ_FLG_EVACUATE((PRIO))) + +#define ERTS_RUNQ_IFLG_SUSPENDED (((long) 1) << 0) +#define ERTS_RUNQ_IFLG_NONEMPTY (((long) 1) << 1) + + +#ifdef DEBUG +# ifdef ARCH_64 +# define ERTS_DBG_SET_INVALID_RUNQP(RQP, N) \ + (*((char **) &(RQP)) = (char *) (0xdeadbeefdead0003 | ((N) << 4))) +# define ERTS_DBG_VERIFY_VALID_RUNQP(RQP) \ +do { \ + ASSERT((RQP) != NULL); \ + ASSERT(((((Uint) (RQP)) & ((Uint) 0x3))) == ((Uint) 0)); \ + ASSERT((((Uint) (RQP)) & ~((Uint) 0xffff)) != ((Uint) 0xdeadbeefdead0000));\ +} while (0) +# else +# define ERTS_DBG_SET_INVALID_RUNQP(RQP, N) \ + (*((char **) &(RQP)) = (char *) (0xdead0003 | ((N) << 4))) +# define ERTS_DBG_VERIFY_VALID_RUNQP(RQP) \ +do { \ + ASSERT((RQP) != NULL); \ + ASSERT(((((Uint) (RQP)) & ((Uint) 1))) == ((Uint) 0)); \ + ASSERT((((Uint) (RQP)) & ~((Uint) 0xffff)) != ((Uint) 0xdead0000)); \ +} while (0) +# endif +#else +# define ERTS_DBG_SET_INVALID_RUNQP(RQP, N) +# define ERTS_DBG_VERIFY_VALID_RUNQP(RQP) +#endif + +typedef enum { + ERTS_SCHDLR_SSPND_DONE_MSCHED_BLOCKED, + ERTS_SCHDLR_SSPND_YIELD_DONE_MSCHED_BLOCKED, + ERTS_SCHDLR_SSPND_DONE, + ERTS_SCHDLR_SSPND_YIELD_RESTART, + ERTS_SCHDLR_SSPND_YIELD_DONE, + ERTS_SCHDLR_SSPND_EINVAL +} ErtsSchedSuspendResult; + +typedef enum { + ERTS_MIGRATE_SUCCESS, + ERTS_MIGRATE_FAILED_NOT_IN_RUNQ, + ERTS_MIGRATE_FAILED_RUNQ_CHANGED, + ERTS_MIGRATE_FAILED_RUNQ_SUSPENDED +} ErtsMigrateResult; + +/* times to reschedule low prio process before running */ +#define RESCHEDULE_LOW 8 + +#define ERTS_MAX_MISC_OPS 5 + +#define ERTS_FULL_REDS_HISTORY_AVG_SHFT 3 +#define ERTS_FULL_REDS_HISTORY_SIZE \ + ((1 << ERTS_FULL_REDS_HISTORY_AVG_SHFT) - 1) + +typedef struct ErtsProcList_ ErtsProcList; +struct ErtsProcList_ { + Eterm pid; + SysTimeval started; + ErtsProcList* next; +}; + +typedef struct ErtsMiscOpList_ ErtsMiscOpList; +struct ErtsMiscOpList_ { + ErtsMiscOpList *next; + void (*func)(void *arg); + void *arg; +}; + +typedef struct { + Process* first; + Process* last; +} ErtsRunPrioQueue; + +typedef struct ErtsSchedulerData_ ErtsSchedulerData; + +typedef struct ErtsRunQueue_ ErtsRunQueue; + +typedef struct { + int len; + int max_len; + int reds; + struct { + struct { + int this; + int other; + } limit; + ErtsRunQueue *runq; + } migrate; +} ErtsRunQueueInfo; + +struct ErtsRunQueue_ { + int ix; + erts_smp_atomic_t info_flags; + + erts_smp_mtx_t mtx; + erts_smp_cnd_t cnd; + + erts_smp_atomic_t spin_waiter; + erts_smp_atomic_t spin_wake; + + ErtsSchedulerData *scheduler; + int waiting; /* < 0 in sys schedule; > 0 on cnd variable */ + int woken; + Uint32 flags; + int check_balance_reds; + int full_reds_history_sum; + int full_reds_history[ERTS_FULL_REDS_HISTORY_SIZE]; + int out_of_work_count; + int max_len; + int len; + int wakeup_other; + int wakeup_other_reds; + + struct { + int len; + ErtsProcList *pending_exiters; + Uint context_switches; + Uint reductions; + + ErtsRunQueueInfo prio_info[ERTS_NO_PROC_PRIO_LEVELS]; + + /* We use the same prio queue for low and + normal prio processes */ + ErtsRunPrioQueue prio[ERTS_NO_PROC_PRIO_LEVELS-1]; + } procs; + + struct { + ErtsMiscOpList *start; + ErtsMiscOpList *end; + ErtsRunQueue *evac_runq; + } misc; + + struct { + ErtsRunQueueInfo info; + struct port *start; + struct port *end; + } ports; +}; + +typedef union { + ErtsRunQueue runq; + char align[ERTS_ALC_CACHE_LINE_ALIGN_SIZE(sizeof(ErtsRunQueue))]; +} ErtsAlignedRunQueue; + +extern ErtsAlignedRunQueue *erts_aligned_run_queues; +extern ErtsRunQueue *erts_common_run_queue; + +#define ERTS_PROC_REDUCTIONS_EXECUTED(RQ, PRIO, REDS, AREDS) \ +do { \ + (RQ)->procs.reductions += (AREDS); \ + (RQ)->procs.prio_info[p->prio].reds += (REDS); \ + (RQ)->check_balance_reds -= (REDS); \ + (RQ)->wakeup_other_reds += (AREDS); \ +} while (0) + +#define ERTS_PORT_REDUCTIONS_EXECUTED(RQ, REDS) \ +do { \ + (RQ)->ports.info.reds += (REDS); \ + (RQ)->check_balance_reds -= (REDS); \ + (RQ)->wakeup_other_reds += (REDS); \ +} while (0) + +struct ErtsSchedulerData_ { + +#ifdef ERTS_SMP + ethr_tid tid; /* Thread id */ + Eterm save_reg[ERTS_X_REGS_ALLOCATED]; /* X registers */ + FloatDef freg[MAX_REG]; /* Floating point registers. */ + struct erl_bits_state erl_bits_state; /* erl_bits.c state */ + void *match_pseudo_process; /* erl_db_util.c:db_prog_match() */ + Process *free_process; +#endif + + Process *current_process; + Uint no; /* Scheduler number */ + struct port *current_port; + ErtsRunQueue *run_queue; + int virtual_reds; + int cpu_id; /* >= 0 when bound */ + + ErtsAtomCacheMap atom_cache_map; + +#ifdef ERTS_SMP + /* NOTE: These fields are modified under held mutexes by other threads */ +#ifdef ERTS_SMP_SCHEDULERS_NEED_TO_CHECK_CHILDREN + int check_children; /* run queue mutex */ + int blocked_check_children; /* schdlr_sspnd mutex */ +#endif + erts_smp_atomic_t suspended; /* Only used when common run queue */ + erts_smp_atomic_t chk_cpu_bind; /* Only used when common run queue */ +#endif +}; + +#ifndef ERTS_SMP +extern ErtsSchedulerData *erts_scheduler_data; +#endif + +/* + * Process Specific Data. + * + * NOTE: Only use PSD for very rarely used data. + */ + +#define ERTS_PSD_ERROR_HANDLER 0 +#define ERTS_PSD_SAVED_CALLS_BUF 1 +#define ERTS_PSD_SCHED_ID 2 +#define ERTS_PSD_DIST_ENTRY 3 + +#define ERTS_PSD_SIZE 4 + +typedef struct { + void *data[ERTS_PSD_SIZE]; +} ErtsPSD; + +#ifdef ERTS_ENABLE_LOCK_CHECK +#define ERTS_LC_PSD_ANY_LOCK (~ERTS_PROC_LOCKS_ALL) + +#define ERTS_PSD_ERROR_HANDLER_BUF_GET_LOCKS ERTS_PROC_LOCK_MAIN +#define ERTS_PSD_ERROR_HANDLER_BUF_SET_LOCKS ERTS_PROC_LOCK_MAIN + +#define ERTS_PSD_SAVED_CALLS_BUF_GET_LOCKS ERTS_PROC_LOCK_MAIN +#define ERTS_PSD_SAVED_CALLS_BUF_SET_LOCKS ERTS_PROC_LOCK_MAIN + +#define ERTS_PSD_SCHED_ID_GET_LOCKS ERTS_PROC_LOCK_STATUS +#define ERTS_PSD_SCHED_ID_SET_LOCKS ERTS_PROC_LOCK_STATUS + +#define ERTS_PSD_DIST_ENTRY_GET_LOCKS ERTS_PROC_LOCK_MAIN +#define ERTS_PSD_DIST_ENTRY_SET_LOCKS ERTS_PROC_LOCK_MAIN + +typedef struct { + ErtsProcLocks get_locks; + ErtsProcLocks set_locks; +} ErtsLcPSDLocks; + +extern ErtsLcPSDLocks erts_psd_required_locks[ERTS_PSD_SIZE]; + +#endif + +#define ERTS_SCHED_STAT_MODIFY_DISABLE 1 +#define ERTS_SCHED_STAT_MODIFY_ENABLE 2 +#define ERTS_SCHED_STAT_MODIFY_CLEAR 3 + +typedef struct { + erts_smp_spinlock_t lock; + int enabled; + struct { + Eterm name; + Uint total_executed; + Uint executed; + Uint total_migrated; + Uint migrated; + } prio[ERTS_NO_PRIO_LEVELS]; +} erts_sched_stat_t; + +extern erts_sched_stat_t erts_sched_stat; + +typedef struct { + Eterm reason; + ErlHeapFragment *bp; +} ErtsPendExit; + +#ifdef ERTS_SMP + +typedef struct ErtsPendingSuspend_ ErtsPendingSuspend; +struct ErtsPendingSuspend_ { + ErtsPendingSuspend *next; + ErtsPendingSuspend *end; + Eterm pid; + void (*handle_func)(Process *suspendee, + ErtsProcLocks suspendee_locks, + int suspendee_alive, + Eterm pid); +}; + +#endif + +/* Defines to ease the change of memory architecture */ +# define HEAP_START(p) (p)->heap +# define HEAP_TOP(p) (p)->htop +# define HEAP_LIMIT(p) (p)->stop +# define HEAP_END(p) (p)->hend +# define HEAP_SIZE(p) (p)->heap_sz +# define STACK_START(p) (p)->hend +# define STACK_TOP(p) (p)->stop +# define STACK_END(p) (p)->htop +# define HIGH_WATER(p) (p)->high_water +# define OLD_HEND(p) (p)->old_hend +# define OLD_HTOP(p) (p)->old_htop +# define OLD_HEAP(p) (p)->old_heap +# define GEN_GCS(p) (p)->gen_gcs +# define MAX_GEN_GCS(p) (p)->max_gen_gcs +# define FLAGS(p) (p)->flags +# define MBUF(p) (p)->mbuf +# define HALLOC_MBUF(p) (p)->halloc_mbuf +# define MBUF_SIZE(p) (p)->mbuf_sz +# define MSO(p) (p)->off_heap +# define MIN_HEAP_SIZE(p) (p)->min_heap_size + +# define BIN_VHEAP_SZ(p) (p)->bin_vheap_sz +# define BIN_OLD_VHEAP_SZ(p) (p)->bin_old_vheap_sz +# define BIN_OLD_VHEAP(p) (p)->bin_old_vheap + +struct process { + /* All fields in the PCB that differs between different heap + * architectures, have been moved to the end of this struct to + * make sure that as few offsets as possible differ. Different + * offsets between memory architectures in this struct, means that + * native code have to use functions instead of constants. + */ + + Eterm* htop; /* Heap top */ + Eterm* stop; /* Stack top */ + Eterm* heap; /* Heap start */ + Eterm* hend; /* Heap end */ + Uint heap_sz; /* Size of heap in words */ + Uint min_heap_size; /* Minimum size of heap (in words). */ + +#if !defined(NO_FPE_SIGNALS) + volatile unsigned long fp_exception; +#endif + +#ifdef HIPE + /* HiPE-specific process fields. Put it early in struct process, + to enable smaller & faster addressing modes on the x86. */ + struct hipe_process_state hipe; +#endif + + /* + * Saved x registers. + */ + Uint arity; /* Number of live argument registers (only valid + * when process is *not* running). + */ + Eterm* arg_reg; /* Pointer to argument registers. */ + unsigned max_arg_reg; /* Maximum number of argument registers available. */ + Eterm def_arg_reg[6]; /* Default array for argument registers. */ + + Eterm* cp; /* Continuation pointer (for threaded code). */ + Eterm* i; /* Program counter for threaded code. */ + Sint catches; /* Number of catches on stack */ + Sint fcalls; /* + * Number of reductions left to execute. + * Only valid for the current process. + */ + Uint32 status; /* process STATE */ + Uint32 gcstatus; /* process gc STATE */ + Uint32 rstatus; /* process resume STATE */ + Uint32 rcount; /* suspend count */ + Eterm id; /* The pid of this process */ + int prio; /* Priority of process */ + int skipped; /* Times a low prio process has been rescheduled */ + Uint reds; /* No of reductions for this process */ + Eterm tracer_proc; /* If proc is traced, this is the tracer + (can NOT be boxed) */ + Uint trace_flags; /* Trace flags (used to be in flags) */ + Eterm group_leader; /* Pid in charge + (can be boxed) */ + Uint flags; /* Trap exit, etc (no trace flags anymore) */ + Eterm fvalue; /* Exit & Throw value (failure reason) */ + Uint freason; /* Reason for detected failure */ + Eterm ftrace; /* Latest exception stack trace dump */ + + Process *next; /* Pointer to next process in run queue */ + Process *prev; /* Pointer to prev process in run queue */ + + struct reg_proc *reg; /* NULL iff not registered */ + ErtsLink *nlinks; + ErtsMonitor *monitors; /* The process monitors, both ends */ + + struct ErtsNodesMonitor_ *nodes_monitors; + + ErtsSuspendMonitor *suspend_monitors; /* Processes suspended by + this process via + erlang:suspend_process/1 */ + + ErlMessageQueue msg; /* Message queue */ + + ErtsBifTimer *bif_timers; /* Bif timers aiming at this process */ + + ProcDict *dictionary; /* Process dictionary, may be NULL */ + + Uint seq_trace_clock; + Uint seq_trace_lastcnt; + Eterm seq_trace_token; /* Sequential trace token (tuple size 5 see below) */ + + Eterm initial[3]; /* Initial module(0), function(1), arity(2) */ + Eterm* current; /* Current Erlang function: + * module(0), function(1), arity(2) + * (module and functions are tagged atoms; + * arity an untagged integer). + */ + + /* + * Information mainly for post-mortem use (erl crash dump). + */ + Eterm parent; /* Pid of process that created this process. */ + SysTimeval started; /* Time when started. */ + + + /* This is the place, where all fields that differs between memory + * architectures, have gone to. + */ + + Eterm *high_water; + Eterm *old_hend; /* Heap pointers for generational GC. */ + Eterm *old_htop; + Eterm *old_heap; + Uint16 gen_gcs; /* Number of (minor) generational GCs. */ + Uint16 max_gen_gcs; /* Max minor gen GCs before fullsweep. */ + ErlOffHeap off_heap; /* Off-heap data updated by copy_struct(). */ + ErlHeapFragment* mbuf; /* Pointer to message buffer list */ + Uint mbuf_sz; /* Size of all message buffers */ + ErtsPSD *psd; /* Rarely used process specific data */ + + Uint bin_vheap_sz; /* Virtual heap block size for binaries */ + Uint bin_old_vheap_sz; /* Virtual old heap block size for binaries */ + Uint bin_old_vheap; /* Virtual old heap size for binaries */ + + union { +#ifdef ERTS_SMP + ErtsSmpPTimer *ptimer; +#else + ErlTimer tm; /* Timer entry */ +#endif + void *exit_data; /* Misc data referred during termination */ + } u; + + ErtsRunQueue *bound_runq; + +#ifdef ERTS_SMP + erts_proc_lock_t lock; + ErtsSchedulerData *scheduler_data; + int is_exiting; + Uint32 runq_flags; + Uint32 status_flags; + ErlMessageInQueue msg_inq; + Eterm suspendee; + ErtsPendingSuspend *pending_suspenders; + ErtsPendExit pending_exit; + ErtsRunQueue *run_queue; +#ifdef HIPE + struct hipe_process_state_smp hipe_smp; +#endif +#endif + +#ifdef HYBRID + Eterm *rrma; /* Remembered roots to Message Area */ + Eterm **rrsrc; /* The source of the root */ + Uint nrr; /* Number of remembered roots */ + Uint rrsz; /* Size of root array */ +#endif + +#ifdef HYBRID + Uint active; /* Active since last major collection? */ + Uint active_index; /* Index in the active process array */ +#endif + +#ifdef INCREMENTAL + Process *active_next; /* Active processes to scan for roots */ + Process *active_prev; /* in collection of the message area */ + Eterm *scan_top; +#endif + +#ifdef CHECK_FOR_HOLES + Eterm* last_htop; /* No need to scan the heap below this point. */ + ErlHeapFragment* last_mbuf; /* No need to scan beyond this mbuf. */ +#endif + +#ifdef DEBUG + Eterm* last_old_htop; /* + * No need to scan the old heap below this point + * when looking for invalid pointers into the new heap or + * heap fragments. + */ +#endif +}; + +#ifdef CHECK_FOR_HOLES +# define INIT_HOLE_CHECK(p) \ +do { \ + (p)->last_htop = 0; \ + (p)->last_mbuf = 0; \ +} while (0) + +# define ERTS_HOLE_CHECK(p) erts_check_for_holes((p)) +void erts_check_for_holes(Process* p); +#else +# define INIT_HOLE_CHECK(p) +# define ERTS_HOLE_CHECK(p) +#endif + +/* + * The MBUF_GC_FACTOR decides how easily a process is subject to GC + * due to message buffers allocated outside the heap. + * The larger the factor, the easier the process gets GCed. + * On a small memory system with lots of processes, this makes a significant + * difference, especially since the GCs help fragmentation quite a bit too. + */ +#if defined(SMALL_MEMORY) +#define MBUF_GC_FACTOR 4 +#else +#define MBUF_GC_FACTOR 1 +#endif + +#define SEQ_TRACE_TOKEN(p) ((p)->seq_trace_token) + +/* The sequential tracing token is a tuple of size 5: + * + * {Flags, Label, Serial, Sender} + */ + +#define SEQ_TRACE_TOKEN_ARITY(p) (arityval(*(tuple_val(SEQ_TRACE_TOKEN(p))))) +#define SEQ_TRACE_TOKEN_FLAGS(p) (*(tuple_val(SEQ_TRACE_TOKEN(p)) + 1)) +#define SEQ_TRACE_TOKEN_LABEL(p) (*(tuple_val(SEQ_TRACE_TOKEN(p)) + 2)) +#define SEQ_TRACE_TOKEN_SERIAL(p) (*(tuple_val(SEQ_TRACE_TOKEN(p)) + 3)) +#define SEQ_TRACE_TOKEN_SENDER(p) (*(tuple_val(SEQ_TRACE_TOKEN(p)) + 4)) +#define SEQ_TRACE_TOKEN_LASTCNT(p) (*(tuple_val(SEQ_TRACE_TOKEN(p)) + 5)) + +/* used when we have unit32 token */ +#define SEQ_TRACE_T_ARITY(token) (arityval(*(tuple_val(token)))) +#define SEQ_TRACE_T_FLAGS(token) (*(tuple_val(token) + 1)) +#define SEQ_TRACE_T_LABEL(token) (*(tuple_val(token) + 2)) +#define SEQ_TRACE_T_SERIAL(token) (*(tuple_val(token) + 3)) +#define SEQ_TRACE_T_SENDER(token) (*(tuple_val(token) + 4)) +#define SEQ_TRACE_T_LASTCNT(token) (*(tuple_val(token) + 5)) + +/* + * Possible flags for the flags field in ErlSpawnOpts below. + */ + +#define SPO_LINK 1 +#define SPO_USE_ARGS 2 +#define SPO_MONITOR 4 + +/* + * The following struct contains options for a process to be spawned. + */ +typedef struct { + Uint flags; + int error_code; /* Error code returned from create_process(). */ + Eterm mref; /* Monitor ref returned (if SPO_MONITOR was given). */ + + /* + * The following items are only initialized if the SPO_USE_ARGS flag is set. + */ + Uint min_heap_size; /* Minimum heap size (must be a valued returned + * from next_heap_size()). + */ + int priority; /* Priority for process. */ + Uint16 max_gen_gcs; /* Maximum number of gen GCs before fullsweep. */ + int scheduler; +} ErlSpawnOpts; + +/* + * The KILL_CATCHES(p) macro kills pending catches for process p. + */ + +#define KILL_CATCHES(p) (p)->catches = -1 + +void erts_arith_shrink(Process* p, Eterm* hp); +Eterm* erts_heap_alloc(Process* p, Uint need); +#ifdef CHECK_FOR_HOLES +Eterm* erts_set_hole_marker(Eterm* ptr, Uint sz); +#endif + +extern Process** process_tab; +#ifdef HYBRID +extern Uint erts_num_active_procs; +extern Process** erts_active_procs; +#endif +extern Uint erts_max_processes; +extern Uint erts_process_tab_index_mask; +extern Uint erts_default_process_flags; +extern erts_smp_rwmtx_t erts_cpu_bind_rwmtx; +/* If any of the erts_system_monitor_* variables are set (enabled), +** erts_system_monitor must be != NIL, to allow testing on just +** the erts_system_monitor_* variables. +*/ +extern Eterm erts_system_monitor; +extern Uint erts_system_monitor_long_gc; +extern Uint erts_system_monitor_large_heap; +struct erts_system_monitor_flags_t { + unsigned int busy_port : 1; + unsigned int busy_dist_port : 1; +}; +extern struct erts_system_monitor_flags_t erts_system_monitor_flags; + +/* system_profile, same rules as for system_monitor. + erts_profile must be != NIL when + erts_profile_* is set. */ + +extern Eterm erts_system_profile; +struct erts_system_profile_flags_t { + unsigned int scheduler : 1; + unsigned int runnable_procs : 1; + unsigned int runnable_ports : 1; + unsigned int exclusive : 1; +}; +extern struct erts_system_profile_flags_t erts_system_profile_flags; + +#define INVALID_PID(p, pid) ((p) == NULL \ + || (p)->id != (pid) \ + || (p)->status == P_EXITING) + +#define IS_TRACED(p) ( (p)->tracer_proc != NIL ) +#define ARE_TRACE_FLAGS_ON(p,tf) ( ((p)->trace_flags & (tf|F_SENSITIVE)) == (tf) ) +#define IS_TRACED_FL(p,tf) ( IS_TRACED(p) && ARE_TRACE_FLAGS_ON(p,tf) ) + +/* process flags */ +#define F_TRAPEXIT (1 << 0) +#define F_INSLPQUEUE (1 << 1) /* Set if in timer queue */ +#define F_TIMO (1 << 2) /* Set if timeout */ +#define F_HEAP_GROW (1 << 3) +#define F_NEED_FULLSWEEP (1 << 4) /* If process has old binaries & funs. */ +#define F_USING_DB (1 << 5) /* If have created tables */ +#define F_DISTRIBUTION (1 << 6) /* Process used in distribution */ +#define F_USING_DDLL (1 << 7) /* Process has used the DDLL interface */ +#define F_HAVE_BLCKD_MSCHED (1 << 8) /* Process has blocked multi-scheduling */ +#define F_P2PNR_RESCHED (1 << 9) /* Process has been rescheduled via erts_pid2proc_not_running() */ +#define F_FORCE_GC (1 << 10) /* Force gc at process in-scheduling */ + +/* process trace_flags */ +#define F_SENSITIVE (1 << 0) +#define F_TRACE_SEND (1 << 1) +#define F_TRACE_RECEIVE (1 << 2) +#define F_TRACE_SOS (1 << 3) /* Set on spawn */ +#define F_TRACE_SOS1 (1 << 4) /* Set on first spawn */ +#define F_TRACE_SOL (1 << 5) /* Set on link */ +#define F_TRACE_SOL1 (1 << 6) /* Set on first link */ +#define F_TRACE_CALLS (1 << 7) +#define F_TIMESTAMP (1 << 8) +#define F_TRACE_PROCS (1 << 9) +#define F_TRACE_FIRST_CHILD (1 << 10) +#define F_TRACE_SCHED (1 << 11) +#define F_TRACE_GC (1 << 12) +#define F_TRACE_ARITY_ONLY (1 << 13) +#define F_TRACE_RETURN_TO (1 << 14) /* Return_to trace when breakpoint tracing */ +#define F_TRACE_SILENT (1 << 15) /* No call trace msg suppress */ +#define F_TRACER (1 << 16) /* May be (has been) tracer */ +#define F_EXCEPTION_TRACE (1 << 17) /* May have exception trace on stack */ + +/* port trace flags, currently the same as process trace flags */ +#define F_TRACE_SCHED_PORTS (1 << 18) /* Trace of port scheduling */ +#define F_TRACE_SCHED_PROCS (1 << 19) /* With virtual scheduling */ +#define F_TRACE_PORTS (1 << 20) /* Ports equivalent to F_TRACE_PROCS */ +#define F_TRACE_SCHED_NO (1 << 21) /* Trace with scheduler id */ +#define F_TRACE_SCHED_EXIT (1 << 22) + +#define F_NUM_FLAGS 23 +#ifdef DEBUG +# define F_INITIAL_TRACE_FLAGS (5 << F_NUM_FLAGS) +#else +# define F_INITIAL_TRACE_FLAGS 0 +#endif + + + +#define TRACEE_FLAGS ( F_TRACE_PROCS | F_TRACE_CALLS \ + | F_TRACE_SOS | F_TRACE_SOS1| F_TRACE_RECEIVE \ + | F_TRACE_SOL | F_TRACE_SOL1 | F_TRACE_SEND \ + | F_TRACE_SCHED | F_TIMESTAMP | F_TRACE_GC \ + | F_TRACE_ARITY_ONLY | F_TRACE_RETURN_TO \ + | F_TRACE_SILENT | F_TRACE_SCHED_PROCS | F_TRACE_PORTS \ + | F_TRACE_SCHED_PORTS | F_TRACE_SCHED_NO \ + | F_TRACE_SCHED_EXIT) + +#define ERTS_TRACEE_MODIFIER_FLAGS \ + (F_TRACE_SILENT | F_TIMESTAMP | F_TRACE_SCHED_NO) +#define ERTS_PORT_TRACEE_FLAGS \ + (ERTS_TRACEE_MODIFIER_FLAGS | F_TRACE_PORTS | F_TRACE_SCHED_PORTS) +#define ERTS_PROC_TRACEE_FLAGS \ + ((TRACEE_FLAGS & ~ERTS_PORT_TRACEE_FLAGS) | ERTS_TRACEE_MODIFIER_FLAGS) + +/* Sequential trace flags */ +#define SEQ_TRACE_SEND (1 << 0) +#define SEQ_TRACE_RECEIVE (1 << 1) +#define SEQ_TRACE_PRINT (1 << 2) +#define SEQ_TRACE_TIMESTAMP (1 << 3) + +#ifdef ERTS_SMP +/* Status flags ... */ +#define ERTS_PROC_SFLG_PENDADD2SCHEDQ (((Uint32) 1) << 0) /* Pending + add to + schedule q */ +#define ERTS_PROC_SFLG_INRUNQ (((Uint32) 1) << 1) /* Process is + in run q */ +#define ERTS_PROC_SFLG_TRAPEXIT (((Uint32) 1) << 2) /* Process is + trapping + exit */ +#define ERTS_PROC_SFLG_RUNNING (((Uint32) 1) << 3) /* Process is + running */ +/* Scheduler flags in process struct... */ +#define ERTS_PROC_RUNQ_FLG_RUNNING (((Uint32) 1) << 0) /* Process is + running */ + +#endif + + +#ifdef ERTS_SMP +#define ERTS_PROC_IS_TRAPPING_EXITS(P) \ + (ERTS_SMP_LC_ASSERT(erts_proc_lc_my_proc_locks((P)) \ + & ERTS_PROC_LOCK_STATUS), \ + (P)->status_flags & ERTS_PROC_SFLG_TRAPEXIT) + +#define ERTS_PROC_SET_TRAP_EXIT(P) \ + (ERTS_SMP_LC_ASSERT(((ERTS_PROC_LOCK_MAIN|ERTS_PROC_LOCK_STATUS) \ + & erts_proc_lc_my_proc_locks((P))) \ + == (ERTS_PROC_LOCK_MAIN|ERTS_PROC_LOCK_STATUS)), \ + (P)->status_flags |= ERTS_PROC_SFLG_TRAPEXIT, \ + (P)->flags |= F_TRAPEXIT, \ + 1) + +#define ERTS_PROC_UNSET_TRAP_EXIT(P) \ + (ERTS_SMP_LC_ASSERT(((ERTS_PROC_LOCK_MAIN|ERTS_PROC_LOCK_STATUS) \ + & erts_proc_lc_my_proc_locks((P))) \ + == (ERTS_PROC_LOCK_MAIN|ERTS_PROC_LOCK_STATUS)), \ + (P)->status_flags &= ~ERTS_PROC_SFLG_TRAPEXIT, \ + (P)->flags &= ~F_TRAPEXIT, \ + 0) +#else +#define ERTS_PROC_IS_TRAPPING_EXITS(P) ((P)->flags & F_TRAPEXIT) +#define ERTS_PROC_SET_TRAP_EXIT(P) ((P)->flags |= F_TRAPEXIT, 1) +#define ERTS_PROC_UNSET_TRAP_EXIT(P) ((P)->flags &= ~F_TRAPEXIT, 0) +#endif + +/* Option flags to erts_send_exit_signal() */ +#define ERTS_XSIG_FLG_IGN_KILL (((Uint32) 1) << 0) +#define ERTS_XSIG_FLG_NO_IGN_NORMAL (((Uint32) 1) << 1) + + +/* Process status values */ +#define P_FREE 0 +#define P_RUNABLE 1 +#define P_WAITING 2 +#define P_RUNNING 3 +#define P_EXITING 4 +#define P_GARBING 5 +#define P_SUSPENDED 6 + +#define CANCEL_TIMER(p) \ + do { \ + if ((p)->flags & (F_INSLPQUEUE)) \ + cancel_timer(p); \ + else \ + (p)->flags &= ~F_TIMO; \ + } while (0) + + +#define ERTS_INIT_SCHED_BIND_TYPE_SUCCESS 0 +#define ERTS_INIT_SCHED_BIND_TYPE_NOT_SUPPORTED 1 +#define ERTS_INIT_SCHED_BIND_TYPE_ERROR_NO_CPU_TOPOLOGY 2 +#define ERTS_INIT_SCHED_BIND_TYPE_ERROR_NO_BAD_TYPE 3 + +int erts_init_scheduler_bind_type(char *how); + +#define ERTS_INIT_CPU_TOPOLOGY_OK 0 +#define ERTS_INIT_CPU_TOPOLOGY_INVALID_ID 1 +#define ERTS_INIT_CPU_TOPOLOGY_INVALID_ID_RANGE 2 +#define ERTS_INIT_CPU_TOPOLOGY_INVALID_HIERARCHY 3 +#define ERTS_INIT_CPU_TOPOLOGY_INVALID_ID_TYPE 4 +#define ERTS_INIT_CPU_TOPOLOGY_INVALID_NODES 5 +#define ERTS_INIT_CPU_TOPOLOGY_MISSING_LID 6 +#define ERTS_INIT_CPU_TOPOLOGY_NOT_UNIQUE_LIDS 7 +#define ERTS_INIT_CPU_TOPOLOGY_NOT_UNIQUE_ENTITIES 8 +#define ERTS_INIT_CPU_TOPOLOGY_MISSING 9 + +int erts_init_cpu_topology(char *topology_str); + +void erts_pre_init_process(void); +void erts_late_init_process(void); +void erts_early_init_scheduling(void); +void erts_init_scheduling(int, int, int); + +ErtsProcList *erts_proclist_create(Process *); +void erts_proclist_destroy(ErtsProcList *); +int erts_proclist_same(ErtsProcList *, Process *); + +#ifdef DEBUG +void erts_dbg_multi_scheduling_return_trap(Process *, Eterm); +#endif +#ifdef ERTS_SMP +ErtsSchedSuspendResult +erts_schedulers_state(Uint *, Uint *, Uint *, int); +ErtsSchedSuspendResult +erts_set_schedulers_online(Process *p, + ErtsProcLocks plocks, + Sint new_no, + Sint *old_no); +ErtsSchedSuspendResult +erts_block_multi_scheduling(Process *, ErtsProcLocks, int, int); +int erts_is_multi_scheduling_blocked(void); +Eterm erts_multi_scheduling_blockers(Process *); +void erts_start_schedulers(void); +void erts_smp_notify_check_children_needed(void); +#endif +Uint erts_active_schedulers(void); +void erts_init_process(void); +Eterm erts_process_status(Process *, ErtsProcLocks, Process *, Eterm); +Uint erts_run_queues_len(Uint *); +void erts_add_to_runq(Process *); +Eterm erts_bound_schedulers_term(Process *c_p); +Eterm erts_get_cpu_topology_term(Process *c_p, Eterm which); +Eterm erts_get_schedulers_binds(Process *c_p); +Eterm erts_set_cpu_topology(Process *c_p, Eterm term); +Eterm erts_bind_schedulers(Process *c_p, Eterm how); +ErtsRunQueue *erts_schedid2runq(Uint); +#ifdef ERTS_SMP +ErtsMigrateResult erts_proc_migrate(Process *, + ErtsProcLocks *, + ErtsRunQueue *, + int *, + ErtsRunQueue *, + int *); +#endif +Process *schedule(Process*, int); +void erts_schedule_misc_op(void (*)(void *), void *); +Eterm erl_create_process(Process*, Eterm, Eterm, Eterm, ErlSpawnOpts*); +void erts_do_exit_process(Process*, Eterm); +void erts_continue_exit_process(Process *); +void set_timer(Process*, Uint); +void cancel_timer(Process*); +/* Begin System profile */ +Uint erts_runnable_process_count(void); +Uint erts_process_count(void); +/* End System profile */ +void erts_init_empty_process(Process *p); +void erts_cleanup_empty_process(Process* p); +#ifdef DEBUG +void erts_debug_verify_clean_empty_process(Process* p); +#endif +void erts_stack_dump(int to, void *to_arg, Process *); +void erts_program_counter_info(int to, void *to_arg, Process *); + +Eterm erts_get_process_priority(Process *p); +Eterm erts_set_process_priority(Process *p, Eterm prio); + +Uint erts_get_total_context_switches(void); +void erts_get_total_reductions(Uint *, Uint *); +void erts_get_exact_total_reductions(Process *, Uint *, Uint *); + +Eterm erts_fake_scheduler_bindings(Process *p, Eterm how); + +void erts_sched_stat_modify(int what); +Eterm erts_sched_stat_term(Process *p, int total); + +void erts_free_proc(Process *); + +void erts_suspend(Process*, ErtsProcLocks, struct port*); +void erts_resume(Process*, ErtsProcLocks); +int erts_resume_processes(ErtsProcList *); + +int erts_send_exit_signal(Process *, + Eterm, + Process *, + ErtsProcLocks *, + Eterm, + Eterm, + Process *, + Uint32); +#ifdef ERTS_SMP +void erts_handle_pending_exit(Process *, ErtsProcLocks); +#define ERTS_PROC_PENDING_EXIT(P) \ + (ERTS_SMP_LC_ASSERT(erts_proc_lc_my_proc_locks((P)) & ERTS_PROC_LOCK_STATUS),\ + (P)->pending_exit.reason != THE_NON_VALUE) +#else +#define ERTS_PROC_PENDING_EXIT(P) 0 +#endif + +void erts_deep_process_dump(int, void *); + +Sint erts_test_next_pid(int, Uint); +Eterm erts_debug_processes(Process *c_p); +Eterm erts_debug_processes_bif_info(Process *c_p); +Uint erts_debug_nbalance(void); + +#ifdef ERTS_SMP +# define ERTS_GET_SCHEDULER_DATA_FROM_PROC(PROC) ((PROC)->scheduler_data) +# define ERTS_PROC_GET_SCHDATA(PROC) ((PROC)->scheduler_data) +#else +# define ERTS_GET_SCHEDULER_DATA_FROM_PROC(PROC) (erts_scheduler_data) +# define ERTS_PROC_GET_SCHDATA(PROC) (erts_scheduler_data) +#endif + +#if defined(ERTS_SMP) || defined(USE_THREADS) +ErtsSchedulerData *erts_get_scheduler_data(void); +#else +ERTS_GLB_INLINE ErtsSchedulerData *erts_get_scheduler_data(void); +#if ERTS_GLB_INLINE_INCL_FUNC_DEF + +ERTS_GLB_INLINE +ErtsSchedulerData *erts_get_scheduler_data(void) +{ + return erts_scheduler_data; +} +#endif +#endif + +#if defined(ERTS_SMP) && defined(ERTS_ENABLE_LOCK_CHECK) + +#define ERTS_PROCESS_LOCK_ONLY_LOCK_CHECK_PROTO__ +#include "erl_process_lock.h" +#undef ERTS_PROCESS_LOCK_ONLY_LOCK_CHECK_PROTO__ + +int erts_smp_lc_runq_is_locked(ErtsRunQueue *); +#define ERTS_SMP_LC_CHK_RUNQ_LOCK(RQ, L) \ +do { \ + if ((L)) \ + ERTS_SMP_LC_ASSERT(erts_smp_lc_runq_is_locked((RQ))); \ + else \ + ERTS_SMP_LC_ASSERT(!erts_smp_lc_runq_is_locked((RQ))); \ +} while (0) +#else +#define ERTS_SMP_LC_CHK_RUNQ_LOCK(RQ, L) +#endif + +void *erts_psd_set_init(Process *p, ErtsProcLocks plocks, int ix, void *data); + +ERTS_GLB_INLINE void * +erts_psd_get(Process *p, int ix); +ERTS_GLB_INLINE void * +erts_psd_set(Process *p, ErtsProcLocks plocks, int ix, void *new); + +#if ERTS_GLB_INLINE_INCL_FUNC_DEF + +ERTS_GLB_INLINE void * +erts_psd_get(Process *p, int ix) +{ +#if defined(ERTS_SMP) && defined(ERTS_ENABLE_LOCK_CHECK) + ErtsProcLocks locks = erts_proc_lc_my_proc_locks(p); + if (ERTS_LC_PSD_ANY_LOCK == erts_psd_required_locks[ix].get_locks) + ERTS_SMP_LC_ASSERT(locks + || erts_is_system_blocked(0) + || (ERTS_IS_CRASH_DUMPING + && erts_is_system_blocked(ERTS_BS_FLG_ALLOW_GC))); + else { + locks &= erts_psd_required_locks[ix].get_locks; + ERTS_SMP_LC_ASSERT(erts_psd_required_locks[ix].get_locks == locks + || erts_is_system_blocked(0) + || (ERTS_IS_CRASH_DUMPING + && erts_is_system_blocked(ERTS_BS_FLG_ALLOW_GC))); + } +#endif + ASSERT(0 <= ix && ix < ERTS_PSD_SIZE); + return p->psd ? p->psd->data[ix] : NULL; +} + + +/* + * NOTE: erts_psd_set() might release and reacquire locks on 'p'. + */ +ERTS_GLB_INLINE void * +erts_psd_set(Process *p, ErtsProcLocks plocks, int ix, void *data) +{ +#if defined(ERTS_SMP) && defined(ERTS_ENABLE_LOCK_CHECK) + ErtsProcLocks locks = erts_proc_lc_my_proc_locks(p); + if (ERTS_LC_PSD_ANY_LOCK == erts_psd_required_locks[ix].set_locks) + ERTS_SMP_LC_ASSERT(locks + || erts_is_system_blocked(0) + || (ERTS_IS_CRASH_DUMPING + && erts_is_system_blocked(ERTS_BS_FLG_ALLOW_GC))); + else { + locks &= erts_psd_required_locks[ix].set_locks; + ERTS_SMP_LC_ASSERT(erts_psd_required_locks[ix].set_locks == locks + || erts_is_system_blocked(0) + || (ERTS_IS_CRASH_DUMPING + && erts_is_system_blocked(ERTS_BS_FLG_ALLOW_GC))); + } +#endif + ASSERT(0 <= ix && ix < ERTS_PSD_SIZE); + if (p->psd) { + void *old = p->psd->data[ix]; + p->psd->data[ix] = data; + return old; + } + else { + if (!data) + return NULL; + else + return erts_psd_set_init(p, plocks, ix, data); + } +} + +#endif + +#define ERTS_PROC_SCHED_ID(P, L, ID) \ + ((Uint) erts_psd_set((P), (L), ERTS_PSD_SCHED_ID, (void *) (ID))) + +#define ERTS_PROC_GET_DIST_ENTRY(P) \ + ((DistEntry *) erts_psd_get((P), ERTS_PSD_DIST_ENTRY)) +#define ERTS_PROC_SET_DIST_ENTRY(P, L, D) \ + ((DistEntry *) erts_psd_set((P), (L), ERTS_PSD_DIST_ENTRY, (void *) (D))) + +#define ERTS_PROC_GET_SAVED_CALLS_BUF(P) \ + ((struct saved_calls *) erts_psd_get((P), ERTS_PSD_SAVED_CALLS_BUF)) +#define ERTS_PROC_SET_SAVED_CALLS_BUF(P, L, SCB) \ + ((struct saved_calls *) erts_psd_set((P), (L), ERTS_PSD_SAVED_CALLS_BUF, (void *) (SCB))) + +ERTS_GLB_INLINE Eterm erts_proc_get_error_handler(Process *p); +ERTS_GLB_INLINE Eterm erts_proc_set_error_handler(Process *p, + ErtsProcLocks plocks, + Eterm handler); + +#if ERTS_GLB_INLINE_INCL_FUNC_DEF +ERTS_GLB_INLINE Eterm +erts_proc_get_error_handler(Process *p) +{ + void *val = erts_psd_get(p, ERTS_PSD_ERROR_HANDLER); + if (!val) + return am_error_handler; + else { + ASSERT(is_atom(((Eterm) val))); + return (Eterm) val; + } +} + +ERTS_GLB_INLINE Eterm +erts_proc_set_error_handler(Process *p, ErtsProcLocks plocks, Eterm handler) +{ + void *old_val; + void *new_val; + ASSERT(is_atom(handler)); + new_val = handler == am_error_handler ? NULL : (void *) handler; + old_val = erts_psd_set(p, plocks, ERTS_PSD_ERROR_HANDLER, new_val); + if (!old_val) + return am_error_handler; + else { + ASSERT(is_atom(((Eterm) old_val))); + return (Eterm) old_val; + } +} + +#endif + +#ifdef ERTS_SMP +ErtsRunQueue *erts_prepare_emigrate(ErtsRunQueue *c_rq, + ErtsRunQueueInfo *c_rqi, + int prio); + +ERTS_GLB_INLINE ErtsRunQueue *erts_check_emigration_need(ErtsRunQueue *c_rq, + int prio); +#endif + +ERTS_GLB_INLINE int erts_is_scheduler_bound(ErtsSchedulerData *esdp); +ERTS_GLB_INLINE Process *erts_get_current_process(void); +ERTS_GLB_INLINE Eterm erts_get_current_pid(void); +ERTS_GLB_INLINE Uint erts_get_scheduler_id(void); +ERTS_GLB_INLINE ErtsRunQueue *erts_get_runq_proc(Process *p); +ERTS_GLB_INLINE ErtsRunQueue *erts_get_runq_current(ErtsSchedulerData *esdp); +ERTS_GLB_INLINE void erts_smp_runq_lock(ErtsRunQueue *rq); +ERTS_GLB_INLINE int erts_smp_runq_trylock(ErtsRunQueue *rq); +ERTS_GLB_INLINE void erts_smp_runq_unlock(ErtsRunQueue *rq); +ERTS_GLB_INLINE void erts_smp_xrunq_lock(ErtsRunQueue *rq, ErtsRunQueue *xrq); +ERTS_GLB_INLINE void erts_smp_xrunq_unlock(ErtsRunQueue *rq, ErtsRunQueue *xrq); +ERTS_GLB_INLINE void erts_smp_runqs_lock(ErtsRunQueue *rq1, ErtsRunQueue *rq2); +ERTS_GLB_INLINE void erts_smp_runqs_unlock(ErtsRunQueue *rq1, ErtsRunQueue *rq2); + +#if ERTS_GLB_INLINE_INCL_FUNC_DEF + +#ifdef ERTS_SMP +ERTS_GLB_INLINE ErtsRunQueue * +erts_check_emigration_need(ErtsRunQueue *c_rq, int prio) +{ + ErtsRunQueueInfo *c_rqi; + + if (!ERTS_CHK_RUNQ_FLG_EMIGRATE(c_rq->flags, prio)) + return NULL; + + if (prio == ERTS_PORT_PRIO_LEVEL) + c_rqi = &c_rq->ports.info; + else + c_rqi = &c_rq->procs.prio_info[prio]; + + if (!ERTS_CHK_RUNQ_FLG_EVACUATE(c_rq->flags, prio) + && !(c_rq->flags & ERTS_RUNQ_FLG_INACTIVE) + && c_rqi->len <= c_rqi->migrate.limit.this) + return NULL; + + return erts_prepare_emigrate(c_rq, c_rqi, prio); +} +#endif + +ERTS_GLB_INLINE +int erts_is_scheduler_bound(ErtsSchedulerData *esdp) +{ + if (!esdp) + esdp = erts_get_scheduler_data(); + ASSERT(esdp); + return esdp->cpu_id >= 0; +} + +ERTS_GLB_INLINE +Process *erts_get_current_process(void) +{ + ErtsSchedulerData *esdp = erts_get_scheduler_data(); + return esdp ? esdp->current_process : NULL; +} + +ERTS_GLB_INLINE +Eterm erts_get_current_pid(void) +{ + Process *proc = erts_get_current_process(); + return proc ? proc->id : THE_NON_VALUE; +} + +ERTS_GLB_INLINE +Uint erts_get_scheduler_id(void) +{ +#ifdef ERTS_SMP + ErtsSchedulerData *esdp = erts_get_scheduler_data(); + return esdp ? esdp->no : (Uint) 0; +#else + return erts_get_scheduler_data() ? (Uint) 1 : (Uint) 0; +#endif +} + +ERTS_GLB_INLINE ErtsRunQueue * +erts_get_runq_proc(Process *p) +{ + ERTS_SMP_LC_ASSERT(ERTS_PROC_LOCK_STATUS & erts_proc_lc_my_proc_locks(p)); +#ifdef ERTS_SMP + ASSERT(p->run_queue); + return p->run_queue; +#else + ASSERT(erts_common_run_queue); + return erts_common_run_queue; +#endif +} + +ERTS_GLB_INLINE ErtsRunQueue * +erts_get_runq_current(ErtsSchedulerData *esdp) +{ + ASSERT(!esdp || esdp == erts_get_scheduler_data()); +#ifdef ERTS_SMP + if (!esdp) + esdp = erts_get_scheduler_data(); + return esdp->run_queue; +#else + ASSERT(erts_common_run_queue); + return erts_common_run_queue; +#endif +} + +ERTS_GLB_INLINE void +erts_smp_runq_lock(ErtsRunQueue *rq) +{ +#ifdef ERTS_SMP + erts_smp_mtx_lock(&rq->mtx); +#endif +} + +ERTS_GLB_INLINE int +erts_smp_runq_trylock(ErtsRunQueue *rq) +{ +#ifdef ERTS_SMP + return erts_smp_mtx_trylock(&rq->mtx); +#else + return 0; +#endif +} + +ERTS_GLB_INLINE void +erts_smp_runq_unlock(ErtsRunQueue *rq) +{ +#ifdef ERTS_SMP + erts_smp_mtx_unlock(&rq->mtx); +#endif +} + +ERTS_GLB_INLINE void +erts_smp_xrunq_lock(ErtsRunQueue *rq, ErtsRunQueue *xrq) +{ +#ifdef ERTS_SMP + ERTS_SMP_LC_ASSERT(erts_smp_lc_mtx_is_locked(&rq->mtx)); + if (xrq != rq) { + if (erts_smp_mtx_trylock(&xrq->mtx) == EBUSY) { + if (rq < xrq) + erts_smp_mtx_lock(&xrq->mtx); + else { + erts_smp_mtx_unlock(&rq->mtx); + erts_smp_mtx_lock(&xrq->mtx); + erts_smp_mtx_lock(&rq->mtx); + } + } + } +#endif +} + +ERTS_GLB_INLINE void +erts_smp_xrunq_unlock(ErtsRunQueue *rq, ErtsRunQueue *xrq) +{ +#ifdef ERTS_SMP + if (xrq != rq) + erts_smp_mtx_unlock(&xrq->mtx); +#endif +} + +ERTS_GLB_INLINE void +erts_smp_runqs_lock(ErtsRunQueue *rq1, ErtsRunQueue *rq2) +{ +#ifdef ERTS_SMP + ASSERT(rq1 && rq2); + if (rq1 == rq2) + erts_smp_mtx_lock(&rq1->mtx); + else if (rq1 < rq2) { + erts_smp_mtx_lock(&rq1->mtx); + erts_smp_mtx_lock(&rq2->mtx); + } + else { + erts_smp_mtx_lock(&rq2->mtx); + erts_smp_mtx_lock(&rq1->mtx); + } +#endif +} + +ERTS_GLB_INLINE void +erts_smp_runqs_unlock(ErtsRunQueue *rq1, ErtsRunQueue *rq2) +{ +#ifdef ERTS_SMP + ASSERT(rq1 && rq2); + erts_smp_mtx_unlock(&rq1->mtx); + if (rq1 != rq2) + erts_smp_mtx_unlock(&rq2->mtx); +#endif +} + +#endif /* #if ERTS_GLB_INLINE_INCL_FUNC_DEF */ + +ERTS_GLB_INLINE ErtsAtomCacheMap *erts_get_atom_cache_map(Process *c_p); + +#if ERTS_GLB_INLINE_INCL_FUNC_DEF +ERTS_GLB_INLINE ErtsAtomCacheMap * +erts_get_atom_cache_map(Process *c_p) +{ + ErtsSchedulerData *esdp = (c_p + ? ERTS_PROC_GET_SCHDATA(c_p) + : erts_get_scheduler_data()); + ASSERT(esdp); + return &esdp->atom_cache_map; +} +#endif + +#ifdef ERTS_SMP + +Process *erts_pid2proc_not_running(Process *, + ErtsProcLocks, + Eterm, + ErtsProcLocks); +Process *erts_pid2proc_nropt(Process *c_p, + ErtsProcLocks c_p_locks, + Eterm pid, + ErtsProcLocks pid_locks); +extern int erts_disable_proc_not_running_opt; + +#ifdef DEBUG +#define ERTS_SMP_ASSERT_IS_NOT_EXITING(P) \ + do { ASSERT(!(P)->is_exiting); } while (0) +#else +#define ERTS_SMP_ASSERT_IS_NOT_EXITING(P) +#endif + +/* NOTE: At least one process lock has to be held on P! */ +#ifdef ERTS_ENABLE_LOCK_CHECK +#define ERTS_PROC_IS_EXITING(P) \ + (ERTS_SMP_LC_ASSERT(erts_proc_lc_my_proc_locks((P)) != 0 \ + || erts_lc_pix_lock_is_locked(ERTS_PID2PIXLOCK((P)->id))),\ + (P)->is_exiting) +#else +#define ERTS_PROC_IS_EXITING(P) ((P)->is_exiting) +#endif + +#else /* !ERTS_SMP */ + +#define ERTS_PROC_IS_EXITING(P) ((P)->status == P_EXITING) + +#define ERTS_SMP_ASSERT_IS_NOT_EXITING(P) + +#define erts_pid2proc_not_running erts_pid2proc +#define erts_pid2proc_nropt erts_pid2proc + +#endif + +/* Minimum NUMBER of processes for a small system to start */ +#ifdef ERTS_SMP +#define ERTS_MIN_PROCESSES ERTS_NO_OF_PIX_LOCKS +#else +#define ERTS_MIN_PROCESSES 16 +#endif + +#ifdef ERTS_INCLUDE_SCHEDULER_INTERNALS +ERTS_GLB_INLINE void erts_smp_notify_inc_runq(ErtsRunQueue *runq); +void erts_smp_notify_inc_runq__(ErtsRunQueue *runq); +#endif /* ERTS_INCLUDE_SCHEDULER_INTERNALS */ + +#if ERTS_GLB_INLINE_INCL_FUNC_DEF + +#ifdef ERTS_INCLUDE_SCHEDULER_INTERNALS + +ERTS_GLB_INLINE void +erts_smp_notify_inc_runq(ErtsRunQueue *runq) +{ +#ifdef ERTS_SMP + ERTS_SMP_LC_ASSERT(erts_smp_lc_runq_is_locked(runq)); + if (runq->waiting) + erts_smp_notify_inc_runq__(runq); +#endif +} + +#endif /* ERTS_INCLUDE_SCHEDULER_INTERNALS */ + +#endif /* #if ERTS_GLB_INLINE_INCL_FUNC_DEF */ + +#include "erl_process_lock.h" + +#undef ERTS_INCLUDE_SCHEDULER_INTERNALS + +#endif + + + diff --git a/erts/emulator/beam/erl_process_dict.c b/erts/emulator/beam/erl_process_dict.c new file mode 100644 index 0000000000..93466da3aa --- /dev/null +++ b/erts/emulator/beam/erl_process_dict.c @@ -0,0 +1,1001 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1999-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* + * Code for process dictionaries. + * + */ +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "erl_process.h" /* Will include erl_process_dict.h */ +#include "error.h" +#include "erl_driver.h" +#include "bif.h" +#include "big.h" +#include "dist.h" +#include "erl_version.h" + +/* #define HARDDEBUG */ + +/* +** Utility macros +*/ + +/* Flags to pd_get_hash */ +#define PD_GET_OTHER_PROCESS 1UL + +/* Hash constant macros */ +#define MAX_HASH 1342177280UL +#define INITIAL_SIZE 10 + +/* Hash utility macros */ +#define HASH_RANGE(PDict) ((PDict)->homeSize + (PDict)->splitPosition) + +#define MAKE_HASH(Term) \ +((is_small(Term)) ? unsigned_val(Term) : \ + ((is_atom(Term)) ? \ + (atom_tab(atom_val(term))->slot.bucket.hvalue) : \ + make_hash2(Term))) + +#define PD_SZ2BYTES(Sz) (sizeof(ProcDict) + ((Sz) - 1)*sizeof(Eterm)) + +/* Memory allocation macros */ +#define PD_ALLOC(Sz) \ + erts_alloc(ERTS_ALC_T_PROC_DICT, (Sz)) +#define PD_FREE(P, Sz) \ + erts_free(ERTS_ALC_T_PROC_DICT, (P)) +#define PD_REALLOC(P, OSz, NSz) \ + erts_realloc(ERTS_ALC_T_PROC_DICT, (P), (NSz)) + + +#define TCAR(Term) CAR(list_val(Term)) +#define TCDR(Term) CDR(list_val(Term)) + +/* Array access macro */ +#define ARRAY_GET(PDict, Index) (((PDict)->size > (Index)) ? \ + (PDict)->data[Index] : NIL) + +/* + * Forward decalarations + */ +static void pd_hash_erase(Process *p, Eterm id, Eterm *ret); +static void pd_hash_erase_all(Process *p); +static Eterm pd_hash_get_keys(Process *p, Eterm value); +static Eterm pd_hash_get_all(Process *p, ProcDict *pd); +static Eterm pd_hash_put(Process *p, Eterm id, Eterm value); + +static void shrink(Process *p, Eterm* ret); +static void grow(Process *p); + +static void array_shrink(ProcDict **ppd, unsigned int need); +static Eterm array_put(ProcDict **ppdict, unsigned int ndx, Eterm term); + +static unsigned int pd_hash_value(ProcDict *pdict, Eterm term); +static unsigned int next_array_size(unsigned int need); + +/* +** Debugging prototypes and macros +*/ +#ifdef HARDDEBUG + +#include + +static int hdebugf(char *format, ...); +static char *hdebugf_file = ""; +static int hdebugf_line; +#define HDEBUGF(X) ((int) hdebugf_file = __FILE__, hdebugf_line = __LINE__, \ + hdebugf X) +#ifndef DEBUG +#define DEBUG 1 +#endif + +#else /* !HARDDEBUG */ + +#define HDEBUGF(X) /* Nothing */ + +#endif /* HARDDEBUG (else) */ + +#ifdef DEBUG + +static void pd_check(ProcDict *pd); + +#define PD_CHECK(PD) pd_check(PD) + +#else /* !DEBUG */ + +#define PD_CHECK(PD) /* Nothing */ + +#endif /* DEBUG (else) */ + +/* +** External interface +*/ + +/* + * Called from break handler + */ +void +erts_dictionary_dump(int to, void *to_arg, ProcDict *pd) +{ + unsigned int i; +#ifdef DEBUG + + /*PD_CHECK(pd);*/ + if (pd == NULL) + return; + erts_print(to, to_arg, "(size = %d, used = %d, homeSize = %d, " + "splitPosition = %d, numElements = %d)\n", + pd->size, pd->used, pd->homeSize, + pd->splitPosition, (unsigned int) pd->numElements); + for (i = 0; i < HASH_RANGE(pd); ++i) { + erts_print(to, to_arg, "%d: %T\n", i, ARRAY_GET(pd, i)); + } + +#else /* !DEBUG */ + + int written = 0; + Eterm t; + + erts_print(to, to_arg, "["); + if (pd != NULL) { + for (i = 0; i < HASH_RANGE(pd); ++i) { + t = ARRAY_GET(pd, i); + if (is_list(t)) { + for (; t != NIL; t = TCDR(t)) { + erts_print(to, to_arg, written++ ? ",%T" : "%T", TCAR(t)); + } + } else if (is_tuple(t)) { + erts_print(to, to_arg, written++ ? ",%T" : "%T", t); + } + } + } + erts_print(to, to_arg, "]"); + +#endif /* DEBUG (else) */ +} + +void +erts_deep_dictionary_dump(int to, void *to_arg, + ProcDict* pd, void (*cb)(int, void *, Eterm)) +{ + unsigned int i; + Eterm t; + + if (pd != NULL) { + for (i = 0; i < HASH_RANGE(pd); ++i) { + t = ARRAY_GET(pd, i); + if (is_list(t)) { + for (; t != NIL; t = TCDR(t)) { + (*cb)(to, to_arg, TCAR(t)); + } + } else if (is_tuple(t)) { + (*cb)(to, to_arg, t); + } + } + } +} + +Uint +erts_dicts_mem_size(Process *p) +{ + Uint size = 0; + if (p->dictionary) + size += PD_SZ2BYTES(p->dictionary->size); + return size; +} + +void +erts_erase_dicts(Process *p) +{ + if (p->dictionary) { + pd_hash_erase_all(p); + p->dictionary = NULL; + } +} + +/* + * Called from process_info/1,2. + */ +Eterm erts_dictionary_copy(Process *p, ProcDict *pd) +{ + Eterm* hp; + Eterm* heap_start; + Eterm res = NIL; + Eterm tmp, tmp2; + unsigned int i, num; + + if (pd == NULL) { + return res; + } + + PD_CHECK(pd); + num = HASH_RANGE(pd); + heap_start = hp = (Eterm *) erts_alloc(ERTS_ALC_T_TMP, + sizeof(Eterm) * pd->numElements * 2); + for (i = 0; i < num; ++i) { + tmp = ARRAY_GET(pd, i); + if (is_boxed(tmp)) { + ASSERT(is_tuple(tmp)); + res = CONS(hp, tmp, res); + hp += 2; + } else if (is_list(tmp)) { + while (tmp != NIL) { + tmp2 = TCAR(tmp); + res = CONS(hp, tmp2, res); + hp += 2; + tmp = TCDR(tmp); + } + } + } + res = copy_object(res, p); + erts_free(ERTS_ALC_T_TMP, (void *) heap_start); + return res; +} + + +/* +** BIF interface +*/ +BIF_RETTYPE get_0(BIF_ALIST_0) +{ + Eterm ret; + PD_CHECK(BIF_P->dictionary); + ret = pd_hash_get_all(BIF_P, BIF_P->dictionary); + PD_CHECK(BIF_P->dictionary); + BIF_RET(ret); +} + +BIF_RETTYPE get_1(BIF_ALIST_1) +{ + Eterm ret; + PD_CHECK(BIF_P->dictionary); + ret = erts_pd_hash_get(BIF_P, BIF_ARG_1); + PD_CHECK(BIF_P->dictionary); + BIF_RET(ret); +} + +BIF_RETTYPE get_keys_1(BIF_ALIST_1) +{ + Eterm ret; + + PD_CHECK(BIF_P->dictionary); + ret = pd_hash_get_keys(BIF_P, BIF_ARG_1); + PD_CHECK(BIF_P->dictionary); + BIF_RET(ret); +} + +BIF_RETTYPE put_2(BIF_ALIST_2) +{ + Eterm ret; + + PD_CHECK(BIF_P->dictionary); + ret = pd_hash_put(BIF_P, BIF_ARG_1, BIF_ARG_2); + PD_CHECK(BIF_P->dictionary); + BIF_RET(ret); +} + +BIF_RETTYPE erase_0(BIF_ALIST_0) +{ + Eterm ret; + PD_CHECK(BIF_P->dictionary); + ret = pd_hash_get_all(BIF_P, BIF_P->dictionary); + pd_hash_erase_all(BIF_P); + PD_CHECK(BIF_P->dictionary); + BIF_RET(ret); +} + +BIF_RETTYPE erase_1(BIF_ALIST_1) +{ + Eterm ret; + PD_CHECK(BIF_P->dictionary); + pd_hash_erase(BIF_P, BIF_ARG_1, &ret); + PD_CHECK(BIF_P->dictionary); + BIF_RET(ret); +} + +/* + * BIF implementations + */ +static void pd_hash_erase(Process *p, Eterm id, Eterm *ret) +{ + unsigned int hval; + Eterm old; + Eterm tmp; + unsigned int range; + + *ret = am_undefined; + if (p->dictionary == NULL) { + return; + } + hval = pd_hash_value(p->dictionary, id); + old = ARRAY_GET(p->dictionary, hval); + if (is_boxed(old)) { /* Tuple */ + ASSERT(is_tuple(old)); + if (EQ(tuple_val(old)[1], id)) { + array_put(&(p->dictionary), hval, NIL); + --(p->dictionary->numElements); + *ret = tuple_val(old)[2]; + } + } else if (is_list(old)) { + /* Find cons cell for identical value */ + Eterm* prev = &p->dictionary->data[hval]; + + for (tmp = *prev; tmp != NIL; prev = &TCDR(tmp), tmp = *prev) { + if (EQ(tuple_val(TCAR(tmp))[1], id)) { + *prev = TCDR(tmp); + *ret = tuple_val(TCAR(tmp))[2]; + --(p->dictionary->numElements); + } + } + + /* If there is only one element left in the list we must remove the list. */ + old = ARRAY_GET(p->dictionary, hval); + ASSERT(is_list(old)); + if (is_nil(TCDR(old))) { + array_put(&p->dictionary, hval, TCAR(old)); + } + } else if (is_not_nil(old)) { +#ifdef DEBUG + erts_fprintf(stderr, + "Process dictionary for process %T is broken, trying to " + "display term found in line %d:\n" + "%T\n", p->id, __LINE__, old); +#endif + erl_exit(1, "Damaged process dictionary found during erase/1."); + } + if ((range = HASH_RANGE(p->dictionary)) > INITIAL_SIZE && + range / 2 > (p->dictionary->numElements)) { + shrink(p, ret); + } +} + +static void pd_hash_erase_all(Process *p) +{ + if (p->dictionary != NULL) { + PD_FREE(p->dictionary, PD_SZ2BYTES(p->dictionary->size)); + p->dictionary = NULL; + } +} + +Eterm erts_pd_hash_get(Process *p, Eterm id) +{ + unsigned int hval; + Eterm tmp; + ProcDict *pd = p->dictionary; + + if (pd == NULL) + return am_undefined; + hval = pd_hash_value(pd, id); + tmp = ARRAY_GET(pd, hval); + if (is_boxed(tmp)) { /* Tuple */ + ASSERT(is_tuple(tmp)); + if (EQ(tuple_val(tmp)[1], id)) { + return tuple_val(tmp)[2]; + } + } else if (is_list(tmp)) { + for (; tmp != NIL && !EQ(tuple_val(TCAR(tmp))[1], id); tmp = TCDR(tmp)) { + ; + } + if (tmp != NIL) { + return tuple_val(TCAR(tmp))[2]; + } + } else if (is_not_nil(tmp)) { +#ifdef DEBUG + erts_fprintf(stderr, + "Process dictionary for process %T is broken, trying to " + "display term found in line %d:\n" + "%T\n", p->id, __LINE__, tmp); +#endif + erl_exit(1, "Damaged process dictionary found during get/1."); + } + return am_undefined; +} + +static Eterm pd_hash_get_keys(Process *p, Eterm value) +{ + Eterm *hp; + Eterm res = NIL; + ProcDict *pd = p->dictionary; + unsigned int i, num; + Eterm tmp, tmp2; + + if (pd == NULL) { + return res; + } + + num = HASH_RANGE(pd); + for (i = 0; i < num; ++i) { + tmp = ARRAY_GET(pd, i); + if (is_boxed(tmp)) { + ASSERT(is_tuple(tmp)); + if (EQ(tuple_val(tmp)[2], value)) { + hp = HAlloc(p, 2); + res = CONS(hp, tuple_val(tmp)[1], res); + } + } else if (is_list(tmp)) { + while (tmp != NIL) { + tmp2 = TCAR(tmp); + if (EQ(tuple_val(tmp2)[2], value)) { + hp = HAlloc(p, 2); + res = CONS(hp, tuple_val(tmp2)[1], res); + } + tmp = TCDR(tmp); + } + } + } + return res; +} + + +static Eterm +pd_hash_get_all(Process *p, ProcDict *pd) +{ + Eterm* hp; + Eterm res = NIL; + Eterm tmp, tmp2; + unsigned int i; + unsigned int num; + + if (pd == NULL) { + return res; + } + num = HASH_RANGE(pd); + hp = HAlloc(p, pd->numElements * 2); + + for (i = 0; i < num; ++i) { + tmp = ARRAY_GET(pd, i); + if (is_boxed(tmp)) { + ASSERT(is_tuple(tmp)); + res = CONS(hp, tmp, res); + hp += 2; + } else if (is_list(tmp)) { + while (tmp != NIL) { + tmp2 = TCAR(tmp); + res = CONS(hp, tmp2, res); + hp += 2; + tmp = TCDR(tmp); + } + } + } + return res; +} + +static Eterm pd_hash_put(Process *p, Eterm id, Eterm value) +{ + unsigned int hval; + Eterm *hp; + Eterm tpl; + Eterm old; + Eterm tmp; + int needed; + int i = 0; +#ifdef DEBUG + Eterm *hp_limit; +#endif + + if (p->dictionary == NULL) { + /* Create it */ + array_put(&(p->dictionary), INITIAL_SIZE - 1, NIL); + p->dictionary->homeSize = INITIAL_SIZE; + } + hval = pd_hash_value(p->dictionary, id); + old = ARRAY_GET(p->dictionary, hval); + + /* + * Calculate the number of heap words needed and garbage + * collect if necessary. (Might be a slight overestimation.) + */ + needed = 3; /* {Key,Value} tuple */ + if (is_boxed(old)) { + /* + * We don't want to compare keys twice, so we'll always + * reserve the space for two CONS cells. + */ + needed += 2+2; + } else if (is_list(old)) { + i = 0; + for (tmp = old; tmp != NIL && !EQ(tuple_val(TCAR(tmp))[1], id); tmp = TCDR(tmp)) { + ++i; + } + if (is_nil(tmp)) { + i = -1; + needed += 2; + } else { + needed += 2*(i+1); + } + } + if (HeapWordsLeft(p) < needed) { + Eterm root[3]; + root[0] = id; + root[1] = value; + root[2] = old; + BUMP_REDS(p, erts_garbage_collect(p, needed, root, 3)); + id = root[0]; + value = root[1]; + old = root[2]; + } +#ifdef DEBUG + hp_limit = p->htop + needed; +#endif + + /* + * Create the {Key,Value} tuple. + */ + hp = HeapOnlyAlloc(p, 3); + tpl = TUPLE2(hp, id, value); + + /* + * Update the dictionary. + */ + if (is_nil(old)) { + array_put(&(p->dictionary), hval, tpl); + ++(p->dictionary->numElements); + } else if (is_boxed(old)) { + ASSERT(is_tuple(old)); + if (EQ(tuple_val(old)[1],id)) { + array_put(&(p->dictionary), hval, tpl); + return tuple_val(old)[2]; + } else { + hp = HeapOnlyAlloc(p, 4); + tmp = CONS(hp, old, NIL); + hp += 2; + ++(p->dictionary->numElements); + array_put(&(p->dictionary), hval, CONS(hp, tpl, tmp)); + hp += 2; + ASSERT(hp <= hp_limit); + } + } else if (is_list(old)) { + if (i == -1) { + /* + * New key. Simply prepend the tuple to the beginning of the list. + */ + hp = HeapOnlyAlloc(p, 2); + array_put(&(p->dictionary), hval, CONS(hp, tpl, old)); + hp += 2; + ASSERT(hp <= hp_limit); + ++(p->dictionary->numElements); + } else { + /* + * i = Number of CDRs to skip to reach the changed element in the list. + * + * Replace old value in list. To avoid pointers from the old generation + * to the new, we must rebuild the list from the beginning up to and + * including the changed element. + */ + Eterm nlist; + int j; + + hp = HeapOnlyAlloc(p, (i+1)*2); + + /* Find the list element to change. */ + for (j = 0, nlist = old; j < i; j++, nlist = TCDR(nlist)) { + ; + } + ASSERT(EQ(tuple_val(TCAR(nlist))[1], id)); + nlist = TCDR(nlist); /* Unchanged part of list. */ + + /* Rebuild list before the updated element. */ + for (tmp = old; i-- > 0; tmp = TCDR(tmp)) { + nlist = CONS(hp, TCAR(tmp), nlist); + hp += 2; + } + ASSERT(EQ(tuple_val(TCAR(tmp))[1], id)); + + /* Put the updated element first in the new list. */ + nlist = CONS(hp, tpl, nlist); + hp += 2; + ASSERT(hp <= hp_limit); + array_put(&(p->dictionary), hval, nlist); + return tuple_val(TCAR(tmp))[2]; + } + } else { +#ifdef DEBUG + erts_fprintf(stderr, + "Process dictionary for process %T is broken, trying to " + "display term found in line %d:\n" + "%T\n", p->id, __LINE__, old); +#endif + + erl_exit(1, "Damaged process dictionary found during put/2."); + } + if (HASH_RANGE(p->dictionary) <= p->dictionary->numElements) { + grow(p); + } + return am_undefined; +} + +/* + * Hash table utilities, rehashing + */ + +static void shrink(Process *p, Eterm* ret) +{ + unsigned int range = HASH_RANGE(p->dictionary); + unsigned int steps = (range*3) / 10; + Eterm hi, lo, tmp; + unsigned int i; + Eterm *hp; +#ifdef DEBUG + Eterm *hp_limit; +#endif + + if (range - steps < INITIAL_SIZE) { + steps = range - INITIAL_SIZE; + } + + for (i = 0; i < steps; ++i) { + ProcDict *pd = p->dictionary; + if (pd->splitPosition == 0) { + pd->homeSize /= 2; + pd->splitPosition = pd->homeSize; + } + --(pd->splitPosition); + hi = ARRAY_GET(pd, (pd->splitPosition + pd->homeSize)); + lo = ARRAY_GET(pd, pd->splitPosition); + if (hi != NIL) { + if (lo == NIL) { + array_put(&(p->dictionary), pd->splitPosition, hi); + } else { + int needed = 4; + if (is_list(hi) && is_list(lo)) { + needed = 2*list_length(hi); + } + if (HeapWordsLeft(p) < needed) { + BUMP_REDS(p, erts_garbage_collect(p, needed, ret, 1)); + hi = pd->data[(pd->splitPosition + pd->homeSize)]; + lo = pd->data[pd->splitPosition]; + } +#ifdef DEBUG + hp_limit = p->htop + needed; +#endif + if (is_tuple(lo)) { + if (is_tuple(hi)) { + hp = HeapOnlyAlloc(p, 4); + tmp = CONS(hp, hi, NIL); + hp += 2; + array_put(&(p->dictionary), pd->splitPosition, + CONS(hp,lo,tmp)); + hp += 2; + ASSERT(hp <= hp_limit); + } else { /* hi is a list */ + hp = HeapOnlyAlloc(p, 2); + array_put(&(p->dictionary), pd->splitPosition, + CONS(hp, lo, hi)); + hp += 2; + ASSERT(hp <= hp_limit); + } + } else { /* lo is a list */ + if (is_tuple(hi)) { + hp = HeapOnlyAlloc(p, 2); + array_put(&(p->dictionary), pd->splitPosition, + CONS(hp, hi, lo)); + hp += 2; + ASSERT(hp <= hp_limit); + + } else { /* Two lists */ + hp = HeapOnlyAlloc(p, needed); + for (tmp = hi; tmp != NIL; tmp = TCDR(tmp)) { + lo = CONS(hp, TCAR(tmp), lo); + hp += 2; + } + ASSERT(hp <= hp_limit); + array_put(&(p->dictionary), pd->splitPosition, lo); + } + } + } + } + array_put(&(p->dictionary), (pd->splitPosition + pd->homeSize), NIL); + } + if (HASH_RANGE(p->dictionary) <= (p->dictionary->size / 4)) { + array_shrink(&(p->dictionary), (HASH_RANGE(p->dictionary) * 3) / 2); + } +} + +static void grow(Process *p) +{ + unsigned int i,j; + unsigned int steps = p->dictionary->homeSize / 5; + Eterm l1,l2; + Eterm l; + Eterm *hp; + unsigned int pos; + unsigned int homeSize; + int needed = 0; + ProcDict *pd; +#ifdef DEBUG + Eterm *hp_limit; +#endif + + HDEBUGF(("grow: steps = %d", steps)); + if (steps == 0) + steps = 1; + /* Dont grow over MAX_HASH */ + if ((MAX_HASH - steps) <= HASH_RANGE(p->dictionary)) { + return; + } + + /* + * Calculate total number of heap words needed, and garbage collect + * if necessary. + */ + + pd = p->dictionary; + pos = pd->splitPosition; + homeSize = pd->homeSize; + for (i = 0; i < steps; ++i) { + if (pos == homeSize) { + homeSize *= 2; + pos = 0; + } + l = ARRAY_GET(pd, pos); + pos++; + if (is_not_tuple(l)) { + while (l != NIL) { + needed += 2; + l = TCDR(l); + } + } + } + if (HeapWordsLeft(p) < needed) { + BUMP_REDS(p, erts_garbage_collect(p, needed, 0, 0)); + } +#ifdef DEBUG + hp_limit = p->htop + needed; +#endif + + /* + * Now grow. + */ + + for (i = 0; i < steps; ++i) { + ProcDict *pd = p->dictionary; + if (pd->splitPosition == pd->homeSize) { + pd->homeSize *= 2; + pd->splitPosition = 0; + } + pos = pd->splitPosition; + ++pd->splitPosition; /* For the hashes */ + l = ARRAY_GET(pd, pos); + if (is_tuple(l)) { + if (pd_hash_value(pd, tuple_val(l)[1]) != pos) { + array_put(&(p->dictionary), pos + + p->dictionary->homeSize, l); + array_put(&(p->dictionary), pos, NIL); + } + } else { + l2 = NIL; + l1 = l; + for (j = 0; l1 != NIL; l1 = TCDR(l1)) + j += 2; + hp = HeapOnlyAlloc(p, j); + + while (l != NIL) { + if (pd_hash_value(pd, tuple_val(TCAR(l))[1]) == pos) + l1 = CONS(hp, TCAR(l), l1); + else + l2 = CONS(hp, TCAR(l), l2); + hp += 2; + l = TCDR(l); + } + if (l1 != NIL && TCDR(l1) == NIL) + l1 = TCAR(l1); + if (l2 != NIL && TCDR(l2) == NIL) + l2 = TCAR(l2); + ASSERT(hp <= hp_limit); + /* After array_put pd is no longer valid */ + array_put(&(p->dictionary), pos, l1); + array_put(&(p->dictionary), pos + + p->dictionary->homeSize, l2); + } + } + +#ifdef HARDDEBUG + dictionary_dump(p->dictionary,CERR); +#endif +} + +/* +** Array oriented operations +*/ + +static void array_shrink(ProcDict **ppd, unsigned int need) +{ + unsigned int siz = next_array_size(need); + + HDEBUGF(("array_shrink: size = %d, used = %d, need = %d", + (*ppd)->size, (*ppd)->used, need)); + + if (siz > (*ppd)->size) + return; /* Only shrink */ + + *ppd = PD_REALLOC(((void *) *ppd), + PD_SZ2BYTES((*ppd)->size), + PD_SZ2BYTES(siz)); + + (*ppd)->size = siz; + if ((*ppd)->size < (*ppd)->used) + (*ppd)->used = (*ppd)->size; +} + + +static Eterm array_put(ProcDict **ppdict, unsigned int ndx, Eterm term) +{ + unsigned int i; + Eterm ret; + if (*ppdict == NULL) { + Uint siz = next_array_size(ndx+1); + ProcDict *p; + + p = PD_ALLOC(PD_SZ2BYTES(siz)); + for (i = 0; i < siz; ++i) + p->data[i] = NIL; + p->size = siz; + p->homeSize = p->splitPosition = p->numElements = p->used = 0; + *ppdict = p; + } else if (ndx >= (*ppdict)->size) { + Uint osize = (*ppdict)->size; + Uint nsize = next_array_size(ndx+1); + *ppdict = PD_REALLOC(((void *) *ppdict), + PD_SZ2BYTES(osize), + PD_SZ2BYTES(nsize)); + for (i = osize; i < nsize; ++i) + (*ppdict)->data[i] = NIL; + (*ppdict)->size = nsize; + } + ret = (*ppdict)->data[ndx]; + (*ppdict)->data[ndx] = term; + if ((ndx + 1) > (*ppdict)->used) + (*ppdict)->used = ndx + 1; +#ifdef HARDDEBUG + HDEBUGF(("array_put: (*ppdict)->size = %d, (*ppdict)->used = %d, ndx = %d", + (*ppdict)->size, (*ppdict)->used, ndx)); + erts_fprintf(stderr, "%T", term); +#endif /* HARDDEBUG */ + return ret; +} + +/* +** Basic utilities +*/ + +static unsigned int pd_hash_value(ProcDict *pdict, Eterm term) +{ + Uint hash, high; + + hash = MAKE_HASH(term); + high = hash % (pdict->homeSize*2); + if (high >= HASH_RANGE(pdict)) + return hash % pdict->homeSize; + return high; +} + +static unsigned int next_array_size(unsigned int need) +{ + static unsigned int tab[] = + { + 10UL, + 20UL, + 40UL, + 80UL, + 160UL, + 320UL, + 640UL, + 1280UL, + 2560UL, + 5120UL, + 10240UL, + 20480UL, + 40960UL, + 81920UL, + 163840UL, + 327680UL, + 655360UL, + 1310720UL, + 2621440UL, + 5242880UL, + 10485760UL, + 20971520UL, + 41943040UL, + 83886080UL, + 167772160UL, + 335544320UL, + 671088640UL, + 1342177280UL, + 2684354560UL + }; + int hi = sizeof(tab) / sizeof(Uint) - 1; + int lo = 1; + int cur = 4; + + while (hi >= lo) { + if (tab[cur] >= need && tab[cur - 1] < need) + return tab[cur]; + if (tab[cur] > need) + hi = cur - 1; + else + lo = cur + 1; + cur = (hi + lo) / 2; + } + return need; +} + + +/* +** Debug functions +*/ +#ifdef DEBUG + +static void pd_check(ProcDict *pd) +{ + unsigned int i; + Uint num; + if (pd == NULL) + return; + ASSERT(pd->size >= pd->used); + ASSERT(HASH_RANGE(pd) <= MAX_HASH); + for (i = 0, num = 0; i < pd->used; ++i) { + Eterm t = pd->data[i]; + if (is_nil(t)) { + continue; + } else if (is_tuple(t)) { + ++num; + ASSERT(arityval(*tuple_val(t)) == 2); + continue; + } else if (is_list(t)) { + while (t != NIL) { + ++num; + ASSERT(is_tuple(TCAR(t))); + ASSERT(arityval(*(tuple_val(TCAR(t)))) == 2); + t = TCDR(t); + } + continue; + } else { + erl_exit(1, + "Found tag 0x%08x in process dictionary at position %d", + (unsigned long) t, (int) i); + } + } + ASSERT(num == pd->numElements); + ASSERT(pd->splitPosition <= pd->homeSize); +} + +#endif /* DEBUG */ + + +#ifdef HARDDEBUG + +static int hdebugf(char *format, ...) +{ + va_list ap; + + erts_fprintf(stderr, "DEBUG: %s:%d :", hdebugf_file, hdebugf_line); + va_start(ap, format); + erts_vfprintf(stderr, format, ap); + va_end(ap); + erts_fprintf(stderr, "\n"); + return 0; +} + +#endif /* HARDDEBUG */ + diff --git a/erts/emulator/beam/erl_process_dict.h b/erts/emulator/beam/erl_process_dict.h new file mode 100644 index 0000000000..8fad2a67ab --- /dev/null +++ b/erts/emulator/beam/erl_process_dict.h @@ -0,0 +1,42 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1999-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifndef _ERL_PROCESS_DICT_H +#define _ERL_PROCESS_DICT_H +#include "sys.h" + +typedef struct proc_dict { + unsigned int size; + unsigned int used; + unsigned int homeSize; + unsigned int splitPosition; + Uint numElements; + Eterm data[1]; /* The beginning of an array of erlang terms */ +} ProcDict; + +Uint erts_dicts_mem_size(struct process *p); +void erts_erase_dicts(struct process *p); +void erts_dictionary_dump(int to, void *to_arg, ProcDict *pd); +void erts_deep_dictionary_dump(int to, void *to_arg, + ProcDict* pd, void (*cb)(int, void *, Eterm obj)); +Eterm erts_dictionary_copy(struct process *p, ProcDict *pd); + +Eterm erts_pd_hash_get(struct process *p, Eterm id); + +#endif diff --git a/erts/emulator/beam/erl_process_dump.c b/erts/emulator/beam/erl_process_dump.c new file mode 100644 index 0000000000..1666509c72 --- /dev/null +++ b/erts/emulator/beam/erl_process_dump.c @@ -0,0 +1,454 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2003-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "erl_process.h" +#include "error.h" +#include "bif.h" +#include "erl_db.h" +#include "dist.h" +#include "beam_catches.h" +#include "erl_binary.h" +#define ERTS_WANT_EXTERNAL_TAGS +#include "external.h" + +#define WORD_FMT "%X" +#define ADDR_FMT "%X" + +#define OUR_NIL _make_header(0,_TAG_HEADER_FLOAT) + +static void dump_process_info(int to, void *to_arg, Process *p); +static void dump_element(int to, void *to_arg, Eterm x); +static void dump_dist_ext(int to, void *to_arg, ErtsDistExternal *edep); +static void dump_element_nl(int to, void *to_arg, Eterm x); +static int stack_element_dump(int to, void *to_arg, Process* p, Eterm* sp, + int yreg); +static void print_function_from_pc(int to, void *to_arg, Eterm* x); +static void heap_dump(int to, void *to_arg, Eterm x); +static void dump_binaries(int to, void *to_arg, Binary* root); +static void dump_externally(int to, void *to_arg, Eterm term); + +static Binary* all_binaries; + +extern Eterm beam_apply[]; +extern Eterm beam_exit[]; +extern Eterm beam_continue_exit[]; + + +void +erts_deep_process_dump(int to, void *to_arg) +{ + int i; + + all_binaries = NULL; + + for (i = 0; i < erts_max_processes; i++) { + if ((process_tab[i] != NULL) && (process_tab[i]->i != ENULL)) { + if (process_tab[i]->status != P_EXITING) { + Process* p = process_tab[i]; + + if (p->status != P_GARBING) { + dump_process_info(to, to_arg, p); + } + } + } + } + + dump_binaries(to, to_arg, all_binaries); +} + +static void +dump_process_info(int to, void *to_arg, Process *p) +{ + Eterm* sp; + ErlMessage* mp; + int yreg = -1; + + ERTS_SMP_MSGQ_MV_INQ2PRIVQ(p); + + if ((p->trace_flags & F_SENSITIVE) == 0 && p->msg.first) { + erts_print(to, to_arg, "=proc_messages:%T\n", p->id); + for (mp = p->msg.first; mp != NULL; mp = mp->next) { + Eterm mesg = ERL_MESSAGE_TERM(mp); + if (is_value(mesg)) + dump_element(to, to_arg, mesg); + else + dump_dist_ext(to, to_arg, mp->data.dist_ext); + mesg = ERL_MESSAGE_TOKEN(mp); + erts_print(to, to_arg, ":"); + dump_element(to, to_arg, mesg); + erts_print(to, to_arg, "\n"); + } + } + + if ((p->trace_flags & F_SENSITIVE) == 0) { + if (p->dictionary) { + erts_print(to, to_arg, "=proc_dictionary:%T\n", p->id); + erts_deep_dictionary_dump(to, to_arg, + p->dictionary, dump_element_nl); + } + } + + if ((p->trace_flags & F_SENSITIVE) == 0) { + erts_print(to, to_arg, "=proc_stack:%T\n", p->id); + for (sp = p->stop; sp < STACK_START(p); sp++) { + yreg = stack_element_dump(to, to_arg, p, sp, yreg); + } + + erts_print(to, to_arg, "=proc_heap:%T\n", p->id); + for (sp = p->stop; sp < STACK_START(p); sp++) { + Eterm term = *sp; + + if (!is_catch(term) && !is_CP(term)) { + heap_dump(to, to_arg, term); + } + } + for (mp = p->msg.first; mp != NULL; mp = mp->next) { + Eterm mesg = ERL_MESSAGE_TERM(mp); + if (is_value(mesg)) + heap_dump(to, to_arg, mesg); + mesg = ERL_MESSAGE_TOKEN(mp); + heap_dump(to, to_arg, mesg); + } + if (p->dictionary) { + erts_deep_dictionary_dump(to, to_arg, p->dictionary, heap_dump); + } + } +} + +static void +dump_dist_ext(int to, void *to_arg, ErtsDistExternal *edep) +{ + if (!edep) + erts_print(to, to_arg, "D0:E0:"); + else { + byte *e; + size_t sz; + if (!(edep->flags & ERTS_DIST_EXT_ATOM_TRANS_TAB)) + erts_print(to, to_arg, "D0:"); + else { + int i; + erts_print(to, to_arg, "D%X:", edep->attab.size); + for (i = 0; i < edep->attab.size; i++) + dump_element(to, to_arg, edep->attab.atom[i]); + } + sz = edep->ext_endp - edep->extp; + e = edep->extp; + if (edep->flags & ERTS_DIST_EXT_DFLAG_HDR) { + ASSERT(*e != VERSION_MAGIC); + sz++; + } + else { + ASSERT(*e == VERSION_MAGIC); + } + + erts_print(to, to_arg, "E%X:", sz); + if (edep->flags & ERTS_DIST_EXT_DFLAG_HDR) + erts_print(to, to_arg, "%02X", VERSION_MAGIC); + while (e < edep->ext_endp) + erts_print(to, to_arg, "%02X", *e++); + } +} + +static void +dump_element(int to, void *to_arg, Eterm x) +{ + if (is_list(x)) { + erts_print(to, to_arg, "H" WORD_FMT, list_val(x)); + } else if (is_boxed(x)) { + erts_print(to, to_arg, "H" WORD_FMT, boxed_val(x)); + } else if (is_immed(x)) { + if (is_atom(x)) { + unsigned char* s = atom_tab(atom_val(x))->name; + int len = atom_tab(atom_val(x))->len; + int i; + + erts_print(to, to_arg, "A%X:", atom_tab(atom_val(x))->len); + for (i = 0; i < len; i++) { + erts_putc(to, to_arg, *s++); + } + } else if (is_small(x)) { + erts_print(to, to_arg, "I%T", x); + } else if (is_pid(x)) { + erts_print(to, to_arg, "P%T", x); + } else if (is_port(x)) { + erts_print(to, to_arg, "p<%bpu.%bpu>", + port_channel_no(x), port_number(x)); + } else if (is_nil(x)) { + erts_putc(to, to_arg, 'N'); + } + } +} + +static void +dump_element_nl(int to, void *to_arg, Eterm x) +{ + dump_element(to, to_arg, x); + erts_putc(to, to_arg, '\n'); +} + + +static int +stack_element_dump(int to, void *to_arg, Process* p, Eterm* sp, int yreg) +{ + Eterm x = *sp; + + if (yreg < 0 || is_CP(x)) { + erts_print(to, to_arg, "%p:", sp); + } else { + erts_print(to, to_arg, "y%d:", yreg); + yreg++; + } + + if (is_CP(x)) { + erts_print(to, to_arg, "SReturn addr 0x%X (", (Eterm *) x); + print_function_from_pc(to, to_arg, cp_val(x)); + erts_print(to, to_arg, ")\n"); + yreg = 0; + } else if is_catch(x) { + erts_print(to, to_arg, "SCatch 0x%X (", catch_pc(x)); + print_function_from_pc(to, to_arg, catch_pc(x)); + erts_print(to, to_arg, ")\n"); + } else { + dump_element(to, to_arg, x); + erts_putc(to, to_arg, '\n'); + } + return yreg; +} + +static void +print_function_from_pc(int to, void *to_arg, Eterm* x) +{ + Eterm* addr = find_function_from_pc(x); + if (addr == NULL) { + if (x == beam_exit) { + erts_print(to, to_arg, ""); + } else if (x == beam_continue_exit) { + erts_print(to, to_arg, ""); + } else if (x == beam_apply+1) { + erts_print(to, to_arg, ""); + } else { + erts_print(to, to_arg, "unknown function"); + } + } else { + erts_print(to, to_arg, "%T:%T/%bpu + %bpu", + addr[0], addr[1], addr[2], ((x-addr)-2) * sizeof(Eterm)); + } +} + +static void +heap_dump(int to, void *to_arg, Eterm x) +{ + Eterm* ptr; + Eterm last = OUR_NIL; + Eterm* next = &last; + + if (is_immed(x) || is_CP(x)) { + return; + } + + again: + if (x == OUR_NIL) { /* We are done. */ + return; + } if (is_CP(x)) { + next = (Eterm *) x; + } else if (is_list(x)) { + ptr = list_val(x); + if (ptr[0] != OUR_NIL) { + erts_print(to, to_arg, ADDR_FMT ":l", ptr); + dump_element(to, to_arg, ptr[0]); + erts_putc(to, to_arg, '|'); + dump_element(to, to_arg, ptr[1]); + erts_putc(to, to_arg, '\n'); + if (is_immed(ptr[1])) { + ptr[1] = make_small(0); + } + x = ptr[0]; + ptr[0] = (Eterm) next; + next = ptr + 1; + goto again; + } + } else if (is_boxed(x)) { + Eterm hdr; + + ptr = boxed_val(x); + hdr = *ptr; + if (hdr != OUR_NIL) { /* If not visited */ + erts_print(to, to_arg, ADDR_FMT ":", ptr); + if (is_arity_value(hdr)) { + Uint i; + Uint arity = arityval(hdr); + + erts_print(to, to_arg, "t" WORD_FMT ":", arity); + for (i = 1; i <= arity; i++) { + dump_element(to, to_arg, ptr[i]); + if (is_immed(ptr[i])) { + ptr[i] = make_small(0); + } + if (i < arity) { + erts_putc(to, to_arg, ','); + } + } + erts_putc(to, to_arg, '\n'); + if (arity == 0) { + ptr[0] = OUR_NIL; + } else { + x = ptr[arity]; + ptr[0] = (Eterm) next; + next = ptr + arity - 1; + goto again; + } + } else if (hdr == HEADER_FLONUM) { + FloatDef f; + char sbuf[31]; + int i; + + GET_DOUBLE_DATA((ptr+1), f); + i = sys_double_to_chars(f.fd, (char*) sbuf); + sys_memset(sbuf+i, 0, 31-i); + erts_print(to, to_arg, "F%X:%s\n", i, sbuf); + *ptr = OUR_NIL; + } else if (_is_bignum_header(hdr)) { + erts_print(to, to_arg, "B%T\n", x); + *ptr = OUR_NIL; + } else if (is_binary_header(hdr)) { + Uint tag = thing_subtag(hdr); + Uint size = binary_size(x); + Uint i; + + if (tag == HEAP_BINARY_SUBTAG) { + byte* p; + + erts_print(to, to_arg, "Yh%X:", size); + p = binary_bytes(x); + for (i = 0; i < size; i++) { + erts_print(to, to_arg, "%02X", p[i]); + } + } else if (tag == REFC_BINARY_SUBTAG) { + ProcBin* pb = (ProcBin *) binary_val(x); + Binary* val = pb->val; + + if (erts_smp_atomic_xchg(&val->refc, 0) != 0) { + val->flags = (Uint) all_binaries; + all_binaries = val; + } + erts_print(to, to_arg, "Yc%X:%X:%X", val, + pb->bytes - (byte *)val->orig_bytes, + size); + } else if (tag == SUB_BINARY_SUBTAG) { + ErlSubBin* Sb = (ErlSubBin *) binary_val(x); + Eterm* real_bin = binary_val(Sb->orig); + void* val; + + if (thing_subtag(*real_bin) == REFC_BINARY_SUBTAG) { + ProcBin* pb = (ProcBin *) real_bin; + val = pb->val; + } else { /* Heap binary */ + val = real_bin; + } + erts_print(to, to_arg, "Ys%X:%X:%X", val, Sb->offs, size); + } + erts_putc(to, to_arg, '\n'); + *ptr = OUR_NIL; + } else if (is_external_pid_header(hdr)) { + erts_print(to, to_arg, "P%T\n", x); + *ptr = OUR_NIL; + } else if (is_external_port_header(hdr)) { + erts_print(to, to_arg, "p<%bpu.%bpu>\n", + port_channel_no(x), port_number(x)); + *ptr = OUR_NIL; + } else { + /* + * All other we dump in the external term format. + */ + dump_externally(to, to_arg, x); + erts_putc(to, to_arg, '\n'); + *ptr = OUR_NIL; + } + } + } + + x = *next; + *next = OUR_NIL; + next--; + goto again; +} + +static void +dump_binaries(int to, void *to_arg, Binary* current) +{ + while (current) { + long i; + long size = current->orig_size; + byte* bytes = (byte*) current->orig_bytes; + + erts_print(to, to_arg, "=binary:%X\n", current); + erts_print(to, to_arg, "%X:", size); + for (i = 0; i < size; i++) { + erts_print(to, to_arg, "%02X", bytes[i]); + } + erts_putc(to, to_arg, '\n'); + current = (Binary *) current->flags; + } +} + +static void +dump_externally(int to, void *to_arg, Eterm term) +{ + byte sbuf[1024]; /* encode and hope for the best ... */ + byte* s; + byte* p; + + if (is_fun(term)) { + /* + * The fun's environment used to cause trouble. There were + * two kind of problems: + * + * 1. A term used in the environment could already have been + * dumped and thus destroyed (since dumping is destructive). + * + * 2. A term in the environment could be too big, so that + * the buffer for external format overflowed (allocating + * memory is not really a solution, as it could be exhausted). + * + * Simple solution: Set all variables in the environment to NIL. + * The crashdump_viewer does not allow inspection of them anyway. + */ + ErlFunThing* funp = (ErlFunThing *) fun_val(term); + Uint num_free = funp->num_free; + Uint i; + + for (i = 0; i < num_free; i++) { + funp->env[i] = NIL; + } + } + + s = p = sbuf; + erts_encode_ext(term, &p); + erts_print(to, to_arg, "E%X:", p-s); + while (s < p) { + erts_print(to, to_arg, "%02X", *s++); + } +} diff --git a/erts/emulator/beam/erl_process_lock.c b/erts/emulator/beam/erl_process_lock.c new file mode 100644 index 0000000000..52440fb635 --- /dev/null +++ b/erts/emulator/beam/erl_process_lock.c @@ -0,0 +1,1431 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2007-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + + +/* + * Description: Impementation of Erlang process locks. + * + * Author: Rickard Green + */ + +/* + * A short explanation of the process lock implementation: + * Each process has a lock bitfield and a number of lock wait + * queues. + * The bit field contains of a number of lock flags (L1, L2, ...) + * and a number of wait flags (W1, W2, ...). Each lock flag has a + * corresponding wait flag. The bit field isn't guarranteed to be + * larger than 32-bits which sets a maximum of 16 different locks + * per process. Currently, only 4 locks per process are used. The + * bit field is operated on by use of atomic operations (custom + * made bitwise atomic operations). When a lock is locked the + * corresponding lock bit is set. When a thread is waiting on a + * lock the wait flag for the lock is set. + * The process table is protected by pix (process index) locks + * which is spinlocks that protects a number of process indices in + * the process table. The pix locks also protects the lock queues + * and modifications of wait flags. + * When acquiring a process lock we first try to set the lock + * flag. If we are able to set the lock flag and the wait flag + * isn't set we are done. If the lock flag was already set we + * have to acquire the pix lock, set the wait flag, and put + * ourselves in the wait queue. + * Process locks will always be acquired in fifo order. + * When releasing a process lock we first unset all lock flags + * whose corresponding wait flag is clear (which will succeed). + * If wait flags were set for the locks being released, we acquire + * the pix lock, and transfer the lock to the first thread + * in the wait queue. + * Note that wait flags may be read without the pix lock, but + * it is important that wait flags only are modified when the pix + * lock is held. + * This implementation assumes that erts_smp_atomic_or_retold() + * provides necessary memorybarriers for a lock operation, and that + * erts_smp_atomic_and_retold() provides necessary memorybarriers + * for an unlock operation. + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "erl_process.h" + +const Process erts_proc_lock_busy; + +#ifdef ERTS_SMP + +/*#define ERTS_PROC_LOCK_SPIN_ON_GATE*/ +#define ERTS_PROC_LOCK_SPIN_COUNT_MAX 16000 +#define ERTS_PROC_LOCK_SPIN_COUNT_BASE 1000 + +#ifdef ERTS_PROC_LOCK_DEBUG +#define ERTS_PROC_LOCK_HARD_DEBUG +#endif + +#ifdef ERTS_PROC_LOCK_HARD_DEBUG +static void check_queue(erts_proc_lock_t *lck); +#endif + + +typedef struct erts_proc_lock_waiter_t_ erts_proc_lock_waiter_t; +struct erts_proc_lock_waiter_t_ { + erts_proc_lock_waiter_t *next; + erts_proc_lock_waiter_t *prev; + ErtsProcLocks wait_locks; + erts_smp_gate_t gate; + erts_proc_lock_queues_t *queues; +}; + +struct erts_proc_lock_queues_t_ { + erts_proc_lock_queues_t *next; + erts_proc_lock_waiter_t *queue[ERTS_PROC_LOCK_MAX_BIT+1]; +}; + +struct erts_proc_lock_thr_spec_data_t_ { + erts_proc_lock_queues_t *qs; + erts_proc_lock_waiter_t *wtr; +}; + +static erts_proc_lock_queues_t zeroqs = {0}; + +static erts_smp_spinlock_t wtr_lock; +static erts_proc_lock_waiter_t *waiter_free_list; +static erts_proc_lock_queues_t *queue_free_list; +static erts_tsd_key_t waiter_key; + +#ifdef ERTS_ENABLE_LOCK_CHECK +static struct { + Sint16 proc_lock_main; + Sint16 proc_lock_link; + Sint16 proc_lock_msgq; + Sint16 proc_lock_status; +} lc_id; +#endif + +erts_pix_lock_t erts_pix_locks[ERTS_NO_OF_PIX_LOCKS]; + +static int proc_lock_spin_count; +static int proc_lock_trans_spin_cost; + +static void cleanup_waiter(void); + +void +erts_init_proc_lock(void) +{ + int i; + int cpus; + erts_smp_spinlock_init(&wtr_lock, "proc_lck_wtr_alloc"); + for (i = 0; i < ERTS_NO_OF_PIX_LOCKS; i++) { +#if ERTS_PROC_LOCK_MUTEX_IMPL +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_smp_mtx_init_x(&erts_pix_locks[i].u.mtx, "pix_lock", make_small(i)); +#else + erts_smp_mtx_init(&erts_pix_locks[i].u.mtx, "pix_lock"); +#endif +#else +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_smp_spinlock_init_x(&erts_pix_locks[i].u.spnlck, "pix_lock", make_small(i)); +#else + erts_smp_spinlock_init(&erts_pix_locks[i].u.spnlck, "pix_lock"); +#endif +#endif + } + waiter_free_list = NULL; + queue_free_list = NULL; + erts_tsd_key_create(&waiter_key); + erts_thr_install_exit_handler(cleanup_waiter); +#ifdef ERTS_ENABLE_LOCK_CHECK + lc_id.proc_lock_main = erts_lc_get_lock_order_id("proc_main"); + lc_id.proc_lock_link = erts_lc_get_lock_order_id("proc_link"); + lc_id.proc_lock_msgq = erts_lc_get_lock_order_id("proc_msgq"); + lc_id.proc_lock_status = erts_lc_get_lock_order_id("proc_status"); +#endif + cpus = erts_get_cpu_configured(erts_cpuinfo); + if (cpus > 1) + proc_lock_spin_count = (ERTS_PROC_LOCK_SPIN_COUNT_BASE + * ((int) erts_no_schedulers)); + else if (cpus == 1) + proc_lock_spin_count = 0; + else /* No of cpus unknown. Assume multi proc, but be conservative. */ + proc_lock_spin_count = ERTS_PROC_LOCK_SPIN_COUNT_BASE; + if (proc_lock_spin_count > ERTS_PROC_LOCK_SPIN_COUNT_MAX) + proc_lock_spin_count = ERTS_PROC_LOCK_SPIN_COUNT_MAX; + proc_lock_trans_spin_cost = proc_lock_spin_count/20; +} + +static ERTS_INLINE erts_proc_lock_waiter_t * +alloc_wtr(void) +{ + erts_proc_lock_waiter_t *wtr; + erts_smp_spin_lock(&wtr_lock); + wtr = waiter_free_list; + if (wtr) { + waiter_free_list = wtr->next; + ERTS_LC_ASSERT(queue_free_list); + wtr->queues = queue_free_list; + queue_free_list = wtr->queues->next; + erts_smp_spin_unlock(&wtr_lock); + } + else { + erts_smp_spin_unlock(&wtr_lock); + wtr = erts_alloc(ERTS_ALC_T_PROC_LCK_WTR, + sizeof(erts_proc_lock_waiter_t)); + erts_smp_gate_init(&wtr->gate); + wtr->wait_locks = (ErtsProcLocks) 0; + wtr->queues = erts_alloc(ERTS_ALC_T_PROC_LCK_QS, + sizeof(erts_proc_lock_queues_t)); + sys_memcpy((void *) wtr->queues, + (void *) &zeroqs, + sizeof(erts_proc_lock_queues_t)); + } + return wtr; +} + +#ifdef ERTS_ENABLE_LOCK_CHECK +static void +check_unused_waiter(erts_proc_lock_waiter_t *wtr) +{ + int i; + ERTS_LC_ASSERT(wtr->wait_locks == 0); + for (i = 0; i <= ERTS_PROC_LOCK_MAX_BIT; i++) + ERTS_LC_ASSERT(!wtr->queues->queue[i]); +} +#define CHECK_UNUSED_WAITER(W) check_unused_waiter((W)) +#else +#define CHECK_UNUSED_WAITER(W) +#endif + + +static ERTS_INLINE void +free_wtr(erts_proc_lock_waiter_t *wtr) +{ + CHECK_UNUSED_WAITER(wtr); + erts_smp_spin_lock(&wtr_lock); + wtr->next = waiter_free_list; + waiter_free_list = wtr; + wtr->queues->next = queue_free_list; + queue_free_list = wtr->queues; + erts_smp_spin_unlock(&wtr_lock); +} + +void +erts_proc_lock_prepare_proc_lock_waiter(void) +{ + erts_tsd_set(waiter_key, (void *) alloc_wtr()); +} + + +static void +cleanup_waiter(void) +{ + erts_proc_lock_waiter_t *wtr = erts_tsd_get(waiter_key); + if (wtr) + free_wtr(wtr); +} + + +/* + * Waiters are queued in a circular double linked list; + * where qs->queue[lock_ix] is the first waiter in queue, and + * qs->queue[lock_ix]->prev is the last waiter in queue. + */ + +static ERTS_INLINE void +enqueue_waiter(erts_proc_lock_queues_t *qs, + int ix, + erts_proc_lock_waiter_t *wtr) +{ + if (!qs->queue[ix]) { + qs->queue[ix] = wtr; + wtr->next = wtr; + wtr->prev = wtr; + } + else { + ERTS_LC_ASSERT(qs->queue[ix]->next && qs->queue[ix]->prev); + wtr->next = qs->queue[ix]; + wtr->prev = qs->queue[ix]->prev; + wtr->prev->next = wtr; + qs->queue[ix]->prev = wtr; + } +} + +static erts_proc_lock_waiter_t * +dequeue_waiter(erts_proc_lock_queues_t *qs, int ix) +{ + erts_proc_lock_waiter_t *wtr = qs->queue[ix]; + ERTS_LC_ASSERT(qs->queue[ix]); + if (wtr->next == wtr) { + ERTS_LC_ASSERT(qs->queue[ix]->prev == wtr); + qs->queue[ix] = NULL; + } + else { + ERTS_LC_ASSERT(wtr->next != wtr); + ERTS_LC_ASSERT(wtr->prev != wtr); + wtr->next->prev = wtr->prev; + wtr->prev->next = wtr->next; + qs->queue[ix] = wtr->next; + } + return wtr; +} + +/* + * Tries to aquire as many locks as possible in lock order, + * and sets the wait flag on the first lock not possible to + * aquire. + * + * Note: We need the pix lock during this operation. Wait + * flags are only allowed to be manipulated under pix + * lock. + */ +static ERTS_INLINE void +try_aquire(erts_proc_lock_t *lck, erts_proc_lock_waiter_t *wtr) +{ + ErtsProcLocks got_locks = (ErtsProcLocks) 0; + ErtsProcLocks locks = wtr->wait_locks; + int lock_no; + + ERTS_LC_ASSERT(lck->queues); + ERTS_LC_ASSERT(got_locks != locks); + + for (lock_no = 0; lock_no <= ERTS_PROC_LOCK_MAX_BIT; lock_no++) { + ErtsProcLocks lock = ((ErtsProcLocks) 1) << lock_no; + if (locks & lock) { + ErtsProcLocks wflg, old_lflgs; + if (lck->queues->queue[lock_no]) { + /* Others already waiting */ + enqueue: + ERTS_LC_ASSERT(ERTS_PROC_LOCK_FLGS_READ_(lck) + & (lock << ERTS_PROC_LOCK_WAITER_SHIFT)); + enqueue_waiter(lck->queues, lock_no, wtr); + break; + } + wflg = lock << ERTS_PROC_LOCK_WAITER_SHIFT; + old_lflgs = ERTS_PROC_LOCK_FLGS_BOR_(lck, wflg | lock); + if (old_lflgs & lock) { + /* Didn't get the lock */ + goto enqueue; + } + else { + /* Got the lock */ + got_locks |= lock; + ERTS_LC_ASSERT(!(old_lflgs & wflg)); + /* No one else can be waiting for the lock; remove wait flag */ + (void) ERTS_PROC_LOCK_FLGS_BAND_(lck, ~wflg); + if (got_locks == locks) + break; + } + } + } + + wtr->wait_locks &= ~got_locks; +} + +/* + * Transfer 'trnsfr_lcks' held by this executing thread to other + * threads waiting for the locks. When a lock has been transferred + * we also have to try to aquire as many lock as possible for the + * other thread. + */ +static int +transfer_locks(Process *p, + ErtsProcLocks trnsfr_lcks, + erts_pix_lock_t *pix_lock, + int unlock) +{ + int transferred = 0; + erts_proc_lock_waiter_t *wake = NULL; + erts_proc_lock_waiter_t *wtr; + ErtsProcLocks unset_waiter = 0; + ErtsProcLocks tlocks = trnsfr_lcks; + int lock_no; + + ERTS_LC_ASSERT(erts_lc_pix_lock_is_locked(pix_lock)); + +#ifdef ERTS_PROC_LOCK_HARD_DEBUG + check_queue(&p->lock); +#endif + + for (lock_no = 0; tlocks && lock_no <= ERTS_PROC_LOCK_MAX_BIT; lock_no++) { + ErtsProcLocks lock = ((ErtsProcLocks) 1) << lock_no; + if (tlocks & lock) { + erts_proc_lock_queues_t *qs = p->lock.queues; + /* Transfer lock */ +#ifdef ERTS_ENABLE_LOCK_CHECK + tlocks &= ~lock; +#endif + ERTS_LC_ASSERT(ERTS_PROC_LOCK_FLGS_READ_(&p->lock) + & (lock << ERTS_PROC_LOCK_WAITER_SHIFT)); + transferred++; + wtr = dequeue_waiter(qs, lock_no); + ERTS_LC_ASSERT(wtr); + if (!qs->queue[lock_no]) + unset_waiter |= lock; + ERTS_LC_ASSERT(wtr->wait_locks & lock); + wtr->wait_locks &= ~lock; + if (wtr->wait_locks) + try_aquire(&p->lock, wtr); + if (!wtr->wait_locks) { + /* + * The other thread got all locks it needs; + * need to wake it up. + */ + wtr->next = wake; + wake = wtr; + } + } + + } + + if (unset_waiter) { + unset_waiter <<= ERTS_PROC_LOCK_WAITER_SHIFT; + (void) ERTS_PROC_LOCK_FLGS_BAND_(&p->lock, ~unset_waiter); + } + +#ifdef ERTS_PROC_LOCK_HARD_DEBUG + check_queue(&p->lock); +#endif + + ERTS_LC_ASSERT(tlocks == 0); /* We should have transferred all of them */ + + if (!wake) { + if (unlock) + erts_pix_unlock(pix_lock); + } + else { + erts_pix_unlock(pix_lock); + + do { + erts_proc_lock_waiter_t *tmp = wake; + wake = wake->next; + erts_smp_gate_let_through(&tmp->gate, 1); + } while (wake); + + if (!unlock) + erts_pix_lock(pix_lock); + } + return transferred; +} + +/* + * Determine which locks in 'need_locks' are not currently locked in + * 'in_use', but do not return any locks "above" some lock we need, + * so we do not attempt to grab locks out of order. + * + * For example, if we want to lock 10111, and 00100 was already locked, this + * would return 00011, indicating we should not try for 10000 yet because + * that would be a lock-ordering violation. + */ +static ERTS_INLINE ErtsProcLocks +in_order_locks(ErtsProcLocks in_use, ErtsProcLocks need_locks) +{ + /* All locks we want that are already locked by someone else. */ + ErtsProcLocks busy = in_use & need_locks; + + /* Just the lowest numbered lock we want that's in use; 0 if none. */ + ErtsProcLocks lowest_busy = busy & -busy; + + /* All locks below the lowest one we want that's in use already. */ + return need_locks & (lowest_busy - 1); +} + +/* + * Try to grab locks one at a time in lock order and wait on the lowest + * lock we fail to grab, if any. + * + * If successful, this returns 0 and all locks in 'need_locks' are held. + * + * On entry, the pix lock is held iff !ERTS_PROC_LOCK_ATOMIC_IMPL. + * On exit it is not held. + */ +static void +wait_for_locks(Process *p, + erts_pix_lock_t *pixlck, + ErtsProcLocks locks, + ErtsProcLocks need_locks, + ErtsProcLocks olflgs) +{ + erts_pix_lock_t *pix_lock = pixlck ? pixlck : ERTS_PID2PIXLOCK(p->id); + int tsd; + erts_proc_lock_waiter_t *wtr; + + /* Acquire a waiter object on which this thread can wait. */ + wtr = erts_tsd_get(waiter_key); + if (wtr) + tsd = 1; + else { +#if ERTS_PROC_LOCK_SPINLOCK_IMPL && !ERTS_PROC_LOCK_ATOMIC_IMPL + erts_pix_unlock(pix_lock); +#endif + wtr = alloc_wtr(); + tsd = 0; +#if ERTS_PROC_LOCK_SPINLOCK_IMPL && !ERTS_PROC_LOCK_ATOMIC_IMPL + erts_pix_lock(pix_lock); +#endif + } + + /* Record which locks this waiter needs. */ + wtr->wait_locks = need_locks; + +#if ERTS_PROC_LOCK_ATOMIC_IMPL + erts_pix_lock(pix_lock); +#endif + + ERTS_LC_ASSERT(erts_lc_pix_lock_is_locked(pix_lock)); + + /* Provide the process with waiter queues, if it doesn't have one. */ + if (!p->lock.queues) { + wtr->queues->next = NULL; + p->lock.queues = wtr->queues; + } + else { + wtr->queues->next = p->lock.queues->next; + p->lock.queues->next = wtr->queues; + } + +#ifdef ERTS_PROC_LOCK_HARD_DEBUG + check_queue(&p->lock); +#endif + + /* Try to aquire locks one at a time in lock order and set wait flag */ + try_aquire(&p->lock, wtr); + +#ifdef ERTS_PROC_LOCK_HARD_DEBUG + check_queue(&p->lock); +#endif + + if (wtr->wait_locks) { /* We didn't get them all; need to wait... */ + /* Got to wait for locks... */ + erts_pix_unlock(pix_lock); + + /* + * Wait for needed locks. When we return all needed locks have + * have been acquired by other threads and transfered to us. + */ +#ifdef ERTS_PROC_LOCK_SPIN_ON_GATE + erts_smp_gate_swait(&wtr->gate, proc_lock_spin_count); +#else + erts_smp_gate_wait(&wtr->gate); +#endif + + erts_pix_lock(pix_lock); + } + + /* Recover some queues to store in the waiter. */ + ERTS_LC_ASSERT(p->lock.queues); + if (p->lock.queues->next) { + wtr->queues = p->lock.queues->next; + p->lock.queues->next = wtr->queues->next; + } + else { + wtr->queues = p->lock.queues; + p->lock.queues = NULL; + } + + erts_pix_unlock(pix_lock); + + ERTS_LC_ASSERT(locks == (ERTS_PROC_LOCK_FLGS_READ_(&p->lock) & locks)); + + if (tsd) + CHECK_UNUSED_WAITER(wtr); + else + free_wtr(wtr); +} + +/* + * erts_proc_lock_failed() is called when erts_smp_proc_lock() + * wasn't able to lock all locks. We may need to transfer locks + * to waiters and wait for our turn on locks. + * + * Iff !ERTS_PROC_LOCK_ATOMIC_IMPL, the pix lock is locked on entry. + * + * This always returns with the pix lock unlocked. + */ +void +erts_proc_lock_failed(Process *p, + erts_pix_lock_t *pixlck, + ErtsProcLocks locks, + ErtsProcLocks old_lflgs) +{ +#ifdef ERTS_PROC_LOCK_SPIN_ON_GATE + int spin_count = 0; +#else + int spin_count = proc_lock_spin_count; +#endif + + ErtsProcLocks need_locks = locks; + ErtsProcLocks olflgs = old_lflgs; + + while (need_locks != 0) + { + ErtsProcLocks can_grab = in_order_locks(olflgs, need_locks); + + if (can_grab == 0) + { + /* Someone already has the lowest-numbered lock we want. */ + + if (spin_count-- <= 0) + { + /* Too many retries, give up and sleep for the lock. */ + wait_for_locks(p, pixlck, locks, need_locks, olflgs); + return; + } + + olflgs = ERTS_PROC_LOCK_FLGS_READ_(&p->lock); + } + else + { + /* Try to grab all of the grabbable locks at once with cmpxchg. */ + ErtsProcLocks grabbed = olflgs | can_grab; + ErtsProcLocks nflgs = + ERTS_PROC_LOCK_FLGS_CMPXCHG_(&p->lock, grabbed, olflgs); + + if (nflgs == olflgs) + { + /* Success! We grabbed the 'can_grab' locks. */ + olflgs = grabbed; + need_locks &= ~can_grab; + +#ifndef ERTS_PROC_LOCK_SPIN_ON_GATE + /* Since we made progress, reset the spin count. */ + spin_count = proc_lock_spin_count; +#endif + } + else + { + /* Compare-and-exchange failed, try again. */ + olflgs = nflgs; + } + } + } + + /* Now we have all of the locks we wanted. */ + +#if !ERTS_PROC_LOCK_ATOMIC_IMPL + erts_pix_unlock(pixlck); +#endif +} + +/* + * erts_proc_unlock_failed() is called when erts_smp_proc_unlock() + * wasn't able to unlock all locks. We may need to transfer locks + * to waiters. + */ +void +erts_proc_unlock_failed(Process *p, + erts_pix_lock_t *pixlck, + ErtsProcLocks wait_locks) +{ + erts_pix_lock_t *pix_lock = pixlck ? pixlck : ERTS_PID2PIXLOCK(p->id); + +#if ERTS_PROC_LOCK_ATOMIC_IMPL + erts_pix_lock(pix_lock); +#endif + + transfer_locks(p, wait_locks, pix_lock, 1); /* unlocks pix_lock */ +} + +/* + * proc_safelock() locks process locks on two processes. In order + * to avoid a deadlock, proc_safelock() unlocks those locks that + * needs to be unlocked, and then acquires locks in lock order + * (including the previously unlocked ones). + */ + +static void +proc_safelock(Process *a_proc, + erts_pix_lock_t *a_pix_lck, + ErtsProcLocks a_have_locks, + ErtsProcLocks a_need_locks, + Process *b_proc, + erts_pix_lock_t *b_pix_lck, + ErtsProcLocks b_have_locks, + ErtsProcLocks b_need_locks) +{ + Process *p1, *p2; + Eterm pid1, pid2; + erts_pix_lock_t *pix_lck1, *pix_lck2; + ErtsProcLocks need_locks1, have_locks1, need_locks2, have_locks2; + ErtsProcLocks unlock_mask; + int lock_no, refc1 = 0, refc2 = 0; + + ERTS_LC_ASSERT(b_proc); + + + /* Determine inter process lock order... + * Locks with the same lock order should be locked on p1 before p2. + */ + if (a_proc) { + if (a_proc->id < b_proc->id) { + p1 = a_proc; + pid1 = a_proc->id; + pix_lck1 = a_pix_lck; + need_locks1 = a_need_locks; + have_locks1 = a_have_locks; + p2 = b_proc; + pid2 = b_proc->id; + pix_lck2 = b_pix_lck; + need_locks2 = b_need_locks; + have_locks2 = b_have_locks; + } + else if (a_proc->id > b_proc->id) { + p1 = b_proc; + pid1 = b_proc->id; + pix_lck1 = b_pix_lck; + need_locks1 = b_need_locks; + have_locks1 = b_have_locks; + p2 = a_proc; + pid2 = a_proc->id; + pix_lck2 = a_pix_lck; + need_locks2 = a_need_locks; + have_locks2 = a_have_locks; + } + else { + ERTS_LC_ASSERT(a_proc == b_proc); + ERTS_LC_ASSERT(a_proc->id == b_proc->id); + p1 = a_proc; + pid1 = a_proc->id; + pix_lck1 = a_pix_lck; + need_locks1 = a_need_locks | b_need_locks; + have_locks1 = a_have_locks | b_have_locks; + p2 = NULL; + pid2 = 0; + pix_lck2 = NULL; + need_locks2 = 0; + have_locks2 = 0; + } + } + else { + p1 = b_proc; + pid1 = b_proc->id; + pix_lck1 = b_pix_lck; + need_locks1 = b_need_locks; + have_locks1 = b_have_locks; + p2 = NULL; + pid2 = 0; + pix_lck2 = NULL; + need_locks2 = 0; + have_locks2 = 0; +#ifdef ERTS_ENABLE_LOCK_CHECK + a_need_locks = 0; + a_have_locks = 0; +#endif + } + +#ifdef ERTS_ENABLE_LOCK_CHECK + if (p1) + erts_proc_lc_chk_proc_locks(p1, have_locks1); + if (p2) + erts_proc_lc_chk_proc_locks(p2, have_locks2); + + if ((need_locks1 & have_locks1) != have_locks1) + erts_lc_fail("Thread tries to release process lock(s) " + "on %T via erts_proc_safelock().", pid1); + if ((need_locks2 & have_locks2) != have_locks2) + erts_lc_fail("Thread tries to release process lock(s) " + "on %T via erts_proc_safelock().", + pid2); +#endif + + + need_locks1 &= ~have_locks1; + need_locks2 &= ~have_locks2; + + /* Figure out the range of locks that needs to be unlocked... */ + unlock_mask = ERTS_PROC_LOCKS_ALL; + for (lock_no = 0; + lock_no <= ERTS_PROC_LOCK_MAX_BIT; + lock_no++) { + ErtsProcLocks lock = (1 << lock_no); + if (lock & need_locks1) + break; + unlock_mask &= ~lock; + if (lock & need_locks2) + break; + } + + /* ... and unlock locks in that range... */ + if (have_locks1 || have_locks2) { + ErtsProcLocks unlock_locks; + unlock_locks = unlock_mask & have_locks1; + if (unlock_locks) { + have_locks1 &= ~unlock_locks; + need_locks1 |= unlock_locks; + if (!have_locks1) { + refc1 = 1; + erts_smp_proc_inc_refc(p1); + } + erts_smp_proc_unlock__(p1, pix_lck1, unlock_locks); + } + unlock_locks = unlock_mask & have_locks2; + if (unlock_locks) { + have_locks2 &= ~unlock_locks; + need_locks2 |= unlock_locks; + if (!have_locks2) { + refc2 = 1; + erts_smp_proc_inc_refc(p2); + } + erts_smp_proc_unlock__(p2, pix_lck2, unlock_locks); + } + } + + /* + * lock_no equals the number of the first lock to lock on + * either p1 *or* p2. + */ + + +#ifdef ERTS_ENABLE_LOCK_CHECK + if (p1) + erts_proc_lc_chk_proc_locks(p1, have_locks1); + if (p2) + erts_proc_lc_chk_proc_locks(p2, have_locks2); +#endif + + /* Lock locks in lock order... */ + while (lock_no <= ERTS_PROC_LOCK_MAX_BIT) { + ErtsProcLocks locks; + ErtsProcLocks lock = (1 << lock_no); + ErtsProcLocks lock_mask = 0; + if (need_locks1 & lock) { + do { + lock = (1 << lock_no++); + lock_mask |= lock; + } while (lock_no <= ERTS_PROC_LOCK_MAX_BIT + && !(need_locks2 & lock)); + if (need_locks2 & lock) + lock_no--; + locks = need_locks1 & lock_mask; + erts_smp_proc_lock__(p1, pix_lck1, locks); + have_locks1 |= locks; + need_locks1 &= ~locks; + } + else if (need_locks2 & lock) { + while (lock_no <= ERTS_PROC_LOCK_MAX_BIT + && !(need_locks1 & lock)) { + lock_mask |= lock; + lock = (1 << ++lock_no); + } + locks = need_locks2 & lock_mask; + erts_smp_proc_lock__(p2, pix_lck2, locks); + have_locks2 |= locks; + need_locks2 &= ~locks; + } + else + lock_no++; + } + +#ifdef ERTS_ENABLE_LOCK_CHECK + if (p1) + erts_proc_lc_chk_proc_locks(p1, have_locks1); + if (p2) + erts_proc_lc_chk_proc_locks(p2, have_locks2); + + if (p1 && p2) { + if (p1 == a_proc) { + ERTS_LC_ASSERT(a_need_locks == have_locks1); + ERTS_LC_ASSERT(b_need_locks == have_locks2); + } + else { + ERTS_LC_ASSERT(a_need_locks == have_locks2); + ERTS_LC_ASSERT(b_need_locks == have_locks1); + } + } + else { + ERTS_LC_ASSERT(p1); + if (a_proc) { + ERTS_LC_ASSERT(have_locks1 == (a_need_locks | b_need_locks)); + } + else { + ERTS_LC_ASSERT(have_locks1 == b_need_locks); + } + } +#endif + + if (refc1) + erts_smp_proc_dec_refc(p1); + if (refc2) + erts_smp_proc_dec_refc(p2); +} + +void +erts_proc_safelock(Process *a_proc, + ErtsProcLocks a_have_locks, + ErtsProcLocks a_need_locks, + Process *b_proc, + ErtsProcLocks b_have_locks, + ErtsProcLocks b_need_locks) +{ + proc_safelock(a_proc, + a_proc ? ERTS_PID2PIXLOCK(a_proc->id) : NULL, + a_have_locks, + a_need_locks, + b_proc, + b_proc ? ERTS_PID2PIXLOCK(b_proc->id) : NULL, + b_have_locks, + b_need_locks); +} + +/* + * erts_pid2proc_safelock() is called from erts_pid2proc_opt() when + * it wasn't possible to trylock all locks needed. + * c_p - current process + * c_p_have_locks - locks held on c_p + * pid - process id of process we are looking up + * proc - process struct of process we are looking + * up (both in and out argument) + * need_locks - all locks we need (including have_locks) + * pix_lock - pix lock for process we are looking up + * flags - option flags + */ +void +erts_pid2proc_safelock(Process *c_p, + ErtsProcLocks c_p_have_locks, + Process **proc, + ErtsProcLocks need_locks, + erts_pix_lock_t *pix_lock, + int flags) +{ + Process *p = *proc; + ERTS_LC_ASSERT(p->lock.refc > 0); + ERTS_LC_ASSERT(process_tab[internal_pid_index(p->id)] == p); + p->lock.refc++; + erts_pix_unlock(pix_lock); + + proc_safelock(c_p, + c_p ? ERTS_PID2PIXLOCK(c_p->id) : NULL, + c_p_have_locks, + c_p_have_locks, + p, + pix_lock, + 0, + need_locks); + + erts_pix_lock(pix_lock); + + if (!p->is_exiting + || ((flags & ERTS_P2P_FLG_ALLOW_OTHER_X) + && process_tab[internal_pid_index(p->id)] == p)) { + ERTS_LC_ASSERT(p->lock.refc > 1); + p->lock.refc--; + } + else { + /* No proc. Note, we need to keep refc until after process unlock */ + erts_pix_unlock(pix_lock); + erts_smp_proc_unlock__(p, pix_lock, need_locks); + *proc = NULL; + erts_pix_lock(pix_lock); + ERTS_LC_ASSERT(p->lock.refc > 0); + if (--p->lock.refc == 0) { + erts_pix_unlock(pix_lock); + erts_free_proc(p); + erts_pix_lock(pix_lock); + } + } +} + +void +erts_proc_lock_init(Process *p) +{ + /* We always start with all locks locked */ +#if ERTS_PROC_LOCK_ATOMIC_IMPL + erts_smp_atomic_init(&p->lock.flags, (long) ERTS_PROC_LOCKS_ALL); +#else + p->lock.flags = ERTS_PROC_LOCKS_ALL; +#endif + p->lock.queues = NULL; + p->lock.refc = 1; +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_proc_lock_init(p); + erts_lcnt_proc_lock(&(p->lock), ERTS_PROC_LOCKS_ALL); + erts_lcnt_proc_lock_post_x(&(p->lock), ERTS_PROC_LOCKS_ALL, __FILE__, __LINE__); +#endif + +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_proc_lc_trylock(p, ERTS_PROC_LOCKS_ALL, 1); +#endif +#ifdef ERTS_PROC_LOCK_DEBUG + { + int i; + for (i = 0; i <= ERTS_PROC_LOCK_MAX_BIT; i++) + erts_smp_atomic_init(&p->lock.locked[i], (long) 1); + } +#endif +} + +/* --- Process lock counting ----------------------------------------------- */ + +#ifdef ERTS_ENABLE_LOCK_COUNT +void erts_lcnt_proc_lock_init(Process *p) { + + if (p->id != ERTS_INVALID_PID) { + erts_lcnt_init_lock_x(&(p->lock.lcnt_main), "proc_main", ERTS_LCNT_LT_PROCLOCK, p->id); + erts_lcnt_init_lock_x(&(p->lock.lcnt_msgq), "proc_msgq", ERTS_LCNT_LT_PROCLOCK, p->id); + erts_lcnt_init_lock_x(&(p->lock.lcnt_link), "proc_link", ERTS_LCNT_LT_PROCLOCK, p->id); + erts_lcnt_init_lock_x(&(p->lock.lcnt_status), "proc_status", ERTS_LCNT_LT_PROCLOCK, p->id); + } else { + erts_lcnt_init_lock(&(p->lock.lcnt_main), "proc_main", ERTS_LCNT_LT_PROCLOCK); + erts_lcnt_init_lock(&(p->lock.lcnt_msgq), "proc_msgq", ERTS_LCNT_LT_PROCLOCK); + erts_lcnt_init_lock(&(p->lock.lcnt_link), "proc_link", ERTS_LCNT_LT_PROCLOCK); + erts_lcnt_init_lock(&(p->lock.lcnt_status), "proc_status", ERTS_LCNT_LT_PROCLOCK); + } +} + + +void erts_lcnt_proc_lock_destroy(Process *p) { + erts_lcnt_destroy_lock(&(p->lock.lcnt_main)); + erts_lcnt_destroy_lock(&(p->lock.lcnt_msgq)); + erts_lcnt_destroy_lock(&(p->lock.lcnt_link)); + erts_lcnt_destroy_lock(&(p->lock.lcnt_status)); +} + +void erts_lcnt_proc_lock(erts_proc_lock_t *lock, ErtsProcLocks locks) { + if (erts_lcnt_rt_options & ERTS_LCNT_OPT_PROCLOCK) { + if (locks & ERTS_PROC_LOCK_MAIN) { + erts_lcnt_lock(&(lock->lcnt_main)); + } + if (locks & ERTS_PROC_LOCK_MSGQ) { + erts_lcnt_lock(&(lock->lcnt_msgq)); + } + if (locks & ERTS_PROC_LOCK_LINK) { + erts_lcnt_lock(&(lock->lcnt_link)); + } + if (locks & ERTS_PROC_LOCK_STATUS) { + erts_lcnt_lock(&(lock->lcnt_status)); + } + } +} + +void erts_lcnt_proc_lock_post_x(erts_proc_lock_t *lock, ErtsProcLocks locks, char *file, unsigned int line) { + if (erts_lcnt_rt_options & ERTS_LCNT_OPT_PROCLOCK) { + if (locks & ERTS_PROC_LOCK_MAIN) { + erts_lcnt_lock_post_x(&(lock->lcnt_main), file, line); + } + if (locks & ERTS_PROC_LOCK_MSGQ) { + erts_lcnt_lock_post_x(&(lock->lcnt_msgq), file, line); + } + if (locks & ERTS_PROC_LOCK_LINK) { + erts_lcnt_lock_post_x(&(lock->lcnt_link), file, line); + } + if (locks & ERTS_PROC_LOCK_STATUS) { + erts_lcnt_lock_post_x(&(lock->lcnt_status), file, line); + } + } +} + +void erts_lcnt_proc_lock_unaquire(erts_proc_lock_t *lock, ErtsProcLocks locks) { + if (erts_lcnt_rt_options & ERTS_LCNT_OPT_PROCLOCK) { + if (locks & ERTS_PROC_LOCK_MAIN) { + erts_lcnt_lock_unaquire(&(lock->lcnt_main)); + } + if (locks & ERTS_PROC_LOCK_MSGQ) { + erts_lcnt_lock_unaquire(&(lock->lcnt_msgq)); + } + if (locks & ERTS_PROC_LOCK_LINK) { + erts_lcnt_lock_unaquire(&(lock->lcnt_link)); + } + if (locks & ERTS_PROC_LOCK_STATUS) { + erts_lcnt_lock_unaquire(&(lock->lcnt_status)); + } + } +} + +void erts_lcnt_proc_unlock(erts_proc_lock_t *lock, ErtsProcLocks locks) { + if (erts_lcnt_rt_options & ERTS_LCNT_OPT_PROCLOCK) { + if (locks & ERTS_PROC_LOCK_MAIN) { + erts_lcnt_unlock(&(lock->lcnt_main)); + } + if (locks & ERTS_PROC_LOCK_MSGQ) { + erts_lcnt_unlock(&(lock->lcnt_msgq)); + } + if (locks & ERTS_PROC_LOCK_LINK) { + erts_lcnt_unlock(&(lock->lcnt_link)); + } + if (locks & ERTS_PROC_LOCK_STATUS) { + erts_lcnt_unlock(&(lock->lcnt_status)); + } + } +} +void erts_lcnt_proc_trylock(erts_proc_lock_t *lock, ErtsProcLocks locks, int res) { + if (erts_lcnt_rt_options & ERTS_LCNT_OPT_PROCLOCK) { + if (locks & ERTS_PROC_LOCK_MAIN) { + erts_lcnt_trylock(&(lock->lcnt_main), res); + } + if (locks & ERTS_PROC_LOCK_MSGQ) { + erts_lcnt_trylock(&(lock->lcnt_msgq), res); + } + if (locks & ERTS_PROC_LOCK_LINK) { + erts_lcnt_trylock(&(lock->lcnt_link), res); + } + if (locks & ERTS_PROC_LOCK_STATUS) { + erts_lcnt_trylock(&(lock->lcnt_status), res); + } + } +} + +#endif /* ifdef ERTS_ENABLE_LOCK_COUNT */ + + +/* --- Process lock checking ----------------------------------------------- */ + +#ifdef ERTS_ENABLE_LOCK_CHECK + +void +erts_proc_lc_lock(Process *p, ErtsProcLocks locks) +{ + erts_lc_lock_t lck = ERTS_LC_LOCK_INIT(-1, + p->id, + ERTS_LC_FLG_LT_PROCLOCK); + if (locks & ERTS_PROC_LOCK_MAIN) { + lck.id = lc_id.proc_lock_main; + erts_lc_lock(&lck); + } + if (locks & ERTS_PROC_LOCK_LINK) { + lck.id = lc_id.proc_lock_link; + erts_lc_lock(&lck); + } + if (locks & ERTS_PROC_LOCK_MSGQ) { + lck.id = lc_id.proc_lock_msgq; + erts_lc_lock(&lck); + } + if (locks & ERTS_PROC_LOCK_STATUS) { + lck.id = lc_id.proc_lock_status; + erts_lc_lock(&lck); + } +} + +void +erts_proc_lc_trylock(Process *p, ErtsProcLocks locks, int locked) +{ + erts_lc_lock_t lck = ERTS_LC_LOCK_INIT(-1, + p->id, + ERTS_LC_FLG_LT_PROCLOCK); + if (locks & ERTS_PROC_LOCK_MAIN) { + lck.id = lc_id.proc_lock_main; + erts_lc_trylock(locked, &lck); + } + if (locks & ERTS_PROC_LOCK_LINK) { + lck.id = lc_id.proc_lock_link; + erts_lc_trylock(locked, &lck); + } + if (locks & ERTS_PROC_LOCK_MSGQ) { + lck.id = lc_id.proc_lock_msgq; + erts_lc_trylock(locked, &lck); + } + if (locks & ERTS_PROC_LOCK_STATUS) { + lck.id = lc_id.proc_lock_status; + erts_lc_trylock(locked, &lck); + } +} + +void +erts_proc_lc_unlock(Process *p, ErtsProcLocks locks) +{ + erts_lc_lock_t lck = ERTS_LC_LOCK_INIT(-1, + p->id, + ERTS_LC_FLG_LT_PROCLOCK); + if (locks & ERTS_PROC_LOCK_STATUS) { + lck.id = lc_id.proc_lock_status; + erts_lc_unlock(&lck); + } + if (locks & ERTS_PROC_LOCK_MSGQ) { + lck.id = lc_id.proc_lock_msgq; + erts_lc_unlock(&lck); + } + if (locks & ERTS_PROC_LOCK_LINK) { + lck.id = lc_id.proc_lock_link; + erts_lc_unlock(&lck); + } + if (locks & ERTS_PROC_LOCK_MAIN) { + lck.id = lc_id.proc_lock_main; + erts_lc_unlock(&lck); + } +} + +void +erts_proc_lc_might_unlock(Process *p, ErtsProcLocks locks) +{ + erts_lc_lock_t lck = ERTS_LC_LOCK_INIT(-1, + p->id, + ERTS_LC_FLG_LT_PROCLOCK); + if (locks & ERTS_PROC_LOCK_STATUS) { + lck.id = lc_id.proc_lock_status; + erts_lc_might_unlock(&lck); + } + if (locks & ERTS_PROC_LOCK_MSGQ) { + lck.id = lc_id.proc_lock_msgq; + erts_lc_might_unlock(&lck); + } + if (locks & ERTS_PROC_LOCK_LINK) { + lck.id = lc_id.proc_lock_link; + erts_lc_might_unlock(&lck); + } + if (locks & ERTS_PROC_LOCK_MAIN) { + lck.id = lc_id.proc_lock_main; + erts_lc_might_unlock(&lck); + } +} + +void +erts_proc_lc_require_lock(Process *p, ErtsProcLocks locks) +{ + erts_lc_lock_t lck = ERTS_LC_LOCK_INIT(-1, + p->id, + ERTS_LC_FLG_LT_PROCLOCK); + if (locks & ERTS_PROC_LOCK_MAIN) { + lck.id = lc_id.proc_lock_main; + erts_lc_require_lock(&lck); + } + if (locks & ERTS_PROC_LOCK_LINK) { + lck.id = lc_id.proc_lock_link; + erts_lc_require_lock(&lck); + } + if (locks & ERTS_PROC_LOCK_MSGQ) { + lck.id = lc_id.proc_lock_msgq; + erts_lc_require_lock(&lck); + } + if (locks & ERTS_PROC_LOCK_STATUS) { + lck.id = lc_id.proc_lock_status; + erts_lc_require_lock(&lck); + } +} + +void +erts_proc_lc_unrequire_lock(Process *p, ErtsProcLocks locks) +{ + erts_lc_lock_t lck = ERTS_LC_LOCK_INIT(-1, + p->id, + ERTS_LC_FLG_LT_PROCLOCK); + if (locks & ERTS_PROC_LOCK_STATUS) { + lck.id = lc_id.proc_lock_status; + erts_lc_unrequire_lock(&lck); + } + if (locks & ERTS_PROC_LOCK_MSGQ) { + lck.id = lc_id.proc_lock_msgq; + erts_lc_unrequire_lock(&lck); + } + if (locks & ERTS_PROC_LOCK_LINK) { + lck.id = lc_id.proc_lock_link; + erts_lc_unrequire_lock(&lck); + } + if (locks & ERTS_PROC_LOCK_MAIN) { + lck.id = lc_id.proc_lock_main; + erts_lc_unrequire_lock(&lck); + } +} + + +int +erts_proc_lc_trylock_force_busy(Process *p, ErtsProcLocks locks) +{ + if (locks & ERTS_PROC_LOCKS_ALL) { + erts_lc_lock_t lck = ERTS_LC_LOCK_INIT(-1, + p->id, + ERTS_LC_FLG_LT_PROCLOCK); + + if (locks & ERTS_PROC_LOCK_MAIN) + lck.id = lc_id.proc_lock_main; + else if (locks & ERTS_PROC_LOCK_LINK) + lck.id = lc_id.proc_lock_link; + else if (locks & ERTS_PROC_LOCK_MSGQ) + lck.id = lc_id.proc_lock_msgq; + else if (locks & ERTS_PROC_LOCK_STATUS) + lck.id = lc_id.proc_lock_status; + else + erts_lc_fail("Unknown proc lock found"); + + return erts_lc_trylock_force_busy(&lck); + } + return 0; +} + +void erts_proc_lc_chk_only_proc_main(Process *p) +{ + erts_lc_lock_t proc_main = ERTS_LC_LOCK_INIT(lc_id.proc_lock_main, + p->id, + ERTS_LC_FLG_LT_PROCLOCK); + erts_lc_check_exact(&proc_main, 1); +} + +#define ERTS_PROC_LC_EMPTY_LOCK_INIT \ + ERTS_LC_LOCK_INIT(-1, THE_NON_VALUE, ERTS_LC_FLG_LT_PROCLOCK) + +void +erts_proc_lc_chk_have_proc_locks(Process *p, ErtsProcLocks locks) +{ + int have_locks_len = 0; + erts_lc_lock_t have_locks[4] = {ERTS_PROC_LC_EMPTY_LOCK_INIT, + ERTS_PROC_LC_EMPTY_LOCK_INIT, + ERTS_PROC_LC_EMPTY_LOCK_INIT, + ERTS_PROC_LC_EMPTY_LOCK_INIT}; + if (locks & ERTS_PROC_LOCK_MAIN) { + have_locks[have_locks_len].id = lc_id.proc_lock_main; + have_locks[have_locks_len++].extra = p->id; + } + if (locks & ERTS_PROC_LOCK_LINK) { + have_locks[have_locks_len].id = lc_id.proc_lock_link; + have_locks[have_locks_len++].extra = p->id; + } + if (locks & ERTS_PROC_LOCK_MSGQ) { + have_locks[have_locks_len].id = lc_id.proc_lock_msgq; + have_locks[have_locks_len++].extra = p->id; + } + if (locks & ERTS_PROC_LOCK_STATUS) { + have_locks[have_locks_len].id = lc_id.proc_lock_status; + have_locks[have_locks_len++].extra = p->id; + } + + erts_lc_check(have_locks, have_locks_len, NULL, 0); +} + +void +erts_proc_lc_chk_proc_locks(Process *p, ErtsProcLocks locks) +{ + int have_locks_len = 0; + int have_not_locks_len = 0; + erts_lc_lock_t have_locks[4] = {ERTS_PROC_LC_EMPTY_LOCK_INIT, + ERTS_PROC_LC_EMPTY_LOCK_INIT, + ERTS_PROC_LC_EMPTY_LOCK_INIT, + ERTS_PROC_LC_EMPTY_LOCK_INIT}; + erts_lc_lock_t have_not_locks[4] = {ERTS_PROC_LC_EMPTY_LOCK_INIT, + ERTS_PROC_LC_EMPTY_LOCK_INIT, + ERTS_PROC_LC_EMPTY_LOCK_INIT, + ERTS_PROC_LC_EMPTY_LOCK_INIT}; + + if (locks & ERTS_PROC_LOCK_MAIN) { + have_locks[have_locks_len].id = lc_id.proc_lock_main; + have_locks[have_locks_len++].extra = p->id; + } + else { + have_not_locks[have_not_locks_len].id = lc_id.proc_lock_main; + have_not_locks[have_not_locks_len++].extra = p->id; + } + if (locks & ERTS_PROC_LOCK_LINK) { + have_locks[have_locks_len].id = lc_id.proc_lock_link; + have_locks[have_locks_len++].extra = p->id; + } + else { + have_not_locks[have_not_locks_len].id = lc_id.proc_lock_link; + have_not_locks[have_not_locks_len++].extra = p->id; + } + if (locks & ERTS_PROC_LOCK_MSGQ) { + have_locks[have_locks_len].id = lc_id.proc_lock_msgq; + have_locks[have_locks_len++].extra = p->id; + } + else { + have_not_locks[have_not_locks_len].id = lc_id.proc_lock_msgq; + have_not_locks[have_not_locks_len++].extra = p->id; + } + if (locks & ERTS_PROC_LOCK_STATUS) { + have_locks[have_locks_len].id = lc_id.proc_lock_status; + have_locks[have_locks_len++].extra = p->id; + } + else { + have_not_locks[have_not_locks_len].id = lc_id.proc_lock_status; + have_not_locks[have_not_locks_len++].extra = p->id; + } + + erts_lc_check(have_locks, have_locks_len, + have_not_locks, have_not_locks_len); +} + +ErtsProcLocks +erts_proc_lc_my_proc_locks(Process *p) +{ + int resv[4]; + erts_lc_lock_t locks[4] = {ERTS_LC_LOCK_INIT(lc_id.proc_lock_main, + p->id, + ERTS_LC_FLG_LT_PROCLOCK), + ERTS_LC_LOCK_INIT(lc_id.proc_lock_link, + p->id, + ERTS_LC_FLG_LT_PROCLOCK), + ERTS_LC_LOCK_INIT(lc_id.proc_lock_msgq, + p->id, + ERTS_LC_FLG_LT_PROCLOCK), + ERTS_LC_LOCK_INIT(lc_id.proc_lock_status, + p->id, + ERTS_LC_FLG_LT_PROCLOCK)}; + + ErtsProcLocks res = 0; + + erts_lc_have_locks(resv, locks, 4); + if (resv[0]) + res |= ERTS_PROC_LOCK_MAIN; + if (resv[1]) + res |= ERTS_PROC_LOCK_LINK; + if (resv[2]) + res |= ERTS_PROC_LOCK_MSGQ; + if (resv[3]) + res |= ERTS_PROC_LOCK_STATUS; + + return res; +} + +void +erts_proc_lc_chk_no_proc_locks(char *file, int line) +{ + int resv[4]; + int ids[4] = {lc_id.proc_lock_main, + lc_id.proc_lock_link, + lc_id.proc_lock_msgq, + lc_id.proc_lock_status}; + erts_lc_have_lock_ids(resv, ids, 4); + if (resv[0] || resv[1] || resv[2] || resv[3]) { + erts_lc_fail("%s:%d: Thread has process locks locked when expected " + "not to have any process locks locked", + file, line); + } +} + +#endif /* #ifdef ERTS_ENABLE_LOCK_CHECK */ + +#ifdef ERTS_PROC_LOCK_HARD_DEBUG +void +check_queue(erts_proc_lock_t *lck) +{ + int lock_no; + ErtsProcLocks lflgs = ERTS_PROC_LOCK_FLGS_READ_(lck); + + for (lock_no = 0; lock_no <= ERTS_PROC_LOCK_MAX_BIT; lock_no++) { + ErtsProcLocks wtr; + wtr = (((ErtsProcLocks) 1) << lock_no) << ERTS_PROC_LOCK_WAITER_SHIFT; + if (lflgs & wtr) { + int n; + erts_proc_lock_waiter_t *wtr; + ERTS_LC_ASSERT(lck->queues && lck->queues->queue[lock_no]); + wtr = lck->queues->queue[lock_no]; + n = 0; + do { + wtr = wtr->next; + n++; + } while (wtr != lck->queues->queue[lock_no]); + do { + wtr = wtr->prev; + n--; + } while (wtr != lck->queues->queue[lock_no]); + ERTS_LC_ASSERT(n == 0); + } + else { + ERTS_LC_ASSERT(!lck->queues || !lck->queues->queue[lock_no]); + } + } +} +#endif + +#endif /* ERTS_SMP (the whole file) */ diff --git a/erts/emulator/beam/erl_process_lock.h b/erts/emulator/beam/erl_process_lock.h new file mode 100644 index 0000000000..d71e5a0a6e --- /dev/null +++ b/erts/emulator/beam/erl_process_lock.h @@ -0,0 +1,990 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2007-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + + +/* + * Description: Impementation of Erlang process locks. + * + * Author: Rickard Green + */ + +#ifndef ERTS_PROC_LOCK_TYPE__ +#define ERTS_PROC_LOCK_TYPE__ + +#ifdef ERTS_ENABLE_LOCK_CHECK +#define ERTS_PROC_LOCK_DEBUG +#endif + +#ifdef ERTS_ENABLE_LOCK_COUNT +#include "erl_lock_count.h" +#endif + +#include "erl_smp.h" + +#define ERTS_PROC_LOCK_ATOMIC_IMPL 0 +#define ERTS_PROC_LOCK_SPINLOCK_IMPL 0 +#define ERTS_PROC_LOCK_MUTEX_IMPL 0 + +#if defined(ETHR_HAVE_OPTIMIZED_ATOMIC_OPS) +# undef ERTS_PROC_LOCK_ATOMIC_IMPL +# define ERTS_PROC_LOCK_ATOMIC_IMPL 1 +#elif defined(ETHR_HAVE_OPTIMIZED_SPINLOCK) +# undef ERTS_PROC_LOCK_SPINLOCK_IMPL +# define ERTS_PROC_LOCK_SPINLOCK_IMPL 1 +#else +# undef ERTS_PROC_LOCK_MUTEX_IMPL +# define ERTS_PROC_LOCK_MUTEX_IMPL 1 +#endif + +#define ERTS_PROC_LOCK_MAX_BIT 3 + +typedef Uint32 ErtsProcLocks; + +typedef struct erts_proc_lock_queues_t_ erts_proc_lock_queues_t; + +typedef struct erts_proc_lock_t_ { +#if ERTS_PROC_LOCK_ATOMIC_IMPL + erts_smp_atomic_t flags; +#else + ErtsProcLocks flags; +#endif + erts_proc_lock_queues_t *queues; + long refc; +#ifdef ERTS_PROC_LOCK_DEBUG + erts_smp_atomic_t locked[ERTS_PROC_LOCK_MAX_BIT+1]; +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_lock_t lcnt_main; + erts_lcnt_lock_t lcnt_link; + erts_lcnt_lock_t lcnt_msgq; + erts_lcnt_lock_t lcnt_status; +#endif +} erts_proc_lock_t; + +/* Process lock flags */ + +/* + * Main lock: + * The main lock is held by the scheduler running a process. It + * is used to protect all fields in the process structure except + * for those fields protected by other process locks (follows). + */ +#define ERTS_PROC_LOCK_MAIN (((ErtsProcLocks) 1) << 0) + +/* + * Link lock: + * Protects the following fields in the process structure: + * * nlinks + * * monitors + * * suspend_monitors + */ +#define ERTS_PROC_LOCK_LINK (((ErtsProcLocks) 1) << 1) + +/* + * Message queue lock: + * Protects the following fields in the process structure: + * * msg_inq + * * bif_timers + */ +#define ERTS_PROC_LOCK_MSGQ (((ErtsProcLocks) 1) << 2) + +/* + * Status lock: + * Protects the following fields in the process structure: + * * status + * * rstatus + * * status_flags + * * pending_suspenders + * * suspendee + */ +#define ERTS_PROC_LOCK_STATUS (((ErtsProcLocks) 1) << ERTS_PROC_LOCK_MAX_BIT) + +/* + * Special fields: + * + * The following fields are read only and can be read if at + * least one process lock (whichever one doesn't matter) + * is held, or if the process structure is guaranteed not to + * disappear by other means (e.g. pix lock is held): + * * id + * + * The following fields are only allowed to be written if + * all process locks are held, and are allowed to be read if + * at least one process lock (whichever one doesn't matter) + * is held: + * * tracer_proc + * * tracer_flags + * + * The following fields are only allowed to be accessed if + * both the schedule queue lock and at least one process lock + * (whichever one doesn't matter) are held: + * * prio + * * next + * * scheduler_flags + */ + +/* + * Other rules regarding process locking: + * + * Exiting processes: + * When changing status to P_EXITING on a process, you are required + * to take all process locks (ERTS_PROC_LOCKS_ALL). Thus, by holding + * at least one process lock (whichever one doesn't matter) you + * are guaranteed that the process won't exit until the lock you are + * holding has been released. Appart from all process locks also + * the pix lock corresponding to the process has to be held. + * At the same time as status is changed to P_EXITING, also the + * field 'is_exiting' in the process structure is set to a value != 0. + * + * Lock order: + * Process locks with low numeric values has to be locked before + * process locks with high numeric values. E.g., main locks has + * to be locked before message queue locks. + * + * When process locks with the same numeric value are to be locked + * on multiple processes, locks on processes with low process ids + * have to be locked before locks on processes with high process + * ids. E.g., if the main and the message queue locks are to be + * locked on processes p1 and p2 and p1->id < p2->id, then locks + * should be locked in the following order: + * 1. main lock on p1 + * 2. main lock on p2 + * 3. message queue lock on p1 + * 4. message queue lock on p2 + */ + +/* Other lock flags */ +#define ERTS_PROC_LOCK_WAITER_SHIFT (ERTS_PROC_LOCK_MAX_BIT + 1) + + +/* ERTS_PROC_LOCKS_* are combinations of process locks */ + +#define ERTS_PROC_LOCKS_MSG_RECEIVE (ERTS_PROC_LOCK_MSGQ \ + | ERTS_PROC_LOCK_STATUS) +#define ERTS_PROC_LOCKS_MSG_SEND (ERTS_PROC_LOCK_MSGQ \ + | ERTS_PROC_LOCK_STATUS) +#define ERTS_PROC_LOCKS_XSIG_SEND ERTS_PROC_LOCK_STATUS + +#define ERTS_PROC_LOCKS_ALL \ + ((((ErtsProcLocks) 1) << (ERTS_PROC_LOCK_MAX_BIT + 1)) - 1) + +#define ERTS_PROC_LOCKS_ALL_MINOR (ERTS_PROC_LOCKS_ALL \ + & ~ERTS_PROC_LOCK_MAIN) + + +#define ERTS_PIX_LOCKS_BITS 8 +#define ERTS_NO_OF_PIX_LOCKS (1 << ERTS_PIX_LOCKS_BITS) + + +#endif /* #ifndef ERTS_PROC_LOCK_TYPE__ */ + +#ifndef ERTS_PROCESS_LOCK_ONLY_PROC_LOCK_TYPE__ +#ifndef ERTS_PROC_LOCK_LOCK_CHECK__ +#define ERTS_PROC_LOCK_LOCK_CHECK__ + +/* Lock counter implemetation */ + +#ifdef ERTS_ENABLE_LOCK_COUNT +#define erts_smp_proc_lock__(P,I,L) erts_smp_proc_lock_x__(P,I,L,__FILE__,__LINE__) +#define erts_smp_proc_lock(P,L) erts_smp_proc_lock_x(P,L,__FILE__,__LINE__) +#endif + +#if defined(ERTS_SMP) && defined (ERTS_ENABLE_LOCK_COUNT) + +void erts_lcnt_proc_lock_init(Process *p); +void erts_lcnt_proc_lock_destroy(Process *p); +void erts_lcnt_proc_lock(erts_proc_lock_t *lock, ErtsProcLocks locks); +void erts_lcnt_proc_lock_post_x(erts_proc_lock_t *lock, ErtsProcLocks locks, char *file, unsigned int line); +void erts_lcnt_proc_lock_unaquire(erts_proc_lock_t *lock, ErtsProcLocks locks); +void erts_lcnt_proc_unlock(erts_proc_lock_t *lock, ErtsProcLocks locks); +void erts_lcnt_proc_trylock(erts_proc_lock_t *lock, ErtsProcLocks locks, int res); + +#endif /* ERTS_ENABLE_LOCK_COUNT*/ + + + +/* --- Process lock checking ----------------------------------------------- */ + +#if defined(ERTS_SMP) && defined(ERTS_ENABLE_LOCK_CHECK) +#define ERTS_SMP_CHK_NO_PROC_LOCKS \ + erts_proc_lc_chk_no_proc_locks(__FILE__, __LINE__) +#define ERTS_SMP_CHK_HAVE_ONLY_MAIN_PROC_LOCK(P) \ + erts_proc_lc_chk_only_proc_main((P)) +void erts_proc_lc_lock(Process *p, ErtsProcLocks locks); +void erts_proc_lc_trylock(Process *p, ErtsProcLocks locks, int locked); +void erts_proc_lc_unlock(Process *p, ErtsProcLocks locks); +void erts_proc_lc_might_unlock(Process *p, ErtsProcLocks locks); +void erts_proc_lc_chk_have_proc_locks(Process *p, ErtsProcLocks locks); +void erts_proc_lc_chk_proc_locks(Process *p, ErtsProcLocks locks); +void erts_proc_lc_chk_only_proc_main(Process *p); +void erts_proc_lc_chk_no_proc_locks(char *file, int line); +ErtsProcLocks erts_proc_lc_my_proc_locks(Process *p); +int erts_proc_lc_trylock_force_busy(Process *p, ErtsProcLocks locks); +void erts_proc_lc_require_lock(Process *p, ErtsProcLocks locks); +void erts_proc_lc_unrequire_lock(Process *p, ErtsProcLocks locks); +#else +#define ERTS_SMP_CHK_NO_PROC_LOCKS +#define ERTS_SMP_CHK_HAVE_ONLY_MAIN_PROC_LOCK(P) +#endif + +#endif /* #ifndef ERTS_PROC_LOCK_LOCK_CHECK__ */ +#endif /* #ifndef ERTS_PROCESS_LOCK_ONLY_PROC_LOCK_TYPE__ */ + +#if !defined(ERTS_PROCESS_LOCK_ONLY_PROC_LOCK_TYPE__) \ + && !defined(ERTS_PROCESS_LOCK_ONLY_LOCK_CHECK_PROTO__) +#ifndef ERTS_PROCESS_LOCK_H__ +#define ERTS_PROCESS_LOCK_H__ + +#ifdef ERTS_SMP + +typedef struct { + union { +#if ERTS_PROC_LOCK_MUTEX_IMPL + erts_smp_mtx_t mtx; +#else + erts_smp_spinlock_t spnlck; +#endif + char buf[64]; /* Try to get locks in different cache lines */ + } u; +} erts_pix_lock_t; + +#define ERTS_PIX2PIXLOCKIX(PIX) \ + ((PIX) & ((1 << ERTS_PIX_LOCKS_BITS) - 1)) +#define ERTS_PIX2PIXLOCK(PIX) \ + (&erts_pix_locks[ERTS_PIX2PIXLOCKIX((PIX))]) +#define ERTS_PID2PIXLOCK(PID) \ + ERTS_PIX2PIXLOCK(internal_pid_data((PID))) + +#if ERTS_PROC_LOCK_ATOMIC_IMPL + +#define ERTS_PROC_LOCK_FLGS_BAND_(L, MSK) \ + ((ErtsProcLocks) erts_smp_atomic_band(&(L)->flags, (long) (MSK))) +#define ERTS_PROC_LOCK_FLGS_BOR_(L, MSK) \ + ((ErtsProcLocks) erts_smp_atomic_bor(&(L)->flags, (long) (MSK))) +#define ERTS_PROC_LOCK_FLGS_CMPXCHG_(L, NEW, EXPECTED) \ + ((ErtsProcLocks) erts_smp_atomic_cmpxchg(&(L)->flags, \ + (long) (NEW), (long) (EXPECTED))) +#define ERTS_PROC_LOCK_FLGS_READ_(L) \ + ((ErtsProcLocks) erts_smp_atomic_read(&(L)->flags)) + +#else /* no opt atomic ops */ + +ERTS_GLB_INLINE ErtsProcLocks erts_proc_lock_flags_band(erts_proc_lock_t *, + ErtsProcLocks); +ERTS_GLB_INLINE ErtsProcLocks erts_proc_lock_flags_bor(erts_proc_lock_t *, + ErtsProcLocks); + +#if ERTS_GLB_INLINE_INCL_FUNC_DEF + +ERTS_GLB_INLINE ErtsProcLocks +erts_proc_lock_flags_band(erts_proc_lock_t *lck, ErtsProcLocks mask) +{ + ErtsProcLocks res = lck->flags; + lck->flags &= mask; + return res; +} + +ERTS_GLB_INLINE ErtsProcLocks +erts_proc_lock_flags_bor(erts_proc_lock_t *lck, ErtsProcLocks mask) +{ + ErtsProcLocks res = lck->flags; + lck->flags |= mask; + return res; +} + +ERTS_GLB_INLINE ErtsProcLocks +erts_proc_lock_flags_cmpxchg(erts_proc_lock_t *lck, ErtsProcLocks new, + ErtsProcLocks expected) +{ + ErtsProcLocks res = lck->flags; + if (res == expected) + lck->flags = new; + return res; +} + +#endif + +#define ERTS_PROC_LOCK_FLGS_BAND_(L, MSK) erts_proc_lock_flags_band((L), (MSK)) +#define ERTS_PROC_LOCK_FLGS_BOR_(L, MSK) erts_proc_lock_flags_bor((L), (MSK)) +#define ERTS_PROC_LOCK_FLGS_CMPXCHG_(L, NEW, EXPECTED) \ + erts_proc_lock_flags_cmpxchg((L), (NEW), (EXPECTED)) +#define ERTS_PROC_LOCK_FLGS_READ_(L) ((L)->flags) + +#endif /* end no opt atomic ops */ + +extern erts_pix_lock_t erts_pix_locks[ERTS_NO_OF_PIX_LOCKS]; + +void erts_init_proc_lock(void); +void erts_proc_lock_prepare_proc_lock_waiter(void); +void erts_proc_lock_failed(Process *, + erts_pix_lock_t *, + ErtsProcLocks, + ErtsProcLocks); +void erts_proc_unlock_failed(Process *, + erts_pix_lock_t *, + ErtsProcLocks); + +ERTS_GLB_INLINE void erts_pix_lock(erts_pix_lock_t *); +ERTS_GLB_INLINE void erts_pix_unlock(erts_pix_lock_t *); +ERTS_GLB_INLINE int erts_lc_pix_lock_is_locked(erts_pix_lock_t *); + +ERTS_GLB_INLINE ErtsProcLocks erts_smp_proc_raw_trylock__(Process *p, + ErtsProcLocks locks); +#ifdef ERTS_ENABLE_LOCK_COUNT +ERTS_GLB_INLINE void erts_smp_proc_lock_x__(Process *, + erts_pix_lock_t *, + ErtsProcLocks, + char *file, unsigned int line); +#else +ERTS_GLB_INLINE void erts_smp_proc_lock__(Process *, + erts_pix_lock_t *, + ErtsProcLocks); +#endif +ERTS_GLB_INLINE void erts_smp_proc_unlock__(Process *, + erts_pix_lock_t *, + ErtsProcLocks); +ERTS_GLB_INLINE int erts_smp_proc_trylock__(Process *, + erts_pix_lock_t *, + ErtsProcLocks); + +#ifdef ERTS_PROC_LOCK_DEBUG +ERTS_GLB_INLINE void erts_proc_lock_op_debug(Process *, ErtsProcLocks, int); +#endif + +#if ERTS_GLB_INLINE_INCL_FUNC_DEF + +ERTS_GLB_INLINE void erts_pix_lock(erts_pix_lock_t *pixlck) +{ + ERTS_LC_ASSERT(pixlck); +#if ERTS_PROC_LOCK_MUTEX_IMPL + erts_smp_mtx_lock(&pixlck->u.mtx); +#else + erts_smp_spin_lock(&pixlck->u.spnlck); +#endif +} + +ERTS_GLB_INLINE void erts_pix_unlock(erts_pix_lock_t *pixlck) +{ + ERTS_LC_ASSERT(pixlck); +#if ERTS_PROC_LOCK_MUTEX_IMPL + erts_smp_mtx_unlock(&pixlck->u.mtx); +#else + erts_smp_spin_unlock(&pixlck->u.spnlck); +#endif +} + +ERTS_GLB_INLINE int erts_lc_pix_lock_is_locked(erts_pix_lock_t *pixlck) +{ +#if ERTS_PROC_LOCK_MUTEX_IMPL + return erts_smp_lc_mtx_is_locked(&pixlck->u.mtx); +#else + return erts_smp_lc_spinlock_is_locked(&pixlck->u.spnlck); +#endif +} + +/* + * Helper function for erts_smp_proc_lock__ and erts_smp_proc_trylock__. + * + * Attempts to grab all of 'locks' simultaneously. + * + * On success, returns zero. + * + * On failure, returns the p->locks at the moment it tried to grab them, + * at least some of which will intersect with 'locks', so it is nonzero. + * + * This assumes p's pix lock is held on entry if !ERTS_PROC_LOCK_ATOMIC_IMPL. + * Does not release the pix lock. + */ +ERTS_GLB_INLINE ErtsProcLocks +erts_smp_proc_raw_trylock__(Process *p, ErtsProcLocks locks) +{ + ErtsProcLocks expct_lflgs = 0; + + while (1) { + ErtsProcLocks lflgs = ERTS_PROC_LOCK_FLGS_CMPXCHG_(&p->lock, + expct_lflgs | locks, + expct_lflgs); + if (ERTS_LIKELY(lflgs == expct_lflgs)) { + /* We successfully grabbed all locks. */ + return 0; + } + + if (lflgs & locks) { + /* Some locks we need are locked, give up. */ + return lflgs; + } + + /* cmpxchg failed, try again (should be rare). */ + expct_lflgs = lflgs; + } +} + + +ERTS_GLB_INLINE void +#ifdef ERTS_ENABLE_LOCK_COUNT +erts_smp_proc_lock_x__(Process *p, + erts_pix_lock_t *pix_lck, + ErtsProcLocks locks, + char *file, unsigned int line) +#else +erts_smp_proc_lock__(Process *p, + erts_pix_lock_t *pix_lck, + ErtsProcLocks locks) +#endif +{ + ErtsProcLocks old_lflgs; +#if !ERTS_PROC_LOCK_ATOMIC_IMPL + erts_pix_lock(pix_lck); +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_proc_lock(&(p->lock), locks); +#endif + + ERTS_LC_ASSERT((locks & ~ERTS_PROC_LOCKS_ALL) == 0); + + old_lflgs = erts_smp_proc_raw_trylock__(p, locks); + + if (old_lflgs != 0) { + /* + * There is lock contention, so let erts_proc_lock_failed() deal + * with it. Note that erts_proc_lock_failed() returns with + * pix_lck unlocked. + */ + erts_proc_lock_failed(p, pix_lck, locks, old_lflgs); + } + +#if !ERTS_PROC_LOCK_ATOMIC_IMPL + else { + ERTS_LC_ASSERT(locks == (ERTS_PROC_LOCK_FLGS_READ_(&p->lock) & locks)); + erts_pix_unlock(pix_lck); + } +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_proc_lock_post_x(&(p->lock), locks, file, line); +#endif +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_proc_lc_lock(p, locks); +#endif +#ifdef ERTS_PROC_LOCK_DEBUG + erts_proc_lock_op_debug(p, locks, 1); +#endif + +#if ERTS_PROC_LOCK_ATOMIC_IMPL + ETHR_COMPILER_BARRIER; +#endif +} + +ERTS_GLB_INLINE void +erts_smp_proc_unlock__(Process *p, + erts_pix_lock_t *pix_lck, + ErtsProcLocks locks) +{ + ErtsProcLocks old_lflgs; + +#if ERTS_PROC_LOCK_ATOMIC_IMPL + ETHR_COMPILER_BARRIER; +#endif + +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_proc_unlock(&(p->lock), locks); +#endif + +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_proc_lc_unlock(p, locks); +#endif +#ifdef ERTS_PROC_LOCK_DEBUG + erts_proc_lock_op_debug(p, locks, 0); +#endif + +#if !ERTS_PROC_LOCK_ATOMIC_IMPL + erts_pix_lock(pix_lck); +#endif + + old_lflgs = ERTS_PROC_LOCK_FLGS_READ_(&p->lock); + + ERTS_LC_ASSERT((locks & ~ERTS_PROC_LOCKS_ALL) == 0); + ERTS_LC_ASSERT(locks == (old_lflgs & locks)); + + while (1) { + /* + * We'll atomically unlock every lock that has no waiter. + * If any locks with waiters remain we'll let + * erts_proc_unlock_failed() deal with them. + */ + ErtsProcLocks wait_locks = + (old_lflgs >> ERTS_PROC_LOCK_WAITER_SHIFT) & locks; + + /* What p->lock will look like with all non-waited locks released. */ + ErtsProcLocks want_lflgs = old_lflgs & (wait_locks | ~locks); + + if (want_lflgs != old_lflgs) { + ErtsProcLocks new_lflgs = + ERTS_PROC_LOCK_FLGS_CMPXCHG_(&p->lock, want_lflgs, old_lflgs); + + if (new_lflgs != old_lflgs) { + /* cmpxchg failed, try again. */ + old_lflgs = new_lflgs; + continue; + } + } + + /* We have successfully unlocked every lock with no waiter. */ + + if (want_lflgs & locks) { + /* Locks with waiters remain. */ + /* erts_proc_unlock_failed() returns with pix_lck unlocked. */ + erts_proc_unlock_failed(p, pix_lck, want_lflgs & locks); + } + else { +#if !ERTS_PROC_LOCK_ATOMIC_IMPL + erts_pix_unlock(pix_lck); +#endif + } + + break; + } +} + +ERTS_GLB_INLINE int +erts_smp_proc_trylock__(Process *p, + erts_pix_lock_t *pix_lck, + ErtsProcLocks locks) +{ + int res; + +#ifdef ERTS_ENABLE_LOCK_CHECK + ERTS_LC_ASSERT((locks & ~ERTS_PROC_LOCKS_ALL) == 0); + if (erts_proc_lc_trylock_force_busy(p, locks)) { + res = EBUSY; /* Make sure caller can handle the situation without + causing a lock order violation to occur */ + } + else +#endif + { +#if !ERTS_PROC_LOCK_ATOMIC_IMPL + erts_pix_lock(pix_lck); +#endif + + if (erts_smp_proc_raw_trylock__(p, locks) != 0) { + /* Didn't get all locks... */ + res = EBUSY; + +#if !ERTS_PROC_LOCK_ATOMIC_IMPL + erts_pix_unlock(pix_lck); +#endif + } + else { + res = 0; + + ERTS_LC_ASSERT(locks + == (ERTS_PROC_LOCK_FLGS_READ_(&p->lock) & locks)); + +#if !ERTS_PROC_LOCK_ATOMIC_IMPL + erts_pix_unlock(pix_lck); +#endif + +#ifdef ERTS_PROC_LOCK_DEBUG + erts_proc_lock_op_debug(p, locks, 1); +#endif + } + } +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_proc_trylock(&(p->lock), locks, res); +#endif + +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_proc_lc_trylock(p, locks, res == 0); +#endif + +#if ERTS_PROC_LOCK_ATOMIC_IMPL + ETHR_COMPILER_BARRIER; +#endif + + return res; +} + +#ifdef ERTS_PROC_LOCK_DEBUG +ERTS_GLB_INLINE void +erts_proc_lock_op_debug(Process *p, ErtsProcLocks locks, int locked) +{ + int i; + for (i = 0; i <= ERTS_PROC_LOCK_MAX_BIT; i++) { + ErtsProcLocks lock = ((ErtsProcLocks) 1) << i; + if (locks & lock) { + long lock_count; + if (locked) { + lock_count = erts_smp_atomic_inctest(&p->lock.locked[i]); + ERTS_LC_ASSERT(lock_count == 1); + } + else { + lock_count = erts_smp_atomic_dectest(&p->lock.locked[i]); + ERTS_LC_ASSERT(lock_count == 0); + } + } + } +} +#endif + +#endif /* #if ERTS_GLB_INLINE_INCL_FUNC_DEF */ + +#endif /* ERTS_SMP */ + +#ifdef ERTS_ENABLE_LOCK_COUNT +ERTS_GLB_INLINE void erts_smp_proc_lock_x(Process *, ErtsProcLocks, char *file, unsigned int line); +#else +ERTS_GLB_INLINE void erts_smp_proc_lock(Process *, ErtsProcLocks); +#endif +ERTS_GLB_INLINE void erts_smp_proc_unlock(Process *, ErtsProcLocks); +ERTS_GLB_INLINE int erts_smp_proc_trylock(Process *, ErtsProcLocks); + +ERTS_GLB_INLINE void erts_smp_proc_inc_refc(Process *); +ERTS_GLB_INLINE void erts_smp_proc_dec_refc(Process *); + + +#if ERTS_GLB_INLINE_INCL_FUNC_DEF + +ERTS_GLB_INLINE void +#ifdef ERTS_ENABLE_LOCK_COUNT +erts_smp_proc_lock_x(Process *p, ErtsProcLocks locks, char *file, unsigned int line) +#else +erts_smp_proc_lock(Process *p, ErtsProcLocks locks) +#endif +{ +#if defined(ERTS_SMP) && defined(ERTS_ENABLE_LOCK_COUNT) + erts_smp_proc_lock_x__(p, +#if ERTS_PROC_LOCK_ATOMIC_IMPL + NULL, +#else + ERTS_PID2PIXLOCK(p->id), +#endif /*ERTS_PROC_LOCK_ATOMIC_IMPL*/ + locks, file, line); +#elif defined(ERTS_SMP) + erts_smp_proc_lock__(p, +#if ERTS_PROC_LOCK_ATOMIC_IMPL + NULL, +#else + ERTS_PID2PIXLOCK(p->id), +#endif /*ERTS_PROC_LOCK_ATOMIC_IMPL*/ + locks); +#endif /*ERTS_SMP*/ +} + +ERTS_GLB_INLINE void +erts_smp_proc_unlock(Process *p, ErtsProcLocks locks) +{ +#ifdef ERTS_SMP + erts_smp_proc_unlock__(p, +#if ERTS_PROC_LOCK_ATOMIC_IMPL + NULL, +#else + ERTS_PID2PIXLOCK(p->id), +#endif + locks); +#endif +} + +ERTS_GLB_INLINE int +erts_smp_proc_trylock(Process *p, ErtsProcLocks locks) +{ +#ifndef ERTS_SMP + return 0; +#else + return erts_smp_proc_trylock__(p, +#if ERTS_PROC_LOCK_ATOMIC_IMPL + NULL, +#else + ERTS_PID2PIXLOCK(p->id), +#endif + locks); +#endif +} + + +ERTS_GLB_INLINE void erts_smp_proc_inc_refc(Process *p) +{ +#ifdef ERTS_SMP + erts_pix_lock_t *pixlck = ERTS_PID2PIXLOCK(p->id); + erts_pix_lock(pixlck); + ERTS_LC_ASSERT(p->lock.refc > 0); + p->lock.refc++; + erts_pix_unlock(pixlck); +#endif +} + +ERTS_GLB_INLINE void erts_smp_proc_dec_refc(Process *p) +{ +#ifdef ERTS_SMP + Process *fp; + erts_pix_lock_t *pixlck = ERTS_PID2PIXLOCK(p->id); + erts_pix_lock(pixlck); + ERTS_LC_ASSERT(p->lock.refc > 0); + fp = --p->lock.refc == 0 ? p : NULL; + erts_pix_unlock(pixlck); + if (fp) + erts_free_proc(fp); +#endif +} + +#endif /* #if ERTS_GLB_INLINE_INCL_FUNC_DEF */ + +#ifdef ERTS_SMP +void erts_proc_lock_init(Process *); +void erts_proc_safelock(Process *a_proc, + ErtsProcLocks a_have_locks, + ErtsProcLocks a_need_locks, + Process *b_proc, + ErtsProcLocks b_have_locks, + ErtsProcLocks b_need_locks); +#endif + +/* + * --- Process table lookup ------------------------------------------------ + * + * erts_pid2proc() and friends looks up the process structure of a pid + * and at the same time acquires process locks in the smp case. Locks + * on currently executing process and looked up process are taken according + * to the lock order, i.e., locks on currently executing process may have + * been released and reacquired. + * + * erts_pid2proc_opt() currently accepts the following flags: + * ERTS_P2P_FLG_ALLOW_OTHER_X Lookup process even if it currently + * is exiting. + */ + +#define ERTS_P2P_FLG_ALLOW_OTHER_X (1 << 0) +#define ERTS_P2P_FLG_TRY_LOCK (1 << 1) +#define ERTS_P2P_FLG_SMP_INC_REFC (1 << 2) + +#define ERTS_PROC_LOCK_BUSY ((Process *) &erts_proc_lock_busy) +extern const Process erts_proc_lock_busy; + +#define erts_pid2proc(PROC, HL, PID, NL) \ + erts_pid2proc_opt((PROC), (HL), (PID), (NL), 0) + +ERTS_GLB_INLINE Process * +erts_pid2proc_opt(Process *, ErtsProcLocks, Eterm, ErtsProcLocks, int); + +#ifdef ERTS_SMP +void +erts_pid2proc_safelock(Process *c_p, + ErtsProcLocks c_p_have_locks, + Process **proc, + ErtsProcLocks need_locks, + erts_pix_lock_t *pix_lock, + int flags); +ERTS_GLB_INLINE Process *erts_pid2proc_unlocked_opt(Eterm pid, int flags); +#define erts_pid2proc_unlocked(PID) erts_pid2proc_unlocked_opt((PID), 0) +#else +#define erts_pid2proc_unlocked_opt(PID, FLGS) \ + erts_pid2proc_opt(NULL, 0, (PID), 0, FLGS) +#define erts_pid2proc_unlocked(PID) erts_pid2proc_opt(NULL, 0, (PID), 0, 0) +#endif + +#if ERTS_GLB_INLINE_INCL_FUNC_DEF + +ERTS_GLB_INLINE Process * +#ifdef ERTS_SMP +erts_pid2proc_unlocked_opt(Eterm pid, int flags) +#else +erts_pid2proc_opt(Process *c_p_unused, + ErtsProcLocks c_p_have_locks_unused, + Eterm pid, + ErtsProcLocks pid_need_locks_unused, + int flags) +#endif +{ + Uint pix; + Process *proc; + + if (is_not_internal_pid(pid)) + return NULL; + pix = internal_pid_index(pid); + if(pix >= erts_max_processes) + return NULL; + proc = process_tab[pix]; + if (proc) { + if (proc->id != pid + || (!(flags & ERTS_P2P_FLG_ALLOW_OTHER_X) + && proc->status == P_EXITING)) + proc = NULL; + } + return proc; +} + +#ifdef ERTS_SMP + +ERTS_GLB_INLINE Process * +erts_pid2proc_opt(Process *c_p, + ErtsProcLocks c_p_have_locks, + Eterm pid, + ErtsProcLocks pid_need_locks, + int flags) +{ + erts_pix_lock_t *pix_lock; + ErtsProcLocks need_locks; + Uint pix; + Process *proc; +#ifdef ERTS_ENABLE_LOCK_COUNT + ErtsProcLocks lcnt_locks; +#endif + +#ifdef ERTS_ENABLE_LOCK_CHECK + if (c_p) { + ErtsProcLocks might_unlock = c_p_have_locks & pid_need_locks; + if (might_unlock) + erts_proc_lc_might_unlock(c_p, might_unlock); + } +#endif + if (is_not_internal_pid(pid)) { + proc = NULL; + goto done; + } + pix = internal_pid_index(pid); + if(pix >= erts_max_processes) { + proc = NULL; + goto done; + } + + ERTS_LC_ASSERT((pid_need_locks & ERTS_PROC_LOCKS_ALL) == pid_need_locks); + need_locks = pid_need_locks; + + pix_lock = ERTS_PIX2PIXLOCK(pix); + + if (c_p && c_p->id == pid) { + ASSERT(c_p->id != ERTS_INVALID_PID); + ASSERT(c_p == process_tab[pix]); + if (!(flags & ERTS_P2P_FLG_ALLOW_OTHER_X) && c_p->is_exiting) { + proc = NULL; + goto done; + } + need_locks &= ~c_p_have_locks; + if (!need_locks) { + proc = c_p; + erts_pix_lock(pix_lock); + if (flags & ERTS_P2P_FLG_SMP_INC_REFC) + proc->lock.refc++; + erts_pix_unlock(pix_lock); + goto done; + } + } + + erts_pix_lock(pix_lock); + + proc = process_tab[pix]; + if (proc) { + if (proc->id != pid || (!(flags & ERTS_P2P_FLG_ALLOW_OTHER_X) + && ERTS_PROC_IS_EXITING(proc))) { + proc = NULL; + } + else if (!need_locks) { + if (flags & ERTS_P2P_FLG_SMP_INC_REFC) + proc->lock.refc++; + } + else { + int busy; + +#ifdef ERTS_ENABLE_LOCK_COUNT + lcnt_locks = need_locks; + if (!(flags & ERTS_P2P_FLG_TRY_LOCK)) { + erts_lcnt_proc_lock(&proc->lock, need_locks); + } +#endif + +#ifdef ERTS_ENABLE_LOCK_CHECK + /* Make sure erts_pid2proc_safelock() is enough to handle + a potential lock order violation situation... */ + busy = erts_proc_lc_trylock_force_busy(proc, need_locks); + if (!busy) +#endif + { + /* Try a quick trylock to grab all the locks we need. */ + busy = (int) erts_smp_proc_raw_trylock__(proc, need_locks); +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_proc_lc_trylock(proc, need_locks, !busy); +#endif +#ifdef ERTS_PROC_LOCK_DEBUG + if (!busy) + erts_proc_lock_op_debug(proc, need_locks, 1); +#endif + } + +#ifdef ERTS_ENABLE_LOCK_COUNT + if (flags & ERTS_P2P_FLG_TRY_LOCK) { + if (busy) { + erts_lcnt_proc_trylock(&proc->lock, need_locks, EBUSY); + } else { + erts_lcnt_proc_trylock(&proc->lock, need_locks, 0); + } + } +#endif + if (!busy) { + if (flags & ERTS_P2P_FLG_SMP_INC_REFC) + proc->lock.refc++; +#ifdef ERTS_ENABLE_LOCK_COUNT + /* all is great */ + if (!(flags & ERTS_P2P_FLG_TRY_LOCK)) { + erts_lcnt_proc_lock_post_x(&proc->lock, lcnt_locks, __FILE__, __LINE__); + } +#endif + } + else { + if (flags & ERTS_P2P_FLG_TRY_LOCK) + proc = ERTS_PROC_LOCK_BUSY; + else { + if (flags & ERTS_P2P_FLG_SMP_INC_REFC) + proc->lock.refc++; +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_proc_lock_unaquire(&proc->lock, lcnt_locks); +#endif + erts_pid2proc_safelock(c_p, + c_p_have_locks, + &proc, + pid_need_locks, + pix_lock, + flags); + } + } + } + } + + erts_pix_unlock(pix_lock); +#ifdef ERTS_PROC_LOCK_DEBUG + ERTS_LC_ASSERT(!proc + || proc == ERTS_PROC_LOCK_BUSY + || (pid_need_locks == + (ERTS_PROC_LOCK_FLGS_READ_(&proc->lock) + & pid_need_locks))); +#endif + + + done: + +#if ERTS_PROC_LOCK_ATOMIC_IMPL + ETHR_COMPILER_BARRIER; +#endif + + return proc; +} +#endif /* ERTS_SMP */ + +#endif /* #if ERTS_GLB_INLINE_INCL_FUNC_DEF */ + +#endif /* #ifndef ERTS_PROCESS_LOCK_H__ */ +#endif /* #if !defined(ERTS_PROCESS_LOCK_ONLY_PROC_LOCK_TYPE__) + && !defined(ERTS_PROCESS_LOCK_ONLY_LOCK_CHECK_PROTO__) */ diff --git a/erts/emulator/beam/erl_resolv_dns.c b/erts/emulator/beam/erl_resolv_dns.c new file mode 100644 index 0000000000..9d76fa89f8 --- /dev/null +++ b/erts/emulator/beam/erl_resolv_dns.c @@ -0,0 +1,23 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1997-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* + * Set this to non-zero value if DNS should be used. + */ +int erl_use_resolver = 1; diff --git a/erts/emulator/beam/erl_resolv_nodns.c b/erts/emulator/beam/erl_resolv_nodns.c new file mode 100644 index 0000000000..f14ab68e27 --- /dev/null +++ b/erts/emulator/beam/erl_resolv_nodns.c @@ -0,0 +1,23 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1997-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* + * Set this to non-zero value if DNS should be used. + */ +int erl_use_resolver = 0; diff --git a/erts/emulator/beam/erl_smp.h b/erts/emulator/beam/erl_smp.h new file mode 100644 index 0000000000..03d2a586e3 --- /dev/null +++ b/erts/emulator/beam/erl_smp.h @@ -0,0 +1,993 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2005-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ +/* + * SMP interface to ethread library. + * This is essentially "sed s/erts_/erts_smp_/g < erl_threads.h > erl_smp.h", + * plus changes to NOP operations when ERTS_SMP is disabled. + * Author: Mikael Pettersson + */ +#ifndef ERL_SMP_H +#define ERL_SMP_H +#include "erl_threads.h" + +#ifdef ERTS_ENABLE_LOCK_COUNT +#define erts_smp_mtx_lock(L) erts_smp_mtx_lock_x(L, __FILE__, __LINE__) +#define erts_smp_spin_lock(L) erts_smp_spin_lock_x(L, __FILE__, __LINE__) +#define erts_smp_rwmtx_rlock(L) erts_smp_rwmtx_rlock_x(L, __FILE__, __LINE__) +#define erts_smp_rwmtx_rwlock(L) erts_smp_rwmtx_rwlock_x(L, __FILE__, __LINE__) +#define erts_smp_read_lock(L) erts_smp_read_lock_x(L, __FILE__, __LINE__) +#define erts_smp_write_lock(L) erts_smp_write_lock_x(L, __FILE__, __LINE__) +#endif + + +#ifdef ERTS_SMP +#define ERTS_SMP_THR_OPTS_DEFAULT_INITER ERTS_THR_OPTS_DEFAULT_INITER +typedef erts_thr_opts_t erts_smp_thr_opts_t; +typedef erts_thr_init_data_t erts_smp_thr_init_data_t; +typedef erts_tid_t erts_smp_tid_t; +typedef erts_mtx_t erts_smp_mtx_t; +typedef erts_cnd_t erts_smp_cnd_t; +typedef erts_rwmtx_t erts_smp_rwmtx_t; +typedef erts_tsd_key_t erts_smp_tsd_key_t; +typedef erts_gate_t erts_smp_gate_t; +typedef ethr_atomic_t erts_smp_atomic_t; +typedef erts_spinlock_t erts_smp_spinlock_t; +typedef erts_rwlock_t erts_smp_rwlock_t; +typedef erts_thr_timeval_t erts_smp_thr_timeval_t; +void erts_thr_fatal_error(int, char *); /* implemented in erl_init.c */ + +#else /* #ifdef ERTS_SMP */ + +#define ERTS_SMP_THR_OPTS_DEFAULT_INITER 0 +typedef int erts_smp_thr_opts_t; +typedef int erts_smp_thr_init_data_t; +typedef int erts_smp_tid_t; +typedef int erts_smp_mtx_t; +typedef int erts_smp_cnd_t; +typedef int erts_smp_rwmtx_t; +typedef int erts_smp_tsd_key_t; +typedef int erts_smp_gate_t; +typedef long erts_smp_atomic_t; +#if __GNUC__ > 2 +typedef struct { } erts_smp_spinlock_t; +typedef struct { } erts_smp_rwlock_t; +#else +typedef struct { int gcc_is_buggy; } erts_smp_spinlock_t; +typedef struct { int gcc_is_buggy; } erts_smp_rwlock_t; +#endif + +typedef struct { + long tv_sec; + long tv_nsec; +} erts_smp_thr_timeval_t; + +#endif /* #ifdef ERTS_SMP */ + +ERTS_GLB_INLINE void erts_smp_thr_init(erts_smp_thr_init_data_t *id); +ERTS_GLB_INLINE void erts_smp_thr_create(erts_smp_tid_t *tid, + void * (*func)(void *), + void *arg, + erts_smp_thr_opts_t *opts); +ERTS_GLB_INLINE void erts_smp_thr_join(erts_smp_tid_t tid, void **thr_res); +ERTS_GLB_INLINE void erts_smp_thr_detach(erts_smp_tid_t tid); +ERTS_GLB_INLINE void erts_smp_thr_exit(void *res); +ERTS_GLB_INLINE void erts_smp_install_exit_handler(void (*exit_handler)(void)); +ERTS_GLB_INLINE erts_smp_tid_t erts_smp_thr_self(void); +ERTS_GLB_INLINE int erts_smp_equal_tids(erts_smp_tid_t x, erts_smp_tid_t y); +#ifdef ERTS_HAVE_REC_MTX_INIT +#define ERTS_SMP_HAVE_REC_MTX_INIT 1 +ERTS_GLB_INLINE void erts_smp_rec_mtx_init(erts_smp_mtx_t *mtx); +#endif +ERTS_GLB_INLINE void erts_smp_mtx_init_x(erts_smp_mtx_t *mtx, + char *name, + Eterm extra); +ERTS_GLB_INLINE void erts_smp_mtx_init_locked_x(erts_smp_mtx_t *mtx, + char *name, + Eterm extra); +ERTS_GLB_INLINE void erts_smp_mtx_init(erts_smp_mtx_t *mtx, char *name); +ERTS_GLB_INLINE void erts_smp_mtx_init_locked(erts_smp_mtx_t *mtx, char *name); +ERTS_GLB_INLINE void erts_smp_mtx_destroy(erts_smp_mtx_t *mtx); +ERTS_GLB_INLINE void erts_smp_mtx_set_forksafe(erts_smp_mtx_t *mtx); +ERTS_GLB_INLINE void erts_smp_mtx_unset_forksafe(erts_smp_mtx_t *mtx); +ERTS_GLB_INLINE int erts_smp_mtx_trylock(erts_smp_mtx_t *mtx); +#ifdef ERTS_ENABLE_LOCK_COUNT +ERTS_GLB_INLINE void erts_smp_mtx_lock_x(erts_smp_mtx_t *mtx, char *file, int line); +#else +ERTS_GLB_INLINE void erts_smp_mtx_lock(erts_smp_mtx_t *mtx); +#endif +ERTS_GLB_INLINE void erts_smp_mtx_unlock(erts_smp_mtx_t *mtx); +ERTS_GLB_INLINE int erts_smp_lc_mtx_is_locked(erts_smp_mtx_t *mtx); +ERTS_GLB_INLINE void erts_smp_cnd_init(erts_smp_cnd_t *cnd); +ERTS_GLB_INLINE void erts_smp_cnd_destroy(erts_smp_cnd_t *cnd); +ERTS_GLB_INLINE void erts_smp_cnd_wait(erts_smp_cnd_t *cnd, + erts_smp_mtx_t *mtx); +ERTS_GLB_INLINE void erts_smp_cnd_signal(erts_smp_cnd_t *cnd); +ERTS_GLB_INLINE void erts_smp_cnd_broadcast(erts_smp_cnd_t *cnd); +ERTS_GLB_INLINE void erts_smp_rwmtx_init_x(erts_smp_rwmtx_t *rwmtx, + char *name, + Eterm extra); +ERTS_GLB_INLINE void erts_smp_rwmtx_init(erts_smp_rwmtx_t *rwmtx, + char *name); +ERTS_GLB_INLINE void erts_smp_rwmtx_destroy(erts_smp_rwmtx_t *rwmtx); +ERTS_GLB_INLINE int erts_smp_rwmtx_tryrlock(erts_smp_rwmtx_t *rwmtx); +#ifdef ERTS_ENABLE_LOCK_COUNT +ERTS_GLB_INLINE void erts_smp_rwmtx_rlock_x(erts_smp_rwmtx_t *rwmtx, char *file, unsigned int line); +ERTS_GLB_INLINE void erts_smp_rwmtx_rwlock_x(erts_smp_rwmtx_t *rwmtx, char *file, unsigned int line); +#else +ERTS_GLB_INLINE void erts_smp_rwmtx_rlock(erts_smp_rwmtx_t *rwmtx); +ERTS_GLB_INLINE void erts_smp_rwmtx_rwlock(erts_smp_rwmtx_t *rwmtx); +#endif +ERTS_GLB_INLINE void erts_smp_rwmtx_runlock(erts_smp_rwmtx_t *rwmtx); +ERTS_GLB_INLINE int erts_smp_rwmtx_tryrwlock(erts_smp_rwmtx_t *rwmtx); +ERTS_GLB_INLINE void erts_smp_rwmtx_rwunlock(erts_smp_rwmtx_t *rwmtx); +ERTS_GLB_INLINE int erts_smp_lc_rwmtx_is_rlocked(erts_smp_rwmtx_t *mtx); +ERTS_GLB_INLINE int erts_smp_lc_rwmtx_is_rwlocked(erts_smp_rwmtx_t *mtx); +ERTS_GLB_INLINE void erts_smp_atomic_init(erts_smp_atomic_t *var, long i); +ERTS_GLB_INLINE void erts_smp_atomic_set(erts_smp_atomic_t *var, long i); +ERTS_GLB_INLINE long erts_smp_atomic_read(erts_smp_atomic_t *var); +ERTS_GLB_INLINE long erts_smp_atomic_inctest(erts_smp_atomic_t *incp); +ERTS_GLB_INLINE long erts_smp_atomic_dectest(erts_smp_atomic_t *decp); +ERTS_GLB_INLINE void erts_smp_atomic_inc(erts_smp_atomic_t *incp); +ERTS_GLB_INLINE void erts_smp_atomic_dec(erts_smp_atomic_t *decp); +ERTS_GLB_INLINE long erts_smp_atomic_addtest(erts_smp_atomic_t *addp, + long i); +ERTS_GLB_INLINE void erts_smp_atomic_add(erts_smp_atomic_t *addp, long i); +ERTS_GLB_INLINE long erts_smp_atomic_xchg(erts_smp_atomic_t *xchgp, + long new); +ERTS_GLB_INLINE long erts_smp_atomic_cmpxchg(erts_smp_atomic_t *xchgp, + long new, + long expected); +ERTS_GLB_INLINE long erts_smp_atomic_bor(erts_smp_atomic_t *var, long mask); +ERTS_GLB_INLINE long erts_smp_atomic_band(erts_smp_atomic_t *var, long mask); +ERTS_GLB_INLINE void erts_smp_spinlock_init_x(erts_smp_spinlock_t *lock, + char *name, + Eterm extra); +ERTS_GLB_INLINE void erts_smp_spinlock_init(erts_smp_spinlock_t *lock, + char *name); +ERTS_GLB_INLINE void erts_smp_spinlock_destroy(erts_smp_spinlock_t *lock); +ERTS_GLB_INLINE void erts_smp_spin_unlock(erts_smp_spinlock_t *lock); +#ifdef ERTS_ENABLE_LOCK_COUNT +ERTS_GLB_INLINE void erts_smp_spin_lock_x(erts_smp_spinlock_t *lock, char *file, unsigned int line); +#else +ERTS_GLB_INLINE void erts_smp_spin_lock(erts_smp_spinlock_t *lock); +#endif +ERTS_GLB_INLINE int erts_smp_lc_spinlock_is_locked(erts_smp_spinlock_t *lock); +ERTS_GLB_INLINE void erts_smp_rwlock_init_x(erts_smp_rwlock_t *lock, + char *name, + Eterm extra); +ERTS_GLB_INLINE void erts_smp_rwlock_init(erts_smp_rwlock_t *lock, + char *name); +ERTS_GLB_INLINE void erts_smp_rwlock_destroy(erts_smp_rwlock_t *lock); +ERTS_GLB_INLINE void erts_smp_read_unlock(erts_smp_rwlock_t *lock); +#ifdef ERTS_ENABLE_LOCK_COUNT +ERTS_GLB_INLINE void erts_smp_read_lock_x(erts_smp_rwlock_t *lock, char *file, unsigned int line); +ERTS_GLB_INLINE void erts_smp_write_lock_x(erts_smp_rwlock_t *lock, char *file, unsigned int line); +#else +ERTS_GLB_INLINE void erts_smp_read_lock(erts_smp_rwlock_t *lock); +ERTS_GLB_INLINE void erts_smp_write_lock(erts_smp_rwlock_t *lock); +#endif +ERTS_GLB_INLINE void erts_smp_write_unlock(erts_smp_rwlock_t *lock); +ERTS_GLB_INLINE int erts_smp_lc_rwlock_is_rlocked(erts_smp_rwlock_t *lock); +ERTS_GLB_INLINE int erts_smp_lc_rwlock_is_rwlocked(erts_smp_rwlock_t *lock); +ERTS_GLB_INLINE void erts_smp_thr_time_now(erts_smp_thr_timeval_t *time); +ERTS_GLB_INLINE void erts_smp_tsd_key_create(erts_smp_tsd_key_t *keyp); +ERTS_GLB_INLINE void erts_smp_tsd_key_delete(erts_smp_tsd_key_t key); +ERTS_GLB_INLINE void erts_smp_tsd_set(erts_smp_tsd_key_t key, void *value); +ERTS_GLB_INLINE void * erts_smp_tsd_get(erts_smp_tsd_key_t key); +ERTS_GLB_INLINE void erts_smp_gate_init(erts_smp_gate_t *gp); +ERTS_GLB_INLINE void erts_smp_gate_destroy(erts_smp_gate_t *gp); +ERTS_GLB_INLINE void erts_smp_gate_close(erts_smp_gate_t *gp); +ERTS_GLB_INLINE void erts_smp_gate_let_through(erts_smp_gate_t *gp, unsigned no); +ERTS_GLB_INLINE void erts_smp_gate_wait(erts_smp_gate_t *gp); +ERTS_GLB_INLINE void erts_smp_gate_swait(erts_smp_gate_t *gp, int spincount); + +#ifdef ERTS_THR_HAVE_SIG_FUNCS +#define ERTS_SMP_THR_HAVE_SIG_FUNCS 1 +ERTS_GLB_INLINE void erts_smp_thr_sigmask(int how, + const sigset_t *set, + sigset_t *oset); +ERTS_GLB_INLINE void erts_smp_thr_sigwait(const sigset_t *set, int *sig); +#endif /* #ifdef ERTS_THR_HAVE_SIG_FUNCS */ + + +#if ERTS_GLB_INLINE_INCL_FUNC_DEF + +ERTS_GLB_INLINE void +erts_smp_thr_init(erts_smp_thr_init_data_t *id) +{ +#ifdef ERTS_SMP + erts_thr_init(id); +#endif +} + +ERTS_GLB_INLINE void +erts_smp_thr_create(erts_smp_tid_t *tid, void * (*func)(void *), void *arg, + erts_smp_thr_opts_t *opts) +{ +#ifdef ERTS_SMP + erts_thr_create(tid, func, arg, opts); +#endif +} + +ERTS_GLB_INLINE void +erts_smp_thr_join(erts_smp_tid_t tid, void **thr_res) +{ +#ifdef ERTS_SMP + erts_thr_join(tid, thr_res); +#endif +} + + +ERTS_GLB_INLINE void +erts_smp_thr_detach(erts_smp_tid_t tid) +{ +#ifdef ERTS_SMP + erts_thr_detach(tid); +#endif +} + + +ERTS_GLB_INLINE void +erts_smp_thr_exit(void *res) +{ +#ifdef ERTS_SMP + erts_thr_exit(res); +#endif +} + +ERTS_GLB_INLINE void +erts_smp_install_exit_handler(void (*exit_handler)(void)) +{ +#ifdef ERTS_SMP + erts_thr_install_exit_handler(exit_handler); +#endif +} + +ERTS_GLB_INLINE erts_smp_tid_t +erts_smp_thr_self(void) +{ +#ifdef ERTS_SMP + return erts_thr_self(); +#else + return 0; +#endif +} + + +ERTS_GLB_INLINE int +erts_smp_equal_tids(erts_smp_tid_t x, erts_smp_tid_t y) +{ +#ifdef ERTS_SMP + return erts_equal_tids(x, y); +#else + return 1; +#endif +} + + +#ifdef ERTS_HAVE_REC_MTX_INIT +ERTS_GLB_INLINE void +erts_smp_rec_mtx_init(erts_smp_mtx_t *mtx) +{ +#ifdef ERTS_SMP + erts_rec_mtx_init(mtx); +#endif +} +#endif + +ERTS_GLB_INLINE void +erts_smp_mtx_init_x(erts_smp_mtx_t *mtx, char *name, Eterm extra) +{ +#ifdef ERTS_SMP + erts_mtx_init_x(mtx, name, extra); +#endif +} + +ERTS_GLB_INLINE void +erts_smp_mtx_init_locked_x(erts_smp_mtx_t *mtx, char *name, Eterm extra) +{ +#ifdef ERTS_SMP + erts_mtx_init_locked_x(mtx, name, extra); +#endif +} + +ERTS_GLB_INLINE void +erts_smp_mtx_init(erts_smp_mtx_t *mtx, char *name) +{ +#ifdef ERTS_SMP + erts_mtx_init(mtx, name); +#endif +} + +ERTS_GLB_INLINE void +erts_smp_mtx_init_locked(erts_smp_mtx_t *mtx, char *name) +{ +#ifdef ERTS_SMP + erts_mtx_init_locked(mtx, name); +#endif +} + +ERTS_GLB_INLINE void +erts_smp_mtx_destroy(erts_smp_mtx_t *mtx) +{ +#ifdef ERTS_SMP + erts_mtx_destroy(mtx); +#endif +} + +ERTS_GLB_INLINE void +erts_smp_mtx_set_forksafe(erts_smp_mtx_t *mtx) +{ +#ifdef ERTS_SMP + erts_mtx_set_forksafe(mtx); +#endif +} + +ERTS_GLB_INLINE void +erts_smp_mtx_unset_forksafe(erts_smp_mtx_t *mtx) +{ +#ifdef ERTS_SMP + erts_mtx_unset_forksafe(mtx); +#endif +} + +ERTS_GLB_INLINE int +erts_smp_mtx_trylock(erts_smp_mtx_t *mtx) +{ +#ifdef ERTS_SMP + return erts_mtx_trylock(mtx); +#else + return 0; +#endif + +} + + +ERTS_GLB_INLINE void +#ifdef ERTS_ENABLE_LOCK_COUNT +erts_smp_mtx_lock_x(erts_smp_mtx_t *mtx, char *file, int line) +#else +erts_smp_mtx_lock(erts_smp_mtx_t *mtx) +#endif +{ +#if defined(ERTS_SMP) && defined(ERTS_ENABLE_LOCK_COUNT) + erts_mtx_lock_x(mtx, file, line); +#elif defined(ERTS_SMP) + erts_mtx_lock(mtx); +#endif +} + +ERTS_GLB_INLINE void +erts_smp_mtx_unlock(erts_smp_mtx_t *mtx) +{ +#ifdef ERTS_SMP + erts_mtx_unlock(mtx); +#endif +} + +ERTS_GLB_INLINE int +erts_smp_lc_mtx_is_locked(erts_smp_mtx_t *mtx) +{ +#if defined(ERTS_SMP) && defined(ERTS_ENABLE_LOCK_CHECK) + return erts_lc_mtx_is_locked(mtx); +#else + return 0; +#endif +} + +ERTS_GLB_INLINE void +erts_smp_cnd_init(erts_smp_cnd_t *cnd) +{ +#ifdef ERTS_SMP + erts_cnd_init(cnd); +#endif +} + +ERTS_GLB_INLINE void +erts_smp_cnd_destroy(erts_smp_cnd_t *cnd) +{ +#ifdef ERTS_SMP + erts_cnd_destroy(cnd); +#endif +} + +ERTS_GLB_INLINE void +erts_smp_cnd_wait(erts_smp_cnd_t *cnd, erts_smp_mtx_t *mtx) +{ +#ifdef ERTS_SMP + erts_cnd_wait(cnd, mtx); +#endif +} + +ERTS_GLB_INLINE void +erts_smp_cnd_signal(erts_smp_cnd_t *cnd) +{ +#ifdef ERTS_SMP + erts_cnd_signal(cnd); +#endif +} + + +ERTS_GLB_INLINE void +erts_smp_cnd_broadcast(erts_smp_cnd_t *cnd) +{ +#ifdef ERTS_SMP + erts_cnd_broadcast(cnd); +#endif +} + +ERTS_GLB_INLINE void +erts_smp_rwmtx_init_x(erts_smp_rwmtx_t *rwmtx, char *name, Eterm extra) +{ +#ifdef ERTS_SMP + erts_rwmtx_init_x(rwmtx, name, extra); +#endif +} + +ERTS_GLB_INLINE void +erts_smp_rwmtx_init(erts_smp_rwmtx_t *rwmtx, char *name) +{ +#ifdef ERTS_SMP + erts_rwmtx_init(rwmtx, name); +#endif +} + +ERTS_GLB_INLINE void +erts_smp_rwmtx_destroy(erts_smp_rwmtx_t *rwmtx) +{ +#ifdef ERTS_SMP + erts_rwmtx_destroy(rwmtx); +#endif +} + +ERTS_GLB_INLINE int +erts_smp_rwmtx_tryrlock(erts_smp_rwmtx_t *rwmtx) +{ +#ifdef ERTS_SMP + return erts_rwmtx_tryrlock(rwmtx); +#else + return 0; +#endif +} + +ERTS_GLB_INLINE void +#ifdef ERTS_ENABLE_LOCK_COUNT +erts_smp_rwmtx_rlock_x(erts_smp_rwmtx_t *rwmtx, char *file, unsigned int line) +#else +erts_smp_rwmtx_rlock(erts_smp_rwmtx_t *rwmtx) +#endif +{ +#if defined(ERTS_SMP) && defined(ERTS_ENABLE_LOCK_COUNT) + erts_rwmtx_rlock_x(rwmtx, file, line); +#elif defined(ERTS_SMP) + erts_rwmtx_rlock(rwmtx); +#endif +} + +ERTS_GLB_INLINE void +erts_smp_rwmtx_runlock(erts_smp_rwmtx_t *rwmtx) +{ +#ifdef ERTS_SMP + erts_rwmtx_runlock(rwmtx); +#endif +} + + +ERTS_GLB_INLINE int +erts_smp_rwmtx_tryrwlock(erts_smp_rwmtx_t *rwmtx) +{ +#ifdef ERTS_SMP + return erts_rwmtx_tryrwlock(rwmtx); +#else + return 0; +#endif +} + +ERTS_GLB_INLINE void +#ifdef ERTS_ENABLE_LOCK_COUNT +erts_smp_rwmtx_rwlock_x(erts_smp_rwmtx_t *rwmtx, char *file, unsigned int line) +#else +erts_smp_rwmtx_rwlock(erts_smp_rwmtx_t *rwmtx) +#endif +{ +#if defined(ERTS_SMP) && defined(ERTS_ENABLE_LOCK_COUNT) + erts_rwmtx_rwlock_x(rwmtx, file, line); +#elif defined(ERTS_SMP) + erts_rwmtx_rwlock(rwmtx); +#endif +} + +ERTS_GLB_INLINE void +erts_smp_rwmtx_rwunlock(erts_smp_rwmtx_t *rwmtx) +{ +#ifdef ERTS_SMP + erts_rwmtx_rwunlock(rwmtx); +#endif +} + +#if 0 /* The following rwmtx function names are + reserved for potential future use. */ + +/* Try upgrade from r-locked state to rw-locked state */ +ERTS_GLB_INLINE int +erts_smp_rwmtx_trywlock(erts_smp_rwmtx_t *rwmtx) +{ + return 0; +} + +/* Upgrade from r-locked state to rw-locked state */ +ERTS_GLB_INLINE void +erts_smp_rwmtx_wlock(erts_smp_rwmtx_t *rwmtx) +{ + +} + +/* Downgrade from rw-locked state to r-locked state */ +ERTS_GLB_INLINE void +erts_smp_rwmtx_wunlock(erts_smp_rwmtx_t *rwmtx) +{ + +} + +#endif + +ERTS_GLB_INLINE int +erts_smp_lc_rwmtx_is_rlocked(erts_smp_rwmtx_t *mtx) +{ +#if defined(ERTS_SMP) && defined(ERTS_ENABLE_LOCK_CHECK) + return erts_lc_rwmtx_is_rlocked(mtx); +#else + return 0; +#endif +} + +ERTS_GLB_INLINE int +erts_smp_lc_rwmtx_is_rwlocked(erts_smp_rwmtx_t *mtx) +{ +#if defined(ERTS_SMP) && defined(ERTS_ENABLE_LOCK_CHECK) + return erts_lc_rwmtx_is_rwlocked(mtx); +#else + return 0; +#endif +} + +ERTS_GLB_INLINE void +erts_smp_atomic_init(erts_smp_atomic_t *var, long i) +{ +#ifdef ERTS_SMP + erts_atomic_init(var, i); +#else + *var = i; +#endif +} + +ERTS_GLB_INLINE void +erts_smp_atomic_set(erts_smp_atomic_t *var, long i) +{ +#ifdef ERTS_SMP + erts_atomic_set(var, i); +#else + *var = i; +#endif +} + +ERTS_GLB_INLINE long +erts_smp_atomic_read(erts_smp_atomic_t *var) +{ +#ifdef ERTS_SMP + return erts_atomic_read(var); +#else + return *var; +#endif +} + +ERTS_GLB_INLINE long +erts_smp_atomic_inctest(erts_smp_atomic_t *incp) +{ +#ifdef ERTS_SMP + return erts_atomic_inctest(incp); +#else + return ++(*incp); +#endif +} + +ERTS_GLB_INLINE long +erts_smp_atomic_dectest(erts_smp_atomic_t *decp) +{ +#ifdef ERTS_SMP + return erts_atomic_dectest(decp); +#else + return --(*decp); +#endif +} + +ERTS_GLB_INLINE void +erts_smp_atomic_inc(erts_smp_atomic_t *incp) +{ +#ifdef ERTS_SMP + erts_atomic_inc(incp); +#else + ++(*incp); +#endif +} + +ERTS_GLB_INLINE void +erts_smp_atomic_dec(erts_smp_atomic_t *decp) +{ +#ifdef ERTS_SMP + erts_atomic_dec(decp); +#else + --(*decp); +#endif +} + +ERTS_GLB_INLINE long +erts_smp_atomic_addtest(erts_smp_atomic_t *addp, long i) +{ +#ifdef ERTS_SMP + return erts_atomic_addtest(addp, i); +#else + return *addp += i; +#endif +} + +ERTS_GLB_INLINE void +erts_smp_atomic_add(erts_smp_atomic_t *addp, long i) +{ +#ifdef ERTS_SMP + erts_atomic_add(addp, i); +#else + *addp += i; +#endif +} + +ERTS_GLB_INLINE long +erts_smp_atomic_xchg(erts_smp_atomic_t *xchgp, long new) +{ +#ifdef ERTS_SMP + return erts_atomic_xchg(xchgp, new); +#else + long old; + old = *xchgp; + *xchgp = new; + return old; +#endif +} + +ERTS_GLB_INLINE long +erts_smp_atomic_cmpxchg(erts_smp_atomic_t *xchgp, long new, long expected) +{ +#ifdef ERTS_SMP + return erts_atomic_cmpxchg(xchgp, new, expected); +#else + long old = *xchgp; + if (old == expected) + *xchgp = new; + return old; +#endif +} + +ERTS_GLB_INLINE long +erts_smp_atomic_bor(erts_smp_atomic_t *var, long mask) +{ +#ifdef ERTS_SMP + return erts_atomic_bor(var, mask); +#else + long old; + old = *var; + *var |= mask; + return old; +#endif +} + +ERTS_GLB_INLINE long +erts_smp_atomic_band(erts_smp_atomic_t *var, long mask) +{ +#ifdef ERTS_SMP + return erts_atomic_band(var, mask); +#else + long old; + old = *var; + *var &= mask; + return old; +#endif +} + +ERTS_GLB_INLINE void +erts_smp_spinlock_init_x(erts_smp_spinlock_t *lock, char *name, Eterm extra) +{ +#ifdef ERTS_SMP + erts_spinlock_init_x(lock, name, extra); +#else + (void)lock; +#endif +} + +ERTS_GLB_INLINE void +erts_smp_spinlock_init(erts_smp_spinlock_t *lock, char *name) +{ +#ifdef ERTS_SMP + erts_spinlock_init(lock, name); +#else + (void)lock; +#endif +} + +ERTS_GLB_INLINE void +erts_smp_spinlock_destroy(erts_smp_spinlock_t *lock) +{ +#ifdef ERTS_SMP + erts_spinlock_destroy(lock); +#else + (void)lock; +#endif +} + +ERTS_GLB_INLINE void +erts_smp_spin_unlock(erts_smp_spinlock_t *lock) +{ +#ifdef ERTS_SMP + erts_spin_unlock(lock); +#else + (void)lock; +#endif +} + +ERTS_GLB_INLINE void +#ifdef ERTS_ENABLE_LOCK_COUNT +erts_smp_spin_lock_x(erts_smp_spinlock_t *lock, char *file, unsigned int line) +#else +erts_smp_spin_lock(erts_smp_spinlock_t *lock) +#endif +{ +#if defined(ERTS_SMP) && defined(ERTS_ENABLE_LOCK_COUNT) + erts_spin_lock_x(lock, file, line); +#elif defined(ERTS_SMP) + erts_spin_lock(lock); +#else + (void)lock; +#endif +} + +ERTS_GLB_INLINE int +erts_smp_lc_spinlock_is_locked(erts_smp_spinlock_t *lock) +{ +#if defined(ERTS_SMP) && defined(ERTS_ENABLE_LOCK_CHECK) + return erts_lc_spinlock_is_locked(lock); +#else + return 0; +#endif +} + +ERTS_GLB_INLINE void +erts_smp_rwlock_init_x(erts_smp_rwlock_t *lock, char *name, Eterm extra) +{ +#ifdef ERTS_SMP + erts_rwlock_init_x(lock, name, extra); +#else + (void)lock; +#endif +} + +ERTS_GLB_INLINE void +erts_smp_rwlock_init(erts_smp_rwlock_t *lock, char *name) +{ +#ifdef ERTS_SMP + erts_rwlock_init(lock, name); +#else + (void)lock; +#endif +} + +ERTS_GLB_INLINE void +erts_smp_rwlock_destroy(erts_smp_rwlock_t *lock) +{ +#ifdef ERTS_SMP + erts_rwlock_destroy(lock); +#else + (void)lock; +#endif +} + +ERTS_GLB_INLINE void +erts_smp_read_unlock(erts_smp_rwlock_t *lock) +{ +#ifdef ERTS_SMP + erts_read_unlock(lock); +#else + (void)lock; +#endif +} + +ERTS_GLB_INLINE void +#ifdef ERTS_ENABLE_LOCK_COUNT +erts_smp_read_lock_x(erts_smp_rwlock_t *lock, char *file, unsigned int line) +#else +erts_smp_read_lock(erts_smp_rwlock_t *lock) +#endif +{ +#if defined(ERTS_ENABLE_LOCK_COUNT) && defined(ERTS_SMP) + erts_read_lock_x(lock, file, line); +#elif defined(ERTS_SMP) + erts_read_lock(lock); +#else + (void)lock; +#endif +} + +ERTS_GLB_INLINE void +erts_smp_write_unlock(erts_smp_rwlock_t *lock) +{ +#ifdef ERTS_SMP + erts_write_unlock(lock); +#else + (void)lock; +#endif +} + +ERTS_GLB_INLINE void +#ifdef ERTS_ENABLE_LOCK_COUNT +erts_smp_write_lock_x(erts_smp_rwlock_t *lock, char *file, unsigned int line) +#else +erts_smp_write_lock(erts_smp_rwlock_t *lock) +#endif +{ +#if defined(ERTS_SMP) && defined(ERTS_ENABLE_LOCK_COUNT) + erts_write_lock_x(lock, file, line); +#elif defined(ERTS_SMP) + erts_write_lock(lock); +#else + (void)lock; +#endif +} + +ERTS_GLB_INLINE int +erts_smp_lc_rwlock_is_rlocked(erts_smp_rwlock_t *lock) +{ +#if defined(ERTS_SMP) && defined(ERTS_ENABLE_LOCK_CHECK) + return erts_lc_rwlock_is_rlocked(lock); +#else + return 0; +#endif +} + +ERTS_GLB_INLINE int +erts_smp_lc_rwlock_is_rwlocked(erts_smp_rwlock_t *lock) +{ +#if defined(ERTS_SMP) && defined(ERTS_ENABLE_LOCK_CHECK) + return erts_lc_rwlock_is_rwlocked(lock); +#else + return 0; +#endif +} + +ERTS_GLB_INLINE void +erts_smp_thr_time_now(erts_smp_thr_timeval_t *time) +{ +#ifdef ERTS_SMP + erts_thr_time_now(time); +#endif +} + +ERTS_GLB_INLINE void +erts_smp_tsd_key_create(erts_smp_tsd_key_t *keyp) +{ +#ifdef ERTS_SMP + erts_tsd_key_create(keyp); +#endif +} + +ERTS_GLB_INLINE void +erts_smp_tsd_key_delete(erts_smp_tsd_key_t key) +{ +#ifdef ERTS_SMP + erts_tsd_key_delete(key); +#endif +} + +ERTS_GLB_INLINE void +erts_smp_tsd_set(erts_smp_tsd_key_t key, void *value) +{ +#ifdef ERTS_SMP + erts_tsd_set(key, value); +#endif +} + +ERTS_GLB_INLINE void * +erts_smp_tsd_get(erts_smp_tsd_key_t key) +{ +#ifdef ERTS_SMP + return erts_tsd_get(key); +#else + return NULL; +#endif +} + +ERTS_GLB_INLINE void +erts_smp_gate_init(erts_smp_gate_t *gp) +{ +#ifdef ERTS_SMP + erts_gate_init((erts_gate_t *) gp); +#endif +} + +ERTS_GLB_INLINE void +erts_smp_gate_destroy(erts_smp_gate_t *gp) +{ +#ifdef ERTS_SMP + erts_gate_destroy((erts_gate_t *) gp); +#endif +} + +ERTS_GLB_INLINE void +erts_smp_gate_close(erts_smp_gate_t *gp) +{ +#ifdef ERTS_SMP + erts_gate_close((erts_gate_t *) gp); +#endif +} + +ERTS_GLB_INLINE void +erts_smp_gate_let_through(erts_smp_gate_t *gp, unsigned no) +{ +#ifdef ERTS_SMP + erts_gate_let_through((erts_gate_t *) gp, no); +#endif +} + +ERTS_GLB_INLINE void +erts_smp_gate_wait(erts_smp_gate_t *gp) +{ +#ifdef ERTS_SMP + erts_gate_wait((erts_gate_t *) gp); +#endif +} + +ERTS_GLB_INLINE void +erts_smp_gate_swait(erts_smp_gate_t *gp, int spincount) +{ +#ifdef ERTS_SMP + erts_gate_swait((erts_gate_t *) gp, spincount); +#endif +} + +#ifdef ERTS_THR_HAVE_SIG_FUNCS +#define ERTS_SMP_THR_HAVE_SIG_FUNCS 1 + +ERTS_GLB_INLINE void +erts_smp_thr_sigmask(int how, const sigset_t *set, sigset_t *oset) +{ +#ifdef ERTS_SMP + erts_thr_sigmask(how, set, oset); +#endif +} + +ERTS_GLB_INLINE void +erts_smp_thr_sigwait(const sigset_t *set, int *sig) +{ +#ifdef ERTS_SMP + erts_thr_sigwait(set, sig); +#endif +} + +#endif /* #ifdef ERTS_THR_HAVE_SIG_FUNCS */ + +#endif /* #if ERTS_GLB_INLINE_INCL_FUNC_DEF */ + +#endif /* ERL_SMP_H */ diff --git a/erts/emulator/beam/erl_sock.h b/erts/emulator/beam/erl_sock.h new file mode 100644 index 0000000000..7ae6116dc5 --- /dev/null +++ b/erts/emulator/beam/erl_sock.h @@ -0,0 +1,44 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2003-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* + * A *very* limited socket interface exported by inet_drv.c. + * Used by the erl_mtrace.c. + */ + +#ifndef ERL_SOCK_H_ +#define ERL_SOCK_H_ + +#ifdef __WIN32__ +#include +typedef SOCKET erts_sock_t; +#else +typedef int erts_sock_t; +#endif + +#define ERTS_SOCK_INVALID_SOCKET -1 + +erts_sock_t erts_sock_open(void); +void erts_sock_close(erts_sock_t); +int erts_sock_connect(erts_sock_t, byte *, int, Uint16); +Sint erts_sock_send(erts_sock_t, const void *, Sint); +int erts_sock_gethostname(char *, int); +int erts_sock_errno(void); + +#endif diff --git a/erts/emulator/beam/erl_sys_driver.h b/erts/emulator/beam/erl_sys_driver.h new file mode 100644 index 0000000000..d429d0ce96 --- /dev/null +++ b/erts/emulator/beam/erl_sys_driver.h @@ -0,0 +1,44 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2001-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* + * Include file for erlang driver writers. + */ + +#ifndef __ERL_SYS_DRIVER_H__ +#define __ERL_SYS_DRIVER_H__ + +#ifdef __ERL_DRIVER_H__ +#error erl_sys_driver.h cannot be included after erl_driver.h +#endif + +#define ERL_SYS_DRV + +typedef long ErlDrvEvent; /* An event to be selected on. */ +typedef long ErlDrvPort; /* A port descriptor. */ + +/* typedef struct _SysDriverOpts SysDriverOpts; defined in sys.h */ + +#include "erl_driver.h" + +#endif + + + + diff --git a/erts/emulator/beam/erl_term.c b/erts/emulator/beam/erl_term.c new file mode 100644 index 0000000000..2924abbd51 --- /dev/null +++ b/erts/emulator/beam/erl_term.c @@ -0,0 +1,174 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2000-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#if HAVE_CONFIG_H +#include "config.h" +#endif +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include +#include + +__decl_noreturn static void __noreturn +et_abort(const char *expr, const char *file, unsigned line) +{ +#ifdef EXIT_ON_ET_ABORT + static int have_been_called = 0; + + if (have_been_called) { + abort(); + } else { + /* + * Prevent infinite loop. + */ + have_been_called = 1; + erl_exit(1, "TYPE ASSERTION FAILED, file %s, line %u: %s\n", file, line, expr); + } +#else + erts_fprintf(stderr, "TYPE ASSERTION FAILED, file %s, line %u: %s\n", file, line, expr); + abort(); +#endif +} + +#if ET_DEBUG +#define ET_ASSERT(expr,file,line) \ +do { \ + if (!(expr)) \ + et_abort(#expr, file, line); \ +} while(0) +#else +#define ET_ASSERT(expr,file,line) do { } while(0) +#endif + +#if ET_DEBUG +unsigned tag_val_def_debug(Eterm x, const char *file, unsigned line) +#else +unsigned tag_val_def(Eterm x) +#define file __FILE__ +#define line __LINE__ +#endif +{ + static char msg[32]; + + switch (x & _TAG_PRIMARY_MASK) { + case TAG_PRIMARY_LIST: return LIST_DEF; + case TAG_PRIMARY_BOXED: { + Eterm hdr = *boxed_val(x); + ET_ASSERT(is_header(hdr),file,line); + switch ((hdr & _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_HEADER_ARITYVAL >> _TAG_PRIMARY_SIZE): return TUPLE_DEF; + case (_TAG_HEADER_POS_BIG >> _TAG_PRIMARY_SIZE): return BIG_DEF; + case (_TAG_HEADER_NEG_BIG >> _TAG_PRIMARY_SIZE): return BIG_DEF; + case (_TAG_HEADER_REF >> _TAG_PRIMARY_SIZE): return REF_DEF; + case (_TAG_HEADER_FLOAT >> _TAG_PRIMARY_SIZE): return FLOAT_DEF; + case (_TAG_HEADER_EXPORT >> _TAG_PRIMARY_SIZE): return EXPORT_DEF; + case (_TAG_HEADER_FUN >> _TAG_PRIMARY_SIZE): return FUN_DEF; + case (_TAG_HEADER_EXTERNAL_PID >> _TAG_PRIMARY_SIZE): return EXTERNAL_PID_DEF; + case (_TAG_HEADER_EXTERNAL_PORT >> _TAG_PRIMARY_SIZE): return EXTERNAL_PORT_DEF; + case (_TAG_HEADER_EXTERNAL_REF >> _TAG_PRIMARY_SIZE): return EXTERNAL_REF_DEF; + default: return BINARY_DEF; + } + break; + } + case TAG_PRIMARY_IMMED1: { + switch ((x & _TAG_IMMED1_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_IMMED1_PID >> _TAG_PRIMARY_SIZE): return PID_DEF; + case (_TAG_IMMED1_PORT >> _TAG_PRIMARY_SIZE): return PORT_DEF; + case (_TAG_IMMED1_IMMED2 >> _TAG_PRIMARY_SIZE): { + switch ((x & _TAG_IMMED2_MASK) >> _TAG_IMMED1_SIZE) { + case (_TAG_IMMED2_ATOM >> _TAG_IMMED1_SIZE): return ATOM_DEF; + case (_TAG_IMMED2_NIL >> _TAG_IMMED1_SIZE): return NIL_DEF; + } + break; + } + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): return SMALL_DEF; + } + break; + } + } + sprintf(msg, "tag_val_def: %#lx", x); + et_abort(msg, file, line); +#undef file +#undef line +} + +/* + * XXX: define NUMBER_CODE() here when new representation is used + */ + +#if ET_DEBUG +#define ET_DEFINE_CHECKED(FUNTY,FUN,ARGTY,PRECOND) \ +FUNTY checked_##FUN(ARGTY x, const char *file, unsigned line) \ +{ \ + ET_ASSERT(PRECOND(x),file,line); \ + return _unchecked_##FUN(x); \ +} + +ET_DEFINE_CHECKED(Eterm,make_boxed,Eterm*,_is_aligned); +ET_DEFINE_CHECKED(int,is_boxed,Eterm,!is_header); +ET_DEFINE_CHECKED(Eterm*,boxed_val,Eterm,is_boxed); +ET_DEFINE_CHECKED(Eterm,make_list,Eterm*,_is_aligned); +ET_DEFINE_CHECKED(int,is_not_list,Eterm,!is_header); +ET_DEFINE_CHECKED(Eterm*,list_val,Eterm,is_list); +ET_DEFINE_CHECKED(Uint,unsigned_val,Eterm,is_small); +ET_DEFINE_CHECKED(Sint,signed_val,Eterm,is_small); +ET_DEFINE_CHECKED(Uint,atom_val,Eterm,is_atom); +ET_DEFINE_CHECKED(Uint,header_arity,Eterm,is_header); +ET_DEFINE_CHECKED(Uint,arityval,Eterm,is_arity_value); +ET_DEFINE_CHECKED(Uint,thing_arityval,Eterm,is_thing); +ET_DEFINE_CHECKED(Uint,thing_subtag,Eterm,is_thing); +ET_DEFINE_CHECKED(Eterm*,binary_val,Eterm,is_binary); +ET_DEFINE_CHECKED(Eterm*,fun_val,Eterm,is_fun); +ET_DEFINE_CHECKED(int,bignum_header_is_neg,Eterm,_is_bignum_header); +ET_DEFINE_CHECKED(Eterm,bignum_header_neg,Eterm,_is_bignum_header); +ET_DEFINE_CHECKED(Uint,bignum_header_arity,Eterm,_is_bignum_header); +ET_DEFINE_CHECKED(Eterm*,big_val,Eterm,is_big); +ET_DEFINE_CHECKED(Eterm*,float_val,Eterm,is_float); +ET_DEFINE_CHECKED(Eterm*,tuple_val,Eterm,is_tuple); +ET_DEFINE_CHECKED(Uint,internal_pid_data,Eterm,is_internal_pid); +ET_DEFINE_CHECKED(struct erl_node_*,internal_pid_node,Eterm,is_internal_pid); +ET_DEFINE_CHECKED(Uint,internal_port_data,Eterm,is_internal_port); +ET_DEFINE_CHECKED(struct erl_node_*,internal_port_node,Eterm,is_internal_port); +ET_DEFINE_CHECKED(Eterm*,internal_ref_val,Eterm,is_internal_ref); +ET_DEFINE_CHECKED(Uint,internal_ref_data_words,Eterm,is_internal_ref); +ET_DEFINE_CHECKED(Uint32*,internal_ref_data,Eterm,is_internal_ref); +ET_DEFINE_CHECKED(struct erl_node_*,internal_ref_node,Eterm,is_internal_ref); +ET_DEFINE_CHECKED(Eterm*,external_val,Eterm,is_external); +ET_DEFINE_CHECKED(Uint,external_data_words,Eterm,is_external); +ET_DEFINE_CHECKED(Uint,external_pid_data_words,Eterm,is_external_pid); +ET_DEFINE_CHECKED(Uint,external_pid_data,Eterm,is_external_pid); +ET_DEFINE_CHECKED(struct erl_node_*,external_pid_node,Eterm,is_external_pid); +ET_DEFINE_CHECKED(Uint,external_port_data_words,Eterm,is_external_port); +ET_DEFINE_CHECKED(Uint,external_port_data,Eterm,is_external_port); +ET_DEFINE_CHECKED(struct erl_node_*,external_port_node,Eterm,is_external_port); +ET_DEFINE_CHECKED(Uint,external_ref_data_words,Eterm,is_external_ref); +ET_DEFINE_CHECKED(Uint32*,external_ref_data,Eterm,is_external_ref); +ET_DEFINE_CHECKED(struct erl_node_*,external_ref_node,Eterm,is_external_ref); +ET_DEFINE_CHECKED(Eterm*,export_val,Eterm,is_export); + +ET_DEFINE_CHECKED(Eterm,make_cp,Uint*,_is_aligned); +ET_DEFINE_CHECKED(Uint*,cp_val,Eterm,is_CP); +ET_DEFINE_CHECKED(Uint,catch_val,Eterm,is_catch); +ET_DEFINE_CHECKED(Uint,x_reg_offset,Uint,_is_xreg); +ET_DEFINE_CHECKED(Uint,y_reg_offset,Uint,_is_yreg); +ET_DEFINE_CHECKED(Uint,x_reg_index,Uint,_is_xreg); +ET_DEFINE_CHECKED(Uint,y_reg_index,Uint,_is_yreg); + +#endif /* ET_DEBUG */ diff --git a/erts/emulator/beam/erl_term.h b/erts/emulator/beam/erl_term.h new file mode 100644 index 0000000000..b0a57a3ebe --- /dev/null +++ b/erts/emulator/beam/erl_term.h @@ -0,0 +1,1056 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2000-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifndef __ERL_TERM_H +#define __ERL_TERM_H + +struct erl_node_; /* Declared in erl_node_tables.h */ + +/* + * Defining ET_DEBUG to 1 causes all type-specific data access + * macros to perform runtime type checking. This is very useful + * during development but reduces performance, so ET_DEBUG should + * be disabled during benchmarking or release. + */ +/* #define ET_DEBUG 1 */ +#ifndef ET_DEBUG +# ifdef DEBUG +# define ET_DEBUG 1 +# else +# define ET_DEBUG 0 +# endif +#endif + +#if ET_DEBUG +#define _ET_DECLARE_CHECKED(TF,F,TX) extern TF checked_##F(TX,const char*,unsigned) +#define _ET_APPLY(F,X) checked_##F(X,__FILE__,__LINE__) +#else +#define _ET_DECLARE_CHECKED(TF,F,TX) +#define _ET_APPLY(F,X) _unchecked_##F(X) +#endif + +#define _TAG_PRIMARY_SIZE 2 +#define _TAG_PRIMARY_MASK 0x3 +#define TAG_PRIMARY_HEADER 0x0 +#define TAG_PRIMARY_LIST 0x1 +#define TAG_PRIMARY_BOXED 0x2 +#define TAG_PRIMARY_IMMED1 0x3 + +#define primary_tag(x) ((x) & _TAG_PRIMARY_MASK) + +#define _TAG_IMMED1_SIZE 4 +#define _TAG_IMMED1_MASK 0xF +#define _TAG_IMMED1_PID ((0x0 << _TAG_PRIMARY_SIZE) | TAG_PRIMARY_IMMED1) +#define _TAG_IMMED1_PORT ((0x1 << _TAG_PRIMARY_SIZE) | TAG_PRIMARY_IMMED1) +#define _TAG_IMMED1_IMMED2 ((0x2 << _TAG_PRIMARY_SIZE) | TAG_PRIMARY_IMMED1) +#define _TAG_IMMED1_SMALL ((0x3 << _TAG_PRIMARY_SIZE) | TAG_PRIMARY_IMMED1) + +#define _TAG_IMMED2_SIZE 6 +#define _TAG_IMMED2_MASK 0x3F +#define _TAG_IMMED2_ATOM ((0x0 << _TAG_IMMED1_SIZE) | _TAG_IMMED1_IMMED2) +#define _TAG_IMMED2_CATCH ((0x1 << _TAG_IMMED1_SIZE) | _TAG_IMMED1_IMMED2) +#define _TAG_IMMED2_NIL ((0x3 << _TAG_IMMED1_SIZE) | _TAG_IMMED1_IMMED2) + +/* + * HEADER representation: + * + * aaaaaaaaaaaaaaaaaaaaaaaaaatttt00 arity:26, tag:4 + * + * HEADER tags: + * + * 0000 ARITYVAL + * 0001 BINARY_AGGREGATE | + * 001x BIGNUM with sign bit | + * 0100 REF | + * 0101 FUN | THINGS + * 0110 FLONUM | + * 0111 EXPORT | + * 1000 REFC_BINARY | | + * 1001 HEAP_BINARY | BINARIES | + * 1010 SUB_BINARY | | + * 1011 Not used + * 1100 EXTERNAL_PID | | + * 1101 EXTERNAL_PORT | EXTERNAL THINGS | + * 1110 EXTERNAL_REF | | + * 1111 Not used + * + * COMMENTS: + * + * - The tag is zero for arityval and non-zero for thing headers. + * - A single bit differentiates between positive and negative bignums. + * - If more tags are needed, the REF and and EXTERNAL_REF tags could probably + * be combined to one tag. + * + * XXX: globally replace XXX_SUBTAG with TAG_HEADER_XXX + */ +#define ARITYVAL_SUBTAG (0x0 << _TAG_PRIMARY_SIZE) /* TUPLE */ +#define BIN_MATCHSTATE_SUBTAG (0x1 << _TAG_PRIMARY_SIZE) +#define POS_BIG_SUBTAG (0x2 << _TAG_PRIMARY_SIZE) /* BIG: tags 2&3 */ +#define NEG_BIG_SUBTAG (0x3 << _TAG_PRIMARY_SIZE) /* BIG: tags 2&3 */ +#define _BIG_SIGN_BIT (0x1 << _TAG_PRIMARY_SIZE) +#define REF_SUBTAG (0x4 << _TAG_PRIMARY_SIZE) /* REF */ +#define FUN_SUBTAG (0x5 << _TAG_PRIMARY_SIZE) /* FUN */ +#define FLOAT_SUBTAG (0x6 << _TAG_PRIMARY_SIZE) /* FLOAT */ +#define EXPORT_SUBTAG (0x7 << _TAG_PRIMARY_SIZE) /* FLOAT */ +#define _BINARY_XXX_MASK (0x3 << _TAG_PRIMARY_SIZE) +#define REFC_BINARY_SUBTAG (0x8 << _TAG_PRIMARY_SIZE) /* BINARY */ +#define HEAP_BINARY_SUBTAG (0x9 << _TAG_PRIMARY_SIZE) /* BINARY */ +#define SUB_BINARY_SUBTAG (0xA << _TAG_PRIMARY_SIZE) /* BINARY */ +#define EXTERNAL_PID_SUBTAG (0xC << _TAG_PRIMARY_SIZE) /* EXTERNAL_PID */ +#define EXTERNAL_PORT_SUBTAG (0xD << _TAG_PRIMARY_SIZE) /* EXTERNAL_PORT */ +#define EXTERNAL_REF_SUBTAG (0xE << _TAG_PRIMARY_SIZE) /* EXTERNAL_REF */ + + +#define _TAG_HEADER_ARITYVAL (TAG_PRIMARY_HEADER|ARITYVAL_SUBTAG) +#define _TAG_HEADER_FUN (TAG_PRIMARY_HEADER|FUN_SUBTAG) +#define _TAG_HEADER_POS_BIG (TAG_PRIMARY_HEADER|POS_BIG_SUBTAG) +#define _TAG_HEADER_NEG_BIG (TAG_PRIMARY_HEADER|NEG_BIG_SUBTAG) +#define _TAG_HEADER_FLOAT (TAG_PRIMARY_HEADER|FLOAT_SUBTAG) +#define _TAG_HEADER_EXPORT (TAG_PRIMARY_HEADER|EXPORT_SUBTAG) +#define _TAG_HEADER_REF (TAG_PRIMARY_HEADER|REF_SUBTAG) +#define _TAG_HEADER_REFC_BIN (TAG_PRIMARY_HEADER|REFC_BINARY_SUBTAG) +#define _TAG_HEADER_HEAP_BIN (TAG_PRIMARY_HEADER|HEAP_BINARY_SUBTAG) +#define _TAG_HEADER_SUB_BIN (TAG_PRIMARY_HEADER|SUB_BINARY_SUBTAG) +#define _TAG_HEADER_EXTERNAL_PID (TAG_PRIMARY_HEADER|EXTERNAL_PID_SUBTAG) +#define _TAG_HEADER_EXTERNAL_PORT (TAG_PRIMARY_HEADER|EXTERNAL_PORT_SUBTAG) +#define _TAG_HEADER_EXTERNAL_REF (TAG_PRIMARY_HEADER|EXTERNAL_REF_SUBTAG) +#define _TAG_HEADER_BIN_MATCHSTATE (TAG_PRIMARY_HEADER|BIN_MATCHSTATE_SUBTAG) + + +#define _TAG_HEADER_MASK 0x3F +#define _HEADER_SUBTAG_MASK 0x3C /* 4 bits for subtag */ +#define _HEADER_ARITY_OFFS 6 + +#define header_is_transparent(x) \ + (((x) & (_HEADER_SUBTAG_MASK)) == ARITYVAL_SUBTAG) +#define header_is_arityval(x) (((x) & _HEADER_SUBTAG_MASK) == ARITYVAL_SUBTAG) +#define header_is_thing(x) (!header_is_transparent((x))) +#define header_is_bin_matchstate(x) ((((x) & (_HEADER_SUBTAG_MASK)) == BIN_MATCHSTATE_SUBTAG)) + +#define _CPMASK 0x3 + +/* immediate object access methods */ +#define is_immed(x) (((x) & _TAG_PRIMARY_MASK) == TAG_PRIMARY_IMMED1) +#define is_not_immed(x) (!is_immed((x))) +#define IS_CONST(x) is_immed((x)) +#if TAG_PRIMARY_IMMED1 == _TAG_PRIMARY_MASK +#define is_both_immed(x,y) is_immed(((x)&(y))) +#else +#define is_both_immed(x,y) (is_immed((x)) && is_immed((y))) +#endif +#define is_not_both_immed(x,y) (!is_both_immed((x),(y))) + + +/* boxed object access methods */ +#define _is_aligned(x) (((Uint)(x) & 0x3) == 0) +#define _unchecked_make_boxed(x) ((Uint)(x) + TAG_PRIMARY_BOXED) +_ET_DECLARE_CHECKED(Eterm,make_boxed,Eterm*); +#define make_boxed(x) _ET_APPLY(make_boxed,(x)) +#if 1 +#define _is_not_boxed(x) ((x) & (_TAG_PRIMARY_MASK-TAG_PRIMARY_BOXED)) +#define _unchecked_is_boxed(x) (!_is_not_boxed((x))) +_ET_DECLARE_CHECKED(int,is_boxed,Eterm); +#define is_boxed(x) _ET_APPLY(is_boxed,(x)) +#else +#define is_boxed(x) (((x) & _TAG_PRIMARY_MASK) == TAG_PRIMARY_BOXED) +#endif +#define _unchecked_boxed_val(x) ((Eterm*)((x) - TAG_PRIMARY_BOXED)) +_ET_DECLARE_CHECKED(Eterm*,boxed_val,Eterm); +#define boxed_val(x) _ET_APPLY(boxed_val,(x)) + +/* cons cell ("list") access methods */ +#define _unchecked_make_list(x) ((Uint)(x) + TAG_PRIMARY_LIST) +_ET_DECLARE_CHECKED(Eterm,make_list,Eterm*); +#define make_list(x) _ET_APPLY(make_list,(x)) +#if 1 +#define _unchecked_is_not_list(x) ((x) & (_TAG_PRIMARY_MASK-TAG_PRIMARY_LIST)) +_ET_DECLARE_CHECKED(int,is_not_list,Eterm); +#define is_not_list(x) _ET_APPLY(is_not_list,(x)) +#define is_list(x) (!is_not_list((x))) +#else +#define is_list(x) (((x) & _TAG_PRIMARY_MASK) == TAG_PRIMARY_LIST) +#define is_not_list(x) (!is_list((x))) +#endif +#define _unchecked_list_val(x) ((Eterm*)((x) - TAG_PRIMARY_LIST)) +_ET_DECLARE_CHECKED(Eterm*,list_val,Eterm); +#define list_val(x) _ET_APPLY(list_val,(x)) + +#define CONS(hp, car, cdr) \ + (CAR(hp)=(car), CDR(hp)=(cdr), make_list(hp)) + +#define CAR(x) ((x)[0]) +#define CDR(x) ((x)[1]) + +/* generic tagged pointer (boxed or list) access methods */ +#define _unchecked_ptr_val(x) ((Eterm*)((x) & ~((Uint) 0x3))) +#define ptr_val(x) _unchecked_ptr_val((x)) /*XXX*/ +#define _unchecked_offset_ptr(x,offs) ((x)+((offs)*sizeof(Eterm))) +#define offset_ptr(x,offs) _unchecked_offset_ptr(x,offs) /*XXX*/ + +/* fixnum ("small") access methods */ +#if defined(ARCH_64) +#define SMALL_BITS (64-4) +#define SMALL_DIGITS (17) +#else +#define SMALL_BITS (28) +#define SMALL_DIGITS (8) +#endif +#define MAX_SMALL ((1L << (SMALL_BITS-1))-1) +#define MIN_SMALL (-(1L << (SMALL_BITS-1))) +#define make_small(x) (((Uint)(x) << _TAG_IMMED1_SIZE) + _TAG_IMMED1_SMALL) +#define is_small(x) (((x) & _TAG_IMMED1_MASK) == _TAG_IMMED1_SMALL) +#define is_not_small(x) (!is_small((x))) +#define is_byte(x) (((x) & ((~(Uint)0 << (_TAG_IMMED1_SIZE+8)) + _TAG_IMMED1_MASK)) == _TAG_IMMED1_SMALL) +#define is_valid_bit_size(x) (((Sint)(x)) >= 0 && ((x) & 0x7F) == _TAG_IMMED1_SMALL) +#define is_not_valid_bit_size(x) (!is_valid_bit_size((x))) +#define MY_IS_SSMALL(x) (((Uint) (((x) >> (SMALL_BITS-1)) + 1)) < 2) +#define _unchecked_unsigned_val(x) ((x) >> _TAG_IMMED1_SIZE) +_ET_DECLARE_CHECKED(Uint,unsigned_val,Eterm); +#define unsigned_val(x) _ET_APPLY(unsigned_val,(x)) +#define _unchecked_signed_val(x) ((Sint)(x) >> _TAG_IMMED1_SIZE) +_ET_DECLARE_CHECKED(Sint,signed_val,Eterm); +#define signed_val(x) _ET_APPLY(signed_val,(x)) + +#if _TAG_IMMED1_SMALL == 0x0F +#define is_both_small(x,y) (((x) & (y) & _TAG_IMMED1_MASK) == _TAG_IMMED1_SMALL) +#elif _TAG_IMMED1_SMALL == 0x00 +#define is_both_small(x,y) ((((x)|(y)) & _TAG_IMMED1_MASK) == _TAG_IMMED1_SMALL) +#else +#define is_both_small(x,y) (is_small(x) && is_small(y)) +#endif + +/* NIL access methods */ +#define NIL ((~((Uint) 0) << _TAG_IMMED2_SIZE) | _TAG_IMMED2_NIL) +#define is_nil(x) ((x) == NIL) +#define is_not_nil(x) ((x) != NIL) + +#define MAX_ATOM_INDEX (~(~((Uint) 0) << (sizeof(Uint)*8 - _TAG_IMMED2_SIZE))) + +/* atom access methods */ +#define make_atom(x) ((Eterm)(((x) << _TAG_IMMED2_SIZE) + _TAG_IMMED2_ATOM)) +#define is_atom(x) (((x) & _TAG_IMMED2_MASK) == _TAG_IMMED2_ATOM) +#define is_not_atom(x) (!is_atom(x)) +#define _unchecked_atom_val(x) ((x) >> _TAG_IMMED2_SIZE) +_ET_DECLARE_CHECKED(Uint,atom_val,Eterm); +#define atom_val(x) _ET_APPLY(atom_val,(x)) + +/* header (arityval or thing) access methods */ +#define _make_header(sz,tag) ((Uint)(((sz) << _HEADER_ARITY_OFFS) + (tag))) +#define is_header(x) (((x) & _TAG_PRIMARY_MASK) == TAG_PRIMARY_HEADER) +#define _unchecked_header_arity(x) ((x) >> _HEADER_ARITY_OFFS) +_ET_DECLARE_CHECKED(Uint,header_arity,Eterm); +#define header_arity(x) _ET_APPLY(header_arity,(x)) + +/* arityval access methods */ +#define make_arityval(sz) _make_header((sz),_TAG_HEADER_ARITYVAL) +#define is_arity_value(x) (((x) & _TAG_HEADER_MASK) == _TAG_HEADER_ARITYVAL) +#define is_not_arity_value(x) (!is_arity_value((x))) +#define _unchecked_arityval(x) _unchecked_header_arity((x)) +_ET_DECLARE_CHECKED(Uint,arityval,Eterm); +#define arityval(x) _ET_APPLY(arityval,(x)) + +/* thing access methods */ +#define is_thing(x) (is_header((x)) && header_is_thing((x))) +#define _unchecked_thing_arityval(x) _unchecked_header_arity((x)) +_ET_DECLARE_CHECKED(Uint,thing_arityval,Eterm); +#define thing_arityval(x) _ET_APPLY(thing_arityval,(x)) +#define _unchecked_thing_subtag(x) ((x) & _HEADER_SUBTAG_MASK) +_ET_DECLARE_CHECKED(Uint,thing_subtag,Eterm); +#define thing_subtag(x) _ET_APPLY(thing_subtag,(x)) + +/* + * Magic non-value object. + * Used as function return error and "absent value" indicator + * in the original runtime system. The new runtime system also + * uses it as forwarding marker for CONS cells. + * + * This value is 0 in the original runtime system, which unfortunately + * promotes sloppy programming practices. It also prevents some useful + * tag assignment schemes, e.g. using a 2-bit tag 00 for FIXNUM. + * + * To help find code which makes unwarranted assumptions about zero, + * we now use a non-zero bit-pattern in debug mode. + */ +#if ET_DEBUG +#define THE_NON_VALUE _make_header(0,_TAG_HEADER_FLOAT) +#else +#define THE_NON_VALUE (0) +#endif +#define is_non_value(x) ((x) == THE_NON_VALUE) +#define is_value(x) ((x) != THE_NON_VALUE) + +/* binary object access methods */ +#define is_binary_header(x) (((x) & (_TAG_HEADER_MASK-_BINARY_XXX_MASK)) == _TAG_HEADER_REFC_BIN) +#define make_binary(x) make_boxed((Eterm*)(x)) +#define is_binary(x) (is_boxed((x)) && is_binary_header(*boxed_val((x)))) +#define is_not_binary(x) (!is_binary((x))) +#define _unchecked_binary_val(x) _unchecked_boxed_val((x)) +_ET_DECLARE_CHECKED(Eterm*,binary_val,Eterm); +#define binary_val(x) _ET_APPLY(binary_val,(x)) + +/* process binaries stuff (special case of binaries) */ +#define HEADER_PROC_BIN _make_header(PROC_BIN_SIZE-1,_TAG_HEADER_REFC_BIN) + +/* fun & export objects */ +#define is_any_fun(x) (is_fun((x)) || is_export((x))) +#define is_not_any_fun(x) (!is_any_fun((x))) + +/* fun objects */ +#define HEADER_FUN _make_header(ERL_FUN_SIZE-2,_TAG_HEADER_FUN) +#define is_fun_header(x) ((x) == HEADER_FUN) +#define make_fun(x) make_boxed((Eterm*)(x)) +#define is_fun(x) (is_boxed((x)) && is_fun_header(*boxed_val((x)))) +#define is_not_fun(x) (!is_fun((x))) +#define _unchecked_fun_val(x) _unchecked_boxed_val((x)) +_ET_DECLARE_CHECKED(Eterm*,fun_val,Eterm); +#define fun_val(x) _ET_APPLY(fun_val,(x)) + +/* export access methods */ +#define make_export(x) make_boxed((x)) +#define is_export(x) (is_boxed((x)) && is_export_header(*boxed_val((x)))) +#define is_not_export(x) (!is_export((x))) +#define _unchecked_export_val(x) _unchecked_boxed_val(x) +_ET_DECLARE_CHECKED(Eterm*,export_val,Eterm); +#define export_val(x) _ET_APPLY(export_val,(x)) +#define is_export_header(x) ((x) == HEADER_EXPORT) +#define HEADER_EXPORT _make_header(1,_TAG_HEADER_EXPORT) + +/* bignum access methods */ +#define make_pos_bignum_header(sz) _make_header((sz),_TAG_HEADER_POS_BIG) +#define make_neg_bignum_header(sz) _make_header((sz),_TAG_HEADER_NEG_BIG) +#define _is_bignum_header(x) (((x) & (_TAG_HEADER_MASK-_BIG_SIGN_BIT)) == _TAG_HEADER_POS_BIG) +#define _unchecked_bignum_header_is_neg(x) ((x) & _BIG_SIGN_BIT) +_ET_DECLARE_CHECKED(int,bignum_header_is_neg,Eterm); +#define bignum_header_is_neg(x) _ET_APPLY(bignum_header_is_neg,(x)) +#define _unchecked_bignum_header_neg(x) ((x) | _BIG_SIGN_BIT) +_ET_DECLARE_CHECKED(Eterm,bignum_header_neg,Eterm); +#define bignum_header_neg(x) _ET_APPLY(bignum_header_neg,(x)) +#define _unchecked_bignum_header_arity(x) _unchecked_header_arity((x)) +_ET_DECLARE_CHECKED(Uint,bignum_header_arity,Eterm); +#define bignum_header_arity(x) _ET_APPLY(bignum_header_arity,(x)) +#define BIG_ARITY_MAX ((1 << 19)-1) +#define make_big(x) make_boxed((x)) +#define is_big(x) (is_boxed((x)) && _is_bignum_header(*boxed_val((x)))) +#define is_not_big(x) (!is_big((x))) +#define _unchecked_big_val(x) _unchecked_boxed_val((x)) +_ET_DECLARE_CHECKED(Eterm*,big_val,Eterm); +#define big_val(x) _ET_APPLY(big_val,(x)) + +/* flonum ("float") access methods */ +#ifdef ARCH_64 +#define HEADER_FLONUM _make_header(1,_TAG_HEADER_FLOAT) +#else +#define HEADER_FLONUM _make_header(2,_TAG_HEADER_FLOAT) +#endif +#define make_float(x) make_boxed((x)) +#define is_float(x) (is_boxed((x)) && *boxed_val((x)) == HEADER_FLONUM) +#define is_not_float(x) (!is_float(x)) +#define _unchecked_float_val(x) _unchecked_boxed_val((x)) +_ET_DECLARE_CHECKED(Eterm*,float_val,Eterm); +#define float_val(x) _ET_APPLY(float_val,(x)) + +/* Float definition for byte and word access */ +typedef double ieee754_8; + +typedef union float_def +{ + ieee754_8 fd; + byte fb[sizeof(ieee754_8)]; + Uint16 fs[sizeof(ieee754_8) / sizeof(Uint16)]; + Uint32 fw[sizeof(ieee754_8) / sizeof(Uint32)]; +#ifdef ARCH_64 + Uint fdw; +#endif +} FloatDef; + +#ifdef ARCH_64 +#define GET_DOUBLE(x, f) (f).fdw = *(float_val(x)+1) + +#define PUT_DOUBLE(f, x) *(x) = HEADER_FLONUM, \ + *((x)+1) = (f).fdw +#define GET_DOUBLE_DATA(p, f) (f).fdw = *((Uint *) (p)) +#define PUT_DOUBLE_DATA(f,p) *((Uint *) (p)) = (f).fdw +#else +#define GET_DOUBLE(x, f) (f).fw[0] = *(float_val(x)+1), \ + (f).fw[1] = *(float_val(x)+2) + +#define PUT_DOUBLE(f, x) *(x) = HEADER_FLONUM, \ + *((x)+1) = (f).fw[0], \ + *((x)+2) = (f).fw[1] +#define GET_DOUBLE_DATA(p, f) (f).fw[0] = *((Uint *) (p)),\ + (f).fw[1] = *(((Uint *) (p))+1) +#define PUT_DOUBLE_DATA(f,p) *((Uint *) (p)) = (f).fw[0],\ + *(((Uint *) (p))+1) = (f).fw[1] +#endif +#define DOUBLE_DATA_WORDS (sizeof(ieee754_8)/sizeof(Eterm)) +#define FLOAT_SIZE_OBJECT (DOUBLE_DATA_WORDS+1) + +/* tuple access methods */ +#define make_tuple(x) make_boxed((x)) +#define is_tuple(x) (is_boxed((x)) && is_arity_value(*boxed_val((x)))) +#define is_not_tuple(x) (!is_tuple((x))) +#define is_tuple_arity(x, a) \ + (is_boxed((x)) && *boxed_val((x)) == make_arityval((a))) +#define is_not_tuple_arity(x, a) (!is_tuple_arity((x),(a))) +#define _unchecked_tuple_val(x) _unchecked_boxed_val(x) +_ET_DECLARE_CHECKED(Eterm*,tuple_val,Eterm); +#define tuple_val(x) _ET_APPLY(tuple_val,(x)) + +#define TUPLE0(t) \ + ((t)[0] = make_arityval(0), \ + make_tuple(t)) +#define TUPLE1(t,e1) \ + ((t)[0] = make_arityval(1), \ + (t)[1] = (e1), \ + make_tuple(t)) +#define TUPLE2(t,e1,e2) \ + ((t)[0] = make_arityval(2), \ + (t)[1] = (e1), \ + (t)[2] = (e2), \ + make_tuple(t)) +#define TUPLE3(t,e1,e2,e3) \ + ((t)[0] = make_arityval(3), \ + (t)[1] = (e1), \ + (t)[2] = (e2), \ + (t)[3] = (e3), \ + make_tuple(t)) +#define TUPLE4(t,e1,e2,e3,e4) \ + ((t)[0] = make_arityval(4), \ + (t)[1] = (e1), \ + (t)[2] = (e2), \ + (t)[3] = (e3), \ + (t)[4] = (e4), \ + make_tuple(t)) +#define TUPLE5(t,e1,e2,e3,e4,e5) \ + ((t)[0] = make_arityval(5), \ + (t)[1] = (e1), \ + (t)[2] = (e2), \ + (t)[3] = (e3), \ + (t)[4] = (e4), \ + (t)[5] = (e5), \ + make_tuple(t)) +#define TUPLE6(t,e1,e2,e3,e4,e5,e6) \ + ((t)[0] = make_arityval(6), \ + (t)[1] = (e1), \ + (t)[2] = (e2), \ + (t)[3] = (e3), \ + (t)[4] = (e4), \ + (t)[5] = (e5), \ + (t)[6] = (e6), \ + make_tuple(t)) + +#define TUPLE7(t,e1,e2,e3,e4,e5,e6,e7) \ + ((t)[0] = make_arityval(7), \ + (t)[1] = (e1), \ + (t)[2] = (e2), \ + (t)[3] = (e3), \ + (t)[4] = (e4), \ + (t)[5] = (e5), \ + (t)[6] = (e6), \ + (t)[7] = (e7), \ + make_tuple(t)) + +#define TUPLE8(t,e1,e2,e3,e4,e5,e6,e7,e8) \ + ((t)[0] = make_arityval(8), \ + (t)[1] = (e1), \ + (t)[2] = (e2), \ + (t)[3] = (e3), \ + (t)[4] = (e4), \ + (t)[5] = (e5), \ + (t)[6] = (e6), \ + (t)[7] = (e7), \ + (t)[8] = (e8), \ + make_tuple(t)) + +/* This macro get Size bits starting at low order position Pos + and adjusts the bits to the right + bits are numbered from 0 - (sizeof(Uint)*8-1) */ + +#define _GETBITS(X,Pos,Size) (((X) >> (Pos)) & ~(~((Uint) 0) << (Size))) + +/* + * Observe! New layout for pids, ports and references in R9 (see also note + * in erl_node_container_utils.h). + */ + + +/* + * Creation in node specific data (pids, ports, refs) + */ + +#define _CRE_SIZE 2 + +/* MAX value for the creation field in pid, port and reference */ +#define MAX_CREATION (1 << _CRE_SIZE) + +/* + * PID layout (internal pids): + * + * |3 3 2 2 2 2 2 2|2 2 2 2 1 1 1 1|1 1 1 1 1 1 | | + * |1 0 9 8 7 6 5 4|3 2 1 0 9 8 7 6|5 4 3 2 1 0 9 8|7 6 5 4 3 2 1 0| + * | | | | | + * +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + * |n n n n n n n n n n n n n n n n n n n n n n n n n n n n|0 0|1 1| + * +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + * + * n : number + * + * Old pid layout: + * + * |3 3 2 2 2 2 2 2|2 2 2 2 1 1 1 1|1 1 1 1 1 1 | | + * |1 0 9 8 7 6 5 4|3 2 1 0 9 8 7 6|5 4 3 2 1 0 9 8|7 6 5 4 3 2 1 0| + * | | | | | + * +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + * |s s s|n n n n n n n n n n n n n n n|N N N N N N N N|c c|0 0|1 1| + * +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + * + * s : serial + * n : number + * c : creation + * N : node number + * + */ + +#define _PID_R9_SER_SIZE 3 +#define _PID_SER_SIZE (_PID_DATA_SIZE - _PID_NUM_SIZE) +#define _PID_NUM_SIZE 15 + +#define _PID_DATA_SIZE 28 +#define _PID_DATA_SHIFT (_TAG_IMMED1_SIZE) + +#define _GET_PID_DATA(X) _GETBITS((X),_PID_DATA_SHIFT,_PID_DATA_SIZE) +#define _GET_PID_NUM(X) _GETBITS((X),0,_PID_NUM_SIZE) +#define _GET_PID_SER(X) _GETBITS((X),_PID_NUM_SIZE,_PID_SER_SIZE) + +#define make_pid_data(Ser, Num) \ + ((Uint) ((Ser) << _PID_NUM_SIZE | (Num))) + +#define make_internal_pid(X) \ + ((Eterm) (((X) << _PID_DATA_SHIFT) | _TAG_IMMED1_PID)) + +#define is_internal_pid(x) (((x) & _TAG_IMMED1_MASK) == _TAG_IMMED1_PID) +#define is_not_internal_pid(x) (!is_internal_pid((x))) + +#define _unchecked_internal_pid_data(x) _GET_PID_DATA((x)) +_ET_DECLARE_CHECKED(Uint,internal_pid_data,Eterm); +#define internal_pid_data(x) _ET_APPLY(internal_pid_data,(x)) + +#define _unchecked_internal_pid_node(x) erts_this_node +_ET_DECLARE_CHECKED(struct erl_node_*,internal_pid_node,Eterm); +#define internal_pid_node(x) _ET_APPLY(internal_pid_node,(x)) + +#define internal_pid_number(x) _GET_PID_NUM(internal_pid_data((x))) +#define internal_pid_serial(x) _GET_PID_SER(internal_pid_data((x))) + +#define internal_pid_data_words(x) (1) + +/* + * PORT layout (internal ports): + * + * |3 3 2 2 2 2 2 2|2 2 2 2 1 1 1 1|1 1 1 1 1 1 | | + * |1 0 9 8 7 6 5 4|3 2 1 0 9 8 7 6|5 4 3 2 1 0 9 8|7 6 5 4 3 2 1 0| + * | | | | | + * +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + * |n n n n n n n n n n n n n n n n n n n n n n n n n n n n|0 1|1 1| + * +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + * + * n : number + * + * Old port layout: + * + * |3 3 2 2 2 2 2 2|2 2 2 2 1 1 1 1|1 1 1 1 1 1 | | + * |1 0 9 8 7 6 5 4|3 2 1 0 9 8 7 6|5 4 3 2 1 0 9 8|7 6 5 4 3 2 1 0| + * | | | | | + * +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + * |N N N N N N N N|n n n n n n n n n n n n n n n n n n|c c|0 1|1 1| + * +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + * + * s : serial + * n : number + * c : creation + * N : node number + * + */ +#define _PORT_R9_NUM_SIZE 18 +#define _PORT_NUM_SIZE _PORT_DATA_SIZE + +#define _PORT_DATA_SIZE 28 +#define _PORT_DATA_SHIFT (_TAG_IMMED1_SIZE) + +#define _GET_PORT_DATA(X) _GETBITS((X),_PORT_DATA_SHIFT,_PORT_DATA_SIZE) +#define _GET_PORT_NUM(X) _GETBITS((X), 0, _PORT_NUM_SIZE) + + +#define make_internal_port(X) \ + ((Eterm) (((X) << _PORT_DATA_SHIFT) | _TAG_IMMED1_PORT)) + +#define is_internal_port(x) (((x) & _TAG_IMMED1_MASK) == _TAG_IMMED1_PORT) +#define is_not_internal_port(x) (!is_internal_port(x)) + +#define _unchecked_internal_port_data(x) _GET_PORT_DATA((x)) +_ET_DECLARE_CHECKED(Uint,internal_port_data,Eterm); +#define internal_port_data(x) _ET_APPLY(internal_port_data,(x)) + +#define internal_port_number(x) _GET_PORT_NUM(internal_port_data((x))) + +#define _unchecked_internal_port_node(x) erts_this_node +_ET_DECLARE_CHECKED(struct erl_node_*,internal_port_node,Eterm); +#define internal_port_node(x) _ET_APPLY(internal_port_node,(x)) + +#define internal_port_data_words(x) (1) +/* + * Ref layout (internal references): + * + * |3 3 2 2 2 2 2 2|2 2 2 2 1 1 1 1|1 1 1 1 1 1 | | + * |1 0 9 8 7 6 5 4|3 2 1 0 9 8 7 6|5 4 3 2 1 0 9 8|7 6 5 4 3 2 1 0| + * | | | | | + * +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + * |0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1|0 1 0 0|0 0| Thing + * +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + * |0 0 0 0 0 0 0 0 0 0 0 0 0 0|r r r r r r r r r r r r r r r r r r| Data 0 + * +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + * |r r r r r r r r r r r r r r r r r r r r r r r r r r r r r r r r| Data 1 + * +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + * |r r r r r r r r r r r r r r r r r r r r r r r r r r r r r r r r| Data 2 + * +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + * + * + * r : reference number + * c : creation + * + * + * Old "heap ref" layout: + * + * + * |3 3 2 2 2 2 2 2|2 2 2 2 1 1 1 1|1 1 1 1 1 1 | | + * |1 0 9 8 7 6 5 4|3 2 1 0 9 8 7 6|5 4 3 2 1 0 9 8|7 6 5 4 3 2 1 0| + * | | | | | + * +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + * |0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1|0 1 0 0|0 0| Thing + * +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + * |N N N N N N N N|0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0|c c|0 1 1 1| Head + * +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + * |0 0 0 0 0 0 0 0 0 0 0 0 0 0|r r r r r r r r r r r r r r r r r r| Word 0 + * +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + * |r r r r r r r r r r r r r r r r r r r r r r r r r r r r r r r r| Word 1 + * +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + * |r r r r r r r r r r r r r r r r r r r r r r r r r r r r r r r r| Word 2 + * +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + * + * r : reference number + * c : creation + * N : node index + * + * Old "one-word ref" layout: + * + * |3 3 2 2 2 2 2 2|2 2 2 2 1 1 1 1|1 1 1 1 1 1 | | + * |1 0 9 8 7 6 5 4|3 2 1 0 9 8 7 6|5 4 3 2 1 0 9 8|7 6 5 4 3 2 1 0| + * | | | | | + * +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + * |N N N N N N N N|r r r r r r r r r r r r r r r r r r|c c|T T T T| + * +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + * + * r : reference number + * c : creation + * N : node index + * + */ +#define _REF_NUM_SIZE 18 + +/* Old maximum number of references in the system */ +#define MAX_REFERENCE (1 << _REF_NUM_SIZE) +#define REF_MASK (~(~((Uint)0) << _REF_NUM_SIZE)) +#define ERTS_MAX_REF_NUMBERS 3 +#define ERTS_REF_NUMBERS ERTS_MAX_REF_NUMBERS + +#ifdef ARCH_64 +# define ERTS_REF_WORDS (ERTS_REF_NUMBERS/2 + 1) +# define ERTS_REF_32BIT_WORDS (ERTS_REF_NUMBERS+1) +#else +# define ERTS_REF_WORDS ERTS_REF_NUMBERS +# define ERTS_REF_32BIT_WORDS ERTS_REF_NUMBERS +#endif + +typedef struct { + Eterm header; + union { + Uint32 ui32[ERTS_REF_32BIT_WORDS]; + Uint ui[ERTS_REF_WORDS]; + } data; +} RefThing; + +#define REF_THING_SIZE (sizeof(RefThing)/sizeof(Uint)) +#define REF_THING_HEAD_SIZE (sizeof(Eterm)/sizeof(Uint)) + +#define make_ref_thing_header(DW) \ + _make_header((DW)+REF_THING_HEAD_SIZE-1,_TAG_HEADER_REF) + +#ifdef ARCH_64 + +/* + * Ref layout on a 64-bit little endian machine: + * + * 63 31 0 + * +--------------+--------------+ + * | Thing word | + * +--------------+--------------+ + * | Data 0 | 32-bit arity | + * +--------------+--------------+ + * | Data 2 | Data 1 | + * +--------------+--------------+ + * + * Data is stored as an Uint32 array with 32-bit arity as first number. + */ + +#define write_ref_thing(Hp, R0, R1, R2) \ +do { \ + ((RefThing *) (Hp))->header = make_ref_thing_header(ERTS_REF_WORDS); \ + ((RefThing *) (Hp))->data.ui32[0] = ERTS_REF_NUMBERS; \ + ((RefThing *) (Hp))->data.ui32[1] = (R0); \ + ((RefThing *) (Hp))->data.ui32[2] = (R1); \ + ((RefThing *) (Hp))->data.ui32[3] = (R2); \ +} while (0) + +#else + +#define write_ref_thing(Hp, R0, R1, R2) \ +do { \ + ((RefThing *) (Hp))->header = make_ref_thing_header(ERTS_REF_WORDS); \ + ((RefThing *) (Hp))->data.ui32[0] = (R0); \ + ((RefThing *) (Hp))->data.ui32[1] = (R1); \ + ((RefThing *) (Hp))->data.ui32[2] = (R2); \ +} while (0) + +#endif + +#define is_ref_thing_header(x) (((x) & _TAG_HEADER_MASK) == _TAG_HEADER_REF) +#define make_internal_ref(x) make_boxed((Eterm*)(x)) + +#define _unchecked_ref_thing_ptr(x) \ + ((RefThing*) _unchecked_internal_ref_val(x)) +#define ref_thing_ptr(x) \ + ((RefThing*) internal_ref_val(x)) + +#define is_internal_ref(x) \ + (_unchecked_is_boxed((x)) && is_ref_thing_header(*boxed_val((x)))) +#define is_not_internal_ref(x) \ + (!is_internal_ref((x))) + +#define _unchecked_internal_ref_val(x) _unchecked_boxed_val((x)) +_ET_DECLARE_CHECKED(Eterm*,internal_ref_val,Eterm); +#define internal_ref_val(x) _ET_APPLY(internal_ref_val,(x)) + +#define _unchecked_internal_ref_data_words(x) \ + (_unchecked_thing_arityval(*_unchecked_internal_ref_val(x))) +_ET_DECLARE_CHECKED(Uint,internal_ref_data_words,Eterm); +#define internal_ref_data_words(x) _ET_APPLY(internal_ref_data_words,(x)) + +#define _unchecked_internal_ref_data(x) (_unchecked_ref_thing_ptr(x)->data.ui32) +_ET_DECLARE_CHECKED(Uint32*,internal_ref_data,Eterm); +#define internal_ref_data(x) _ET_APPLY(internal_ref_data,(x)) + +#define _unchecked_internal_ref_node(x) erts_this_node +_ET_DECLARE_CHECKED(struct erl_node_*,internal_ref_node,Eterm); +#define internal_ref_node(x) _ET_APPLY(internal_ref_node,(x)) + +/* + * + * External thing layout (external pids, ports, and refs): + * + * |3 3 2 2 2 2 2 2|2 2 2 2 1 1 1 1|1 1 1 1 1 1 | | + * |1 0 9 8 7 6 5 4|3 2 1 0 9 8 7 6|5 4 3 2 1 0 9 8|7 6 5 4 3 2 1 0| + * | | | | | + * +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + * |A A A A A A A A A A A A A A A A A A A A A A A A A A|t t t t|0 0| Thing + * +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + * |N N N N N N N N N N N N N N N N N N N N N N N N N N N N N N N N| Next + * +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + * |E E E E E E E E E E E E E E E E E E E E E E E E E E E E E E E E| ErlNode + * +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + * |X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X| Data 0 + * +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + * . . . + * . . . + * . . . + * + * A : Arity + * t : External pid thing tag (1100) + * t : External port thing tag (1101) + * t : External ref thing tag (1110) + * N : Next (external thing) pointer + * E : ErlNode pointer + * X : Type specific data + * + * External pid and port layout: + * External pids and ports only have one data word (Data 0) which has + * the same layout as internal pids resp. internal ports. + * + * External refs layout: + * External refs has the same layout for the data words as in the internal + * ref. + * + */ + +typedef struct external_thing_ { + /* ----+ */ + Eterm header; /* | */ + struct external_thing_ *next; /* > External thing head */ + struct erl_node_ *node; /* | */ + /* ----+ */ + union { + Uint32 ui32[1]; + Uint ui[1]; + } data; +} ExternalThing; + +#define EXTERNAL_THING_HEAD_SIZE (sizeof(ExternalThing)/sizeof(Uint) - 1) + +#define make_external_pid_header(DW) \ + _make_header((DW)+EXTERNAL_THING_HEAD_SIZE-1,_TAG_HEADER_EXTERNAL_PID) +#define is_external_pid_header(x) \ + (((x) & _TAG_HEADER_MASK) == _TAG_HEADER_EXTERNAL_PID) + +#define make_external_port_header(DW) \ + _make_header((DW)+EXTERNAL_THING_HEAD_SIZE-1,_TAG_HEADER_EXTERNAL_PORT) +#define is_external_port_header(x) \ + (((x) & _TAG_HEADER_MASK) == _TAG_HEADER_EXTERNAL_PORT) + +#define make_external_ref_header(DW) \ + _make_header((DW)+EXTERNAL_THING_HEAD_SIZE-1,_TAG_HEADER_EXTERNAL_REF) +#define is_external_ref_header(x) \ + (((x) & _TAG_HEADER_MASK) == _TAG_HEADER_EXTERNAL_REF) + +#define is_external_header(x) \ + (((x) & (_TAG_HEADER_MASK-_BINARY_XXX_MASK)) == _TAG_HEADER_EXTERNAL_PID) + +#define is_external(x) \ + (is_boxed((x)) && is_external_header(*boxed_val((x)))) +#define is_external_pid(x) \ + (is_boxed((x)) && is_external_pid_header(*boxed_val((x)))) +#define is_external_port(x) \ + (is_boxed((x)) && is_external_port_header(*boxed_val((x)))) +#define is_external_ref(x) \ + (_unchecked_is_boxed((x)) && is_external_ref_header(*boxed_val((x)))) + +#define _unchecked_is_external(x) \ + (_unchecked_is_boxed((x)) && is_external_header(*_unchecked_boxed_val((x)))) + +#define is_not_external(x) (!is_external((x))) +#define is_not_external_pid(x) (!is_external_pid((x))) +#define is_not_external_port(x) (!is_external_port((x))) +#define is_not_external_ref(x) (!is_external_ref((x))) + + +#define make_external(x) make_boxed((Eterm *) (x)) + +#define make_external_pid make_external +#define make_external_port make_external +#define make_external_ref make_external + +#define _unchecked_external_val(x) _unchecked_boxed_val((x)) +_ET_DECLARE_CHECKED(Eterm*,external_val,Eterm); +#define external_val(x) _ET_APPLY(external_val,(x)) + +#define external_thing_ptr(x) ((ExternalThing *) external_val((x))) +#define _unchecked_external_thing_ptr(x) \ + ((ExternalThing *) _unchecked_external_val((x))) + +#define _unchecked_external_data_words(x) \ + (_unchecked_thing_arityval(_unchecked_external_thing_ptr((x))->header) \ + + (1 - EXTERNAL_THING_HEAD_SIZE)) +_ET_DECLARE_CHECKED(Uint,external_data_words,Eterm); +#define external_data_words(x) _ET_APPLY(external_data_words,(x)) + +#define _unchecked_external_data(x) (_unchecked_external_thing_ptr((x))->data.ui) +#define _unchecked_external_node(x) (_unchecked_external_thing_ptr((x))->node) + +#define external_data(x) (external_thing_ptr((x))->data.ui) +#define external_node(x) (external_thing_ptr((x))->node) + +#define _unchecked_external_pid_data_words(x) \ + _unchecked_external_data_words((x)) +_ET_DECLARE_CHECKED(Uint,external_pid_data_words,Eterm); +#define external_pid_data_words(x) _ET_APPLY(external_pid_data_words,(x)) + +#define _unchecked_external_pid_data(x) _unchecked_external_data((x))[0] +_ET_DECLARE_CHECKED(Uint,external_pid_data,Eterm); +#define external_pid_data(x) _ET_APPLY(external_pid_data,(x)) + +#define _unchecked_external_pid_node(x) _unchecked_external_node((x)) +_ET_DECLARE_CHECKED(struct erl_node_*,external_pid_node,Eterm); +#define external_pid_node(x) _ET_APPLY(external_pid_node,(x)) + +#define external_pid_number(x) _GET_PID_NUM(external_pid_data((x))) +#define external_pid_serial(x) _GET_PID_SER(external_pid_data((x))) + +#define _unchecked_external_port_data_words(x) \ + _unchecked_external_data_words((x)) +_ET_DECLARE_CHECKED(Uint,external_port_data_words,Eterm); +#define external_port_data_words(x) _ET_APPLY(external_port_data_words,(x)) + +#define _unchecked_external_port_data(x) _unchecked_external_data((x))[0] +_ET_DECLARE_CHECKED(Uint,external_port_data,Eterm); +#define external_port_data(x) _ET_APPLY(external_port_data,(x)) + +#define _unchecked_external_port_node(x) _unchecked_external_node((x)) +_ET_DECLARE_CHECKED(struct erl_node_*,external_port_node,Eterm); +#define external_port_node(x) _ET_APPLY(external_port_node,(x)) + +#define external_port_number(x) _GET_PORT_NUM(external_port_data((x))) + +#define _unchecked_external_ref_data_words(x) \ + _unchecked_external_data_words((x)) +_ET_DECLARE_CHECKED(Uint,external_ref_data_words,Eterm); +#define external_ref_data_words(x) _ET_APPLY(external_ref_data_words,(x)) + +#define _unchecked_external_ref_data(x) (_unchecked_external_thing_ptr((x))->data.ui32) +_ET_DECLARE_CHECKED(Uint32*,external_ref_data,Eterm); +#define external_ref_data(x) _ET_APPLY(external_ref_data,(x)) + +#define _unchecked_external_ref_node(x) _unchecked_external_node((x)) +_ET_DECLARE_CHECKED(struct erl_node_*,external_ref_node,Eterm); +#define external_ref_node(x) _ET_APPLY(external_ref_node,(x)) + +/* number tests */ + +#define is_integer(x) (is_small(x) || is_big(x)) +#define is_not_integer(x) (!is_integer(x)) +#define is_number(x) (is_integer(x) || is_float(x)) + +#define SMALL_MINUS_ONE make_small(-1) +#define SMALL_ZERO make_small(0) +#define SMALL_ONE make_small(1) + +#define ENULL 0 + +/* on some architectures CP contains labels which are not aligned */ +#ifdef NOT_ALIGNED +#error "fix yer arch, like" +#endif + +#define _unchecked_make_cp(x) ((Eterm)(x)) +_ET_DECLARE_CHECKED(Eterm,make_cp,Uint*); +#define make_cp(x) _ET_APPLY(make_cp,(x)) + +#define is_not_CP(x) ((x) & _CPMASK) +#define is_CP(x) (!is_not_CP(x)) + +#define _unchecked_cp_val(x) ((Uint*)(x)) +_ET_DECLARE_CHECKED(Uint*,cp_val,Eterm); +#define cp_val(x) _ET_APPLY(cp_val,(x)) + +#define make_catch(x) (((x) << _TAG_IMMED2_SIZE) | _TAG_IMMED2_CATCH) +#define is_catch(x) (((x) & _TAG_IMMED2_MASK) == _TAG_IMMED2_CATCH) +#define is_not_catch(x) (!is_catch(x)) +#define _unchecked_catch_val(x) ((x) >> _TAG_IMMED2_SIZE) +_ET_DECLARE_CHECKED(Uint,catch_val,Eterm); +#define catch_val(x) _ET_APPLY(catch_val,(x)) + +#define make_blank(X) ((X) = NIL) + +/* + * Overloaded tags. + * + * SMALL = 15 + * ATOM/NIL=7 + * + * Note that the two least significant bits in SMALL/ATOM/NIL always are 3; + * thus, we can distinguish register from literals by looking at only these + * two bits. + */ + +#define X_REG_DEF 0 +#define Y_REG_DEF 1 +#define R_REG_DEF 2 + +#define beam_reg_tag(x) ((x) & 3) + +#define make_rreg() R_REG_DEF +#define make_xreg(ix) (((ix) * sizeof(Eterm)) | X_REG_DEF) +#define make_yreg(ix) (((ix) * sizeof(Eterm)) | Y_REG_DEF) + +#define _is_xreg(x) (beam_reg_tag(x) == X_REG_DEF) +#define _is_yreg(x) (beam_reg_tag(x) == Y_REG_DEF) + +#define _unchecked_x_reg_offset(R) ((R) - X_REG_DEF) +_ET_DECLARE_CHECKED(Uint,x_reg_offset,Uint); +#define x_reg_offset(R) _ET_APPLY(x_reg_offset,(R)) + +#define _unchecked_y_reg_offset(R) ((R) - Y_REG_DEF) +_ET_DECLARE_CHECKED(Uint,y_reg_offset,Uint); +#define y_reg_offset(R) _ET_APPLY(y_reg_offset,(R)) + +#define reg_index(R) ((R) / sizeof(Eterm)) + +#define _unchecked_x_reg_index(R) ((R) >> 2) +_ET_DECLARE_CHECKED(Uint,x_reg_index,Uint); +#define x_reg_index(R) _ET_APPLY(x_reg_index,(R)) + +#define _unchecked_y_reg_index(R) ((R) >> 2) +_ET_DECLARE_CHECKED(Uint,y_reg_index,Uint); +#define y_reg_index(R) _ET_APPLY(y_reg_index,(R)) + +/* + * Backwards compatibility definitions: + * - #define virtal *_DEF constants with values that fit term order: + * number < atom < ref < fun < port < pid < tuple < nil < cons < binary + * - tag_val_def() function generates virtual _DEF tag + * - not_eq_tags() and NUMBER_CODE() defined in terms + * of the tag_val_def() function + */ + +#define BINARY_DEF 0x0 +#define LIST_DEF 0x1 +#define NIL_DEF 0x2 +#define TUPLE_DEF 0x3 +#define PID_DEF 0x4 +#define EXTERNAL_PID_DEF 0x5 +#define PORT_DEF 0x6 +#define EXTERNAL_PORT_DEF 0x7 +#define EXPORT_DEF 0x8 +#define FUN_DEF 0x9 +#define REF_DEF 0xa +#define EXTERNAL_REF_DEF 0xb +#define ATOM_DEF 0xc +#define FLOAT_DEF 0xd +#define BIG_DEF 0xe +#define SMALL_DEF 0xf + +#if ET_DEBUG +extern unsigned tag_val_def_debug(Eterm, const char*, unsigned); +#define tag_val_def(x) tag_val_def_debug((x),__FILE__,__LINE__) +#else +extern unsigned tag_val_def(Eterm); +#endif +#define not_eq_tags(X,Y) (tag_val_def((X)) ^ tag_val_def((Y))) + +#define NUMBER_CODE(x,y) ((tag_val_def(x) << 4) | tag_val_def(y)) +#define _NUMBER_CODE(TX,TY) ((TX << 4) | TY) +#define SMALL_SMALL _NUMBER_CODE(SMALL_DEF,SMALL_DEF) +#define SMALL_BIG _NUMBER_CODE(SMALL_DEF,BIG_DEF) +#define SMALL_FLOAT _NUMBER_CODE(SMALL_DEF,FLOAT_DEF) +#define BIG_SMALL _NUMBER_CODE(BIG_DEF,SMALL_DEF) +#define BIG_BIG _NUMBER_CODE(BIG_DEF,BIG_DEF) +#define BIG_FLOAT _NUMBER_CODE(BIG_DEF,FLOAT_DEF) +#define FLOAT_SMALL _NUMBER_CODE(FLOAT_DEF,SMALL_DEF) +#define FLOAT_BIG _NUMBER_CODE(FLOAT_DEF,BIG_DEF) +#define FLOAT_FLOAT _NUMBER_CODE(FLOAT_DEF,FLOAT_DEF) + +#endif /* __ERL_TERM_H */ + diff --git a/erts/emulator/beam/erl_threads.h b/erts/emulator/beam/erl_threads.h new file mode 100644 index 0000000000..d635916dd8 --- /dev/null +++ b/erts/emulator/beam/erl_threads.h @@ -0,0 +1,1524 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2001-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* Description: Error checking thread interface to the ethread library. + * All functions terminates the emulator on failure. + * Author: Rickard Green + */ + +#ifndef ERL_THREAD_H__ +#define ERL_THREAD_H__ + +#include "sys.h" +#ifdef USE_THREADS + +#define ETHR_TRY_INLINE_FUNCS +#include "ethread.h" +#include "erl_lock_check.h" +#include "erl_lock_count.h" +#include "erl_term.h" + +#ifdef ERTS_ENABLE_LOCK_COUNT +#define erts_mtx_lock(L) erts_mtx_lock_x(L, __FILE__, __LINE__) +#define erts_spin_lock(L) erts_spin_lock_x(L, __FILE__, __LINE__) +#define erts_rwmtx_rlock(L) erts_rwmtx_rlock_x(L, __FILE__, __LINE__) +#define erts_rwmtx_rwlock(L) erts_rwmtx_rwlock_x(L, __FILE__, __LINE__) +#define erts_read_lock(L) erts_read_lock_x(L, __FILE__, __LINE__) +#define erts_write_lock(L) erts_write_lock_x(L, __FILE__, __LINE__) +#endif + +#define ERTS_THR_OPTS_DEFAULT_INITER ETHR_THR_OPTS_DEFAULT_INITER +typedef ethr_thr_opts erts_thr_opts_t; +typedef ethr_init_data erts_thr_init_data_t; +typedef ethr_tid erts_tid_t; + +/* mutex */ +typedef struct { + ethr_mutex mtx; +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_lock_t lc; +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_lock_t lcnt; +#endif + +} erts_mtx_t; +typedef ethr_cond erts_cnd_t; + +/* rwmutex */ +typedef struct { + ethr_rwmutex rwmtx; +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_lock_t lc; +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_lock_t lcnt; +#endif +} erts_rwmtx_t; +typedef ethr_tsd_key erts_tsd_key_t; +typedef ethr_gate erts_gate_t; +typedef ethr_atomic_t erts_atomic_t; + +/* spinlock */ +typedef struct { + ethr_spinlock_t slck; +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_lock_t lc; +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_lock_t lcnt; +#endif +} erts_spinlock_t; + +/* rwlock */ +typedef struct { + ethr_rwlock_t rwlck; +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_lock_t lc; +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_lock_t lcnt; +#endif +} erts_rwlock_t; + +typedef ethr_timeval erts_thr_timeval_t; +__decl_noreturn void __noreturn erts_thr_fatal_error(int, char *); + /* implemented in erl_init.c */ + +#ifdef ERTS_ENABLE_LOCK_CHECK +#define ERTS_REC_MTX_INITER \ + {ETHR_REC_MUTEX_INITER, \ + ERTS_LC_LOCK_INIT(-1,THE_NON_VALUE,ERTS_LC_FLG_LT_MUTEX)} +#define ERTS_MTX_INITER \ + {ETHR_MUTEX_INITER, \ + ERTS_LC_LOCK_INIT(-1, THE_NON_VALUE, ERTS_LC_FLG_LT_MUTEX)} +#else +#define ERTS_REC_MTX_INITER {ETHR_REC_MUTEX_INITER} +#define ERTS_MTX_INITER {ETHR_MUTEX_INITER} +#endif +#define ERTS_CND_INITER ETHR_COND_INITER +#define ERTS_THR_INIT_DATA_DEF_INITER ETHR_INIT_DATA_DEFAULT_INITER + +#ifdef ETHR_HAVE_ETHR_REC_MUTEX_INIT +# define ERTS_HAVE_REC_MTX_INIT ETHR_HAVE_ETHR_REC_MUTEX_INIT +#endif + + +#else /* #ifdef USE_THREADS */ + +#define ERTS_THR_OPTS_DEFAULT_INITER 0 +typedef int erts_thr_opts_t; +typedef int erts_thr_init_data_t; +typedef int erts_tid_t; +typedef int erts_mtx_t; +typedef int erts_cnd_t; +typedef int erts_rwmtx_t; +typedef int erts_tsd_key_t; +typedef int erts_gate_t; +typedef long erts_atomic_t; +#if __GNUC__ > 2 +typedef struct { } erts_spinlock_t; +typedef struct { } erts_rwlock_t; +#else +typedef struct { int gcc_is_buggy; } erts_spinlock_t; +typedef struct { int gcc_is_buggy; } erts_rwlock_t; +#endif +typedef struct { + long tv_sec; + long tv_nsec; +} erts_thr_timeval_t; + +#define ERTS_REC_MTX_INITER 0 +#define ERTS_MTX_INITER 0 +#define ERTS_CND_INITER 0 +#define ERTS_THR_INIT_DATA_DEF_INITER 0 + +#define ERTS_HAVE_REC_MTX_INIT 1 + +#endif /* #ifdef USE_THREADS */ + +ERTS_GLB_INLINE void erts_thr_init(erts_thr_init_data_t *id); +ERTS_GLB_INLINE void erts_thr_create(erts_tid_t *tid, void * (*func)(void *), + void *arg, erts_thr_opts_t *opts); +ERTS_GLB_INLINE void erts_thr_join(erts_tid_t tid, void **thr_res); +ERTS_GLB_INLINE void erts_thr_detach(erts_tid_t tid); +ERTS_GLB_INLINE void erts_thr_exit(void *res); +ERTS_GLB_INLINE void erts_thr_install_exit_handler(void (*exit_handler)(void)); +ERTS_GLB_INLINE erts_tid_t erts_thr_self(void); +ERTS_GLB_INLINE int erts_equal_tids(erts_tid_t x, erts_tid_t y); +#ifdef ERTS_HAVE_REC_MTX_INIT +ERTS_GLB_INLINE void erts_rec_mtx_init(erts_mtx_t *mtx); +#endif +ERTS_GLB_INLINE void erts_mtx_init_x(erts_mtx_t *mtx, char *name, Eterm extra); +ERTS_GLB_INLINE void erts_mtx_init_x_opt(erts_mtx_t *mtx, char *name, Eterm extra, Uint16 opt); +ERTS_GLB_INLINE void erts_mtx_init_locked_x(erts_mtx_t *mtx, + char *name, + Eterm extra); +ERTS_GLB_INLINE void erts_mtx_init(erts_mtx_t *mtx, char *name); +ERTS_GLB_INLINE void erts_mtx_init_locked(erts_mtx_t *mtx, char *name); +ERTS_GLB_INLINE void erts_mtx_destroy(erts_mtx_t *mtx); +ERTS_GLB_INLINE void erts_mtx_set_forksafe(erts_mtx_t *mtx); +ERTS_GLB_INLINE void erts_mtx_unset_forksafe(erts_mtx_t *mtx); +ERTS_GLB_INLINE int erts_mtx_trylock(erts_mtx_t *mtx); +#ifdef ERTS_ENABLE_LOCK_COUNT +ERTS_GLB_INLINE void erts_mtx_lock_x(erts_mtx_t *mtx, char *file, unsigned int line); +#else +ERTS_GLB_INLINE void erts_mtx_lock(erts_mtx_t *mtx); +#endif +ERTS_GLB_INLINE void erts_mtx_unlock(erts_mtx_t *mtx); +ERTS_GLB_INLINE int erts_lc_mtx_is_locked(erts_mtx_t *mtx); +ERTS_GLB_INLINE void erts_cnd_init(erts_cnd_t *cnd); +ERTS_GLB_INLINE void erts_cnd_destroy(erts_cnd_t *cnd); +ERTS_GLB_INLINE void erts_cnd_wait(erts_cnd_t *cnd, erts_mtx_t *mtx); +ERTS_GLB_INLINE void erts_cnd_signal(erts_cnd_t *cnd); +ERTS_GLB_INLINE void erts_cnd_broadcast(erts_cnd_t *cnd); +ERTS_GLB_INLINE void erts_rwmtx_init_x(erts_rwmtx_t *rwmtx, + char *name, + Eterm extra); +ERTS_GLB_INLINE void erts_rwmtx_init(erts_rwmtx_t *rwmtx, + char *name); +ERTS_GLB_INLINE void erts_rwmtx_destroy(erts_rwmtx_t *rwmtx); +ERTS_GLB_INLINE int erts_rwmtx_tryrlock(erts_rwmtx_t *rwmtx); +#ifdef ERTS_ENABLE_LOCK_COUNT +ERTS_GLB_INLINE void erts_rwmtx_rlock_x(erts_rwmtx_t *rwmtx, char *file, unsigned int line); +ERTS_GLB_INLINE void erts_rwmtx_rwlock_x(erts_rwmtx_t *rwmtx, char *file, unsigned int line); +#else +ERTS_GLB_INLINE void erts_rwmtx_rlock(erts_rwmtx_t *rwmtx); +ERTS_GLB_INLINE void erts_rwmtx_rwlock(erts_rwmtx_t *rwmtx); +#endif +ERTS_GLB_INLINE void erts_rwmtx_runlock(erts_rwmtx_t *rwmtx); +ERTS_GLB_INLINE int erts_rwmtx_tryrwlock(erts_rwmtx_t *rwmtx); +ERTS_GLB_INLINE void erts_rwmtx_rwunlock(erts_rwmtx_t *rwmtx); +ERTS_GLB_INLINE int erts_lc_rwmtx_is_rlocked(erts_rwmtx_t *mtx); +ERTS_GLB_INLINE int erts_lc_rwmtx_is_rwlocked(erts_rwmtx_t *mtx); +ERTS_GLB_INLINE void erts_atomic_init(erts_atomic_t *var, long i); +ERTS_GLB_INLINE void erts_atomic_set(erts_atomic_t *var, long i); +ERTS_GLB_INLINE long erts_atomic_read(erts_atomic_t *var); +ERTS_GLB_INLINE long erts_atomic_inctest(erts_atomic_t *incp); +ERTS_GLB_INLINE long erts_atomic_dectest(erts_atomic_t *decp); +ERTS_GLB_INLINE void erts_atomic_inc(erts_atomic_t *incp); +ERTS_GLB_INLINE void erts_atomic_dec(erts_atomic_t *decp); +ERTS_GLB_INLINE long erts_atomic_addtest(erts_atomic_t *addp, + long i); +ERTS_GLB_INLINE void erts_atomic_add(erts_atomic_t *addp, long i); +ERTS_GLB_INLINE long erts_atomic_xchg(erts_atomic_t *xchgp, + long new); +ERTS_GLB_INLINE long erts_atomic_cmpxchg(erts_atomic_t *xchgp, + long new, + long expected); +ERTS_GLB_INLINE long erts_atomic_bor(erts_atomic_t *var, long mask); +ERTS_GLB_INLINE long erts_atomic_band(erts_atomic_t *var, long mask); +ERTS_GLB_INLINE void erts_spinlock_init_x(erts_spinlock_t *lock, + char *name, + Eterm extra); +ERTS_GLB_INLINE void erts_spinlock_init(erts_spinlock_t *lock, + char *name); +ERTS_GLB_INLINE void erts_spinlock_destroy(erts_spinlock_t *lock); +ERTS_GLB_INLINE void erts_spin_unlock(erts_spinlock_t *lock); +#ifdef ERTS_ENABLE_LOCK_COUNT +ERTS_GLB_INLINE void erts_spin_lock_x(erts_spinlock_t *lock, char *file, unsigned int line); +#else +ERTS_GLB_INLINE void erts_spin_lock(erts_spinlock_t *lock); +#endif +ERTS_GLB_INLINE int erts_lc_spinlock_is_locked(erts_spinlock_t *lock); +ERTS_GLB_INLINE void erts_rwlock_init_x(erts_rwlock_t *lock, + char *name, + Eterm extra); +ERTS_GLB_INLINE void erts_rwlock_init(erts_rwlock_t *lock, + char *name); +ERTS_GLB_INLINE void erts_rwlock_destroy(erts_rwlock_t *lock); +ERTS_GLB_INLINE void erts_read_unlock(erts_rwlock_t *lock); +#ifdef ERTS_ENABLE_LOCK_COUNT +ERTS_GLB_INLINE void erts_read_lock_x(erts_rwlock_t *lock, char *file, unsigned int line); +ERTS_GLB_INLINE void erts_write_lock_x(erts_rwlock_t *lock, char *file, unsigned int line); +#else +ERTS_GLB_INLINE void erts_read_lock(erts_rwlock_t *lock); +ERTS_GLB_INLINE void erts_write_lock(erts_rwlock_t *lock); +#endif +ERTS_GLB_INLINE void erts_write_unlock(erts_rwlock_t *lock); +ERTS_GLB_INLINE int erts_lc_rwlock_is_rlocked(erts_rwlock_t *lock); +ERTS_GLB_INLINE int erts_lc_rwlock_is_rwlocked(erts_rwlock_t *lock); +ERTS_GLB_INLINE void erts_thr_time_now(erts_thr_timeval_t *time); +ERTS_GLB_INLINE void erts_tsd_key_create(erts_tsd_key_t *keyp); +ERTS_GLB_INLINE void erts_tsd_key_delete(erts_tsd_key_t key); +ERTS_GLB_INLINE void erts_tsd_set(erts_tsd_key_t key, void *value); +ERTS_GLB_INLINE void * erts_tsd_get(erts_tsd_key_t key); +ERTS_GLB_INLINE void erts_gate_init(erts_gate_t *gp); +ERTS_GLB_INLINE void erts_gate_destroy(erts_gate_t *gp); +ERTS_GLB_INLINE void erts_gate_close(erts_gate_t *gp); +ERTS_GLB_INLINE void erts_gate_let_through(erts_gate_t *gp, unsigned no); +ERTS_GLB_INLINE void erts_gate_wait(erts_gate_t *gp); +ERTS_GLB_INLINE void erts_gate_swait(erts_gate_t *gp, int spincount); + +#ifdef ETHR_HAVE_ETHR_SIG_FUNCS +#define ERTS_THR_HAVE_SIG_FUNCS 1 +ERTS_GLB_INLINE void erts_thr_sigmask(int how, const sigset_t *set, + sigset_t *oset); +ERTS_GLB_INLINE void erts_thr_sigwait(const sigset_t *set, int *sig); +#endif /* #ifdef HAVE_ETHR_SIG_FUNCS */ + +#if ERTS_GLB_INLINE_INCL_FUNC_DEF + +ERTS_GLB_INLINE void +erts_thr_init(erts_thr_init_data_t *id) +{ +#ifdef USE_THREADS + int res = ethr_init(id); + if (res) + erts_thr_fatal_error(res, "initialize thread library"); +#endif +} + +ERTS_GLB_INLINE void +erts_thr_create(erts_tid_t *tid, void * (*func)(void *), void *arg, + erts_thr_opts_t *opts) +{ +#ifdef USE_THREADS +#ifdef ERTS_ENABLE_LOCK_COUNT + int res = erts_lcnt_thr_create(tid, func, arg, opts); +#else + int res = ethr_thr_create(tid, func, arg, opts); +#endif + if (res) + erts_thr_fatal_error(res, "create thread"); +#endif +} + +ERTS_GLB_INLINE void +erts_thr_join(erts_tid_t tid, void **thr_res) +{ +#ifdef USE_THREADS + int res = ethr_thr_join(tid, thr_res); + if (res) + erts_thr_fatal_error(res, "join thread"); +#endif +} + + +ERTS_GLB_INLINE void +erts_thr_detach(erts_tid_t tid) +{ +#ifdef USE_THREADS + int res = ethr_thr_detach(tid); + if (res) + erts_thr_fatal_error(res, "detach thread"); +#endif +} + + +ERTS_GLB_INLINE void +erts_thr_exit(void *res) +{ +#ifdef USE_THREADS + ethr_thr_exit(res); + erts_thr_fatal_error(0, "terminate thread"); +#endif +} + +ERTS_GLB_INLINE void +erts_thr_install_exit_handler(void (*exit_handler)(void)) +{ +#ifdef USE_THREADS + int res = ethr_install_exit_handler(exit_handler); + if (res != 0) + erts_thr_fatal_error(res, "install thread exit handler"); +#endif +} + +ERTS_GLB_INLINE erts_tid_t +erts_thr_self(void) +{ +#ifdef USE_THREADS + return ethr_self(); +#else + return 0; +#endif +} + + +ERTS_GLB_INLINE int +erts_equal_tids(erts_tid_t x, erts_tid_t y) +{ +#ifdef USE_THREADS + return ethr_equal_tids(x, y); +#else + return 1; +#endif +} + + +#ifdef ERTS_HAVE_REC_MTX_INIT +ERTS_GLB_INLINE void +erts_rec_mtx_init(erts_mtx_t *mtx) +{ +#ifdef USE_THREADS + int res = ethr_rec_mutex_init(&mtx->mtx); + if (res) + erts_thr_fatal_error(res, "initialize recursive mutex"); +#endif +} +#endif + + +ERTS_GLB_INLINE void +erts_mtx_init_x(erts_mtx_t *mtx, char *name, Eterm extra) +{ +#ifdef USE_THREADS + int res = ethr_mutex_init(&mtx->mtx); + if (res) + erts_thr_fatal_error(res, "initialize mutex"); +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_init_lock_x(&mtx->lc, name, ERTS_LC_FLG_LT_MUTEX, extra); +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_init_lock_x(&mtx->lcnt, name, ERTS_LCNT_LT_MUTEX, extra); +#endif +#endif +} + +ERTS_GLB_INLINE void +erts_mtx_init_x_opt(erts_mtx_t *mtx, char *name, Eterm extra, Uint16 opt) +{ +#ifdef USE_THREADS + int res = ethr_mutex_init(&mtx->mtx); + if (res) + erts_thr_fatal_error(res, "initialize mutex"); +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_init_lock_x(&mtx->lc, name, ERTS_LC_FLG_LT_MUTEX, extra); +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_init_lock_x(&mtx->lcnt, name, ERTS_LCNT_LT_MUTEX | opt, extra); +#endif +#endif +} + + +ERTS_GLB_INLINE void +erts_mtx_init_locked_x(erts_mtx_t *mtx, char *name, Eterm extra) +{ +#ifdef USE_THREADS + int res = ethr_mutex_init(&mtx->mtx); + if (res) + erts_thr_fatal_error(res, "initialize mutex"); +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_init_lock_x(&mtx->lc, name, ERTS_LC_FLG_LT_MUTEX, extra); +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_init_lock_x(&mtx->lcnt, name, ERTS_LCNT_LT_MUTEX, extra); +#endif + res = ethr_mutex_lock(&mtx->mtx); + if (res) + erts_thr_fatal_error(res, "lock mutex"); +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_trylock(1, &mtx->lc); +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_trylock(&mtx->lcnt, 1); +#endif +#endif +} + +ERTS_GLB_INLINE void +erts_mtx_init(erts_mtx_t *mtx, char *name) +{ +#ifdef USE_THREADS + int res = ethr_mutex_init(&mtx->mtx); + if (res) + erts_thr_fatal_error(res, "initialize mutex"); +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_init_lock(&mtx->lc, name, ERTS_LC_FLG_LT_MUTEX); +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_init_lock(&mtx->lcnt, name, ERTS_LCNT_LT_MUTEX); +#endif +#endif +} + +ERTS_GLB_INLINE void +erts_mtx_init_locked(erts_mtx_t *mtx, char *name) +{ +#ifdef USE_THREADS + int res = ethr_mutex_init(&mtx->mtx); + if (res) + erts_thr_fatal_error(res, "initialize mutex"); +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_init_lock(&mtx->lc, name, ERTS_LC_FLG_LT_MUTEX); +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_init_lock(&mtx->lcnt, name, ERTS_LCNT_LT_MUTEX); +#endif + res = ethr_mutex_lock(&mtx->mtx); + if (res) + erts_thr_fatal_error(res, "lock mutex"); +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_trylock(1, &mtx->lc); +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_trylock(&mtx->lcnt, 1); +#endif +#endif +} + +ERTS_GLB_INLINE void +erts_mtx_destroy(erts_mtx_t *mtx) +{ +#ifdef USE_THREADS + int res; +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_destroy_lock(&mtx->lc); +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_destroy_lock(&mtx->lcnt); +#endif + res = ethr_mutex_destroy(&mtx->mtx); + if (res) + erts_thr_fatal_error(res, "destroy mutex"); +#endif +} + +ERTS_GLB_INLINE void +erts_mtx_set_forksafe(erts_mtx_t *mtx) +{ +#ifdef USE_THREADS + int res = ethr_mutex_set_forksafe(&mtx->mtx); + if (res != 0 && res != ENOTSUP) + erts_thr_fatal_error(res, "set mutex forksafe"); +#endif +} + +ERTS_GLB_INLINE void +erts_mtx_unset_forksafe(erts_mtx_t *mtx) +{ +#ifdef USE_THREADS + int res = ethr_mutex_unset_forksafe(&mtx->mtx); + if (res != 0 && res != ENOTSUP) + erts_thr_fatal_error(res, "unset mutex forksafe"); +#endif +} + +ERTS_GLB_INLINE int +erts_mtx_trylock(erts_mtx_t *mtx) +{ +#ifdef USE_THREADS + int res; + +#ifdef ERTS_ENABLE_LOCK_CHECK + if (erts_lc_trylock_force_busy(&mtx->lc)) + return EBUSY; /* Make sure caller can handle the situation without + causing a lock order violation */ +#endif + + res = ethr_mutex_trylock(&mtx->mtx); + +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_trylock(res == 0, &mtx->lc); +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_trylock(&mtx->lcnt, res); +#endif + + if (res != 0 && res != EBUSY) + erts_thr_fatal_error(res, "try lock mutex"); + + return res; +#else + return 0; +#endif + +} + +ERTS_GLB_INLINE void +#ifdef ERTS_ENABLE_LOCK_COUNT +erts_mtx_lock_x(erts_mtx_t *mtx, char *file, unsigned int line) +#else +erts_mtx_lock(erts_mtx_t *mtx) +#endif +{ +#ifdef USE_THREADS + int res; +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_lock(&mtx->lc); +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_lock(&mtx->lcnt); +#endif + res = ethr_mutex_lock(&mtx->mtx); +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_lock_post_x(&mtx->lcnt, file, line); +#endif + if (res) + erts_thr_fatal_error(res, "lock mutex"); +#endif +} + +ERTS_GLB_INLINE void +erts_mtx_unlock(erts_mtx_t *mtx) +{ +#ifdef USE_THREADS + int res; +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_unlock(&mtx->lc); +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_unlock(&mtx->lcnt); +#endif + res = ethr_mutex_unlock(&mtx->mtx); + if (res) + erts_thr_fatal_error(res, "unlock mutex"); +#endif +} + +ERTS_GLB_INLINE int +erts_lc_mtx_is_locked(erts_mtx_t *mtx) +{ +#if defined(USE_THREADS) && defined(ERTS_ENABLE_LOCK_CHECK) + int res; + erts_lc_lock_t lc = mtx->lc; + lc.flags = 0; + erts_lc_have_locks(&res, &lc, 1); + return res; +#else + return 0; +#endif +} + +ERTS_GLB_INLINE void +erts_cnd_init(erts_cnd_t *cnd) +{ +#ifdef USE_THREADS + int res = ethr_cond_init(cnd); + if (res) + erts_thr_fatal_error(res, "initialize condition variable"); +#endif +} + +ERTS_GLB_INLINE void +erts_cnd_destroy(erts_cnd_t *cnd) +{ +#ifdef USE_THREADS + int res = ethr_cond_destroy(cnd); + if (res) + erts_thr_fatal_error(res, "destroy condition variable"); +#endif +} + +ERTS_GLB_INLINE void +erts_cnd_wait(erts_cnd_t *cnd, erts_mtx_t *mtx) +{ +#ifdef USE_THREADS + int res; +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_unlock(&mtx->lc); +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_unlock(&mtx->lcnt); +#endif + res = ethr_cond_wait(cnd, &mtx->mtx); +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_lock(&mtx->lc); +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_lock(&mtx->lcnt); +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_lock_post(&mtx->lcnt); +#endif + if (res != 0 && res != EINTR) + erts_thr_fatal_error(res, "wait on condition variable"); +#endif +} + +ERTS_GLB_INLINE void +erts_cnd_signal(erts_cnd_t *cnd) +{ +#ifdef USE_THREADS + int res = ethr_cond_signal(cnd); + if (res) + erts_thr_fatal_error(res, "signal on condition variable"); +#endif +} + + +ERTS_GLB_INLINE void +erts_cnd_broadcast(erts_cnd_t *cnd) +{ +#ifdef USE_THREADS + int res = ethr_cond_broadcast(cnd); + if (res) + erts_thr_fatal_error(res, "broadcast on condition variable"); +#endif +} + +/* rwmutex */ + +ERTS_GLB_INLINE void +erts_rwmtx_init_x(erts_rwmtx_t *rwmtx, char *name, Eterm extra) +{ +#ifdef USE_THREADS + int res = ethr_rwmutex_init(&rwmtx->rwmtx); + if (res != 0) + erts_thr_fatal_error(res, "initialize rwmutex"); +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_init_lock_x(&rwmtx->lc, name, ERTS_LC_FLG_LT_RWMUTEX, extra); +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_init_lock_x(&rwmtx->lcnt, name, ERTS_LCNT_LT_RWMUTEX, extra); +#endif +#endif +} + +ERTS_GLB_INLINE void +erts_rwmtx_init(erts_rwmtx_t *rwmtx, char *name) +{ +#ifdef USE_THREADS + int res = ethr_rwmutex_init(&rwmtx->rwmtx); + if (res != 0) + erts_thr_fatal_error(res, "initialize rwmutex"); +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_init_lock(&rwmtx->lc, name, ERTS_LC_FLG_LT_RWMUTEX); +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_init_lock(&rwmtx->lcnt, name, ERTS_LCNT_LT_RWMUTEX); +#endif +#endif +} + +ERTS_GLB_INLINE void +erts_rwmtx_destroy(erts_rwmtx_t *rwmtx) +{ +#ifdef USE_THREADS + int res; +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_destroy_lock(&rwmtx->lc); +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_destroy_lock(&rwmtx->lcnt); +#endif + res = ethr_rwmutex_destroy(&rwmtx->rwmtx); + if (res != 0) + erts_thr_fatal_error(res, "destroy rwmutex"); +#endif +} + +ERTS_GLB_INLINE int +erts_rwmtx_tryrlock(erts_rwmtx_t *rwmtx) +{ +#ifdef USE_THREADS + int res; + +#ifdef ERTS_ENABLE_LOCK_CHECK + if (erts_lc_trylock_force_busy_flg(&rwmtx->lc, ERTS_LC_FLG_LO_READ)) + return EBUSY; /* Make sure caller can handle the situation without + causing a lock order violation */ +#endif + + res = ethr_rwmutex_tryrlock(&rwmtx->rwmtx); + +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_trylock_flg(res == 0, &rwmtx->lc, ERTS_LC_FLG_LO_READ); +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_trylock_opt(&rwmtx->lcnt, res, ERTS_LCNT_LO_READ); +#endif + + if (res != 0 && res != EBUSY) + erts_thr_fatal_error(res, "try read lock rwmutex"); + + return res; +#else + return 0; +#endif +} + +ERTS_GLB_INLINE void +#ifdef ERTS_ENABLE_LOCK_COUNT +erts_rwmtx_rlock_x(erts_rwmtx_t *rwmtx, char *file, unsigned int line) +#else +erts_rwmtx_rlock(erts_rwmtx_t *rwmtx) +#endif +{ +#ifdef USE_THREADS + int res; +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_lock_flg(&rwmtx->lc, ERTS_LC_FLG_LO_READ); +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_lock_opt(&rwmtx->lcnt, ERTS_LCNT_LO_READ); +#endif + res = ethr_rwmutex_rlock(&rwmtx->rwmtx); +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_lock_post_x(&rwmtx->lcnt, file, line); +#endif + if (res != 0) + erts_thr_fatal_error(res, "read lock rwmutex"); +#endif +} + +ERTS_GLB_INLINE void +erts_rwmtx_runlock(erts_rwmtx_t *rwmtx) +{ +#ifdef USE_THREADS + int res; +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_unlock_flg(&rwmtx->lc, ERTS_LC_FLG_LO_READ); +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_unlock_opt(&rwmtx->lcnt, ERTS_LCNT_LO_READ); +#endif + res = ethr_rwmutex_runlock(&rwmtx->rwmtx); + if (res != 0) + erts_thr_fatal_error(res, "read unlock rwmutex"); +#endif +} + + +ERTS_GLB_INLINE int +erts_rwmtx_tryrwlock(erts_rwmtx_t *rwmtx) +{ +#ifdef USE_THREADS + int res; + +#ifdef ERTS_ENABLE_LOCK_CHECK + if (erts_lc_trylock_force_busy_flg(&rwmtx->lc, ERTS_LC_FLG_LO_READ_WRITE)) + return EBUSY; /* Make sure caller can handle the situation without + causing a lock order violation */ +#endif + + res = ethr_rwmutex_tryrwlock(&rwmtx->rwmtx); + +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_trylock_flg(res == 0, &rwmtx->lc, ERTS_LC_FLG_LO_READ_WRITE); +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_trylock_opt(&rwmtx->lcnt, res, ERTS_LCNT_LO_READ_WRITE); +#endif + + if (res != 0 && res != EBUSY) + erts_thr_fatal_error(res, "try write lock rwmutex"); + + return res; +#else + return 0; +#endif +} + +ERTS_GLB_INLINE void +#ifdef ERTS_ENABLE_LOCK_COUNT +erts_rwmtx_rwlock_x(erts_rwmtx_t *rwmtx, char *file, unsigned int line) +#else +erts_rwmtx_rwlock(erts_rwmtx_t *rwmtx) +#endif +{ +#ifdef USE_THREADS + int res; +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_lock_flg(&rwmtx->lc, ERTS_LC_FLG_LO_READ_WRITE); +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_lock_opt(&rwmtx->lcnt, ERTS_LCNT_LO_READ_WRITE); +#endif + res = ethr_rwmutex_rwlock(&rwmtx->rwmtx); +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_lock_post_x(&rwmtx->lcnt, file, line); +#endif + if (res != 0) + erts_thr_fatal_error(res, "write lock rwmutex"); +#endif +} + +ERTS_GLB_INLINE void +erts_rwmtx_rwunlock(erts_rwmtx_t *rwmtx) +{ +#ifdef USE_THREADS + int res; +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_unlock_flg(&rwmtx->lc, ERTS_LC_FLG_LO_READ_WRITE); +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_unlock_opt(&rwmtx->lcnt, ERTS_LCNT_LO_READ_WRITE); +#endif + res = ethr_rwmutex_rwunlock(&rwmtx->rwmtx); + if (res != 0) + erts_thr_fatal_error(res, "write unlock rwmutex"); +#endif +} + +#if 0 /* The following rwmtx function names are + reserved for potential future use. */ + +/* Try upgrade from r-locked state to rw-locked state */ +ERTS_GLB_INLINE int +erts_rwmtx_trywlock(erts_rwmtx_t *rwmtx) +{ + return 0; +} + +/* Upgrade from r-locked state to rw-locked state */ +ERTS_GLB_INLINE void +erts_rwmtx_wlock(erts_rwmtx_t *rwmtx) +{ + +} + +/* Downgrade from rw-locked state to r-locked state */ +ERTS_GLB_INLINE void +erts_rwmtx_wunlock(erts_rwmtx_t *rwmtx) +{ + +} + +#endif + +ERTS_GLB_INLINE int +erts_lc_rwmtx_is_rlocked(erts_rwmtx_t *mtx) +{ +#if defined(USE_THREADS) && defined(ERTS_ENABLE_LOCK_CHECK) + int res; + erts_lc_lock_t lc = mtx->lc; + lc.flags = ERTS_LC_FLG_LO_READ; + erts_lc_have_locks(&res, &lc, 1); + return res; +#else + return 0; +#endif +} + +ERTS_GLB_INLINE int +erts_lc_rwmtx_is_rwlocked(erts_rwmtx_t *mtx) +{ +#if defined(USE_THREADS) && defined(ERTS_ENABLE_LOCK_CHECK) + int res; + erts_lc_lock_t lc = mtx->lc; + lc.flags = ERTS_LC_FLG_LO_READ|ERTS_LC_FLG_LO_WRITE; + erts_lc_have_locks(&res, &lc, 1); + return res; +#else + return 0; +#endif +} + +ERTS_GLB_INLINE void +erts_atomic_init(erts_atomic_t *var, long i) +{ +#ifdef USE_THREADS + int res = ethr_atomic_init(var, i); + if (res) + erts_thr_fatal_error(res, "perform atomic init"); +#else + *var = i; +#endif +} + +ERTS_GLB_INLINE void +erts_atomic_set(erts_atomic_t *var, long i) +{ +#ifdef USE_THREADS + int res = ethr_atomic_set(var, i); + if (res) + erts_thr_fatal_error(res, "perform atomic set"); +#else + *var = i; +#endif +} + +ERTS_GLB_INLINE long +erts_atomic_read(erts_atomic_t *var) +{ +#ifdef USE_THREADS + long i; + int res = ethr_atomic_read(var, &i); + if (res) + erts_thr_fatal_error(res, "perform atomic read"); + return i; +#else + return *var; +#endif +} + +ERTS_GLB_INLINE long +erts_atomic_inctest(erts_atomic_t *incp) +{ +#ifdef USE_THREADS + long test; + int res = ethr_atomic_inctest(incp, &test); + if (res) + erts_thr_fatal_error(res, "perform atomic increment and test"); + return test; +#else + return ++(*incp); +#endif +} + +ERTS_GLB_INLINE long +erts_atomic_dectest(erts_atomic_t *decp) +{ +#ifdef USE_THREADS + long test; + int res = ethr_atomic_dectest(decp, &test); + if (res) + erts_thr_fatal_error(res, "perform atomic decrement and test"); + return test; +#else + return --(*decp); +#endif +} + +ERTS_GLB_INLINE void +erts_atomic_inc(erts_atomic_t *incp) +{ +#ifdef USE_THREADS + int res = ethr_atomic_inc(incp); + if (res) + erts_thr_fatal_error(res, "perform atomic increment"); +#else + ++(*incp); +#endif +} + +ERTS_GLB_INLINE void +erts_atomic_dec(erts_atomic_t *decp) +{ +#ifdef USE_THREADS + int res = ethr_atomic_dec(decp); + if (res) + erts_thr_fatal_error(res, "perform atomic decrement"); +#else + --(*decp); +#endif +} + +ERTS_GLB_INLINE long +erts_atomic_addtest(erts_atomic_t *addp, long i) +{ +#ifdef USE_THREADS + long test; + int res = ethr_atomic_addtest(addp, i, &test); + if (res) + erts_thr_fatal_error(res, "perform atomic addition and test"); + return test; +#else + return *addp += i; +#endif +} + +ERTS_GLB_INLINE void +erts_atomic_add(erts_atomic_t *addp, long i) +{ +#ifdef USE_THREADS + int res = ethr_atomic_add(addp, i); + if (res) + erts_thr_fatal_error(res, "perform atomic addition"); +#else + *addp += i; +#endif +} + +ERTS_GLB_INLINE long +erts_atomic_xchg(erts_atomic_t *xchgp, long new) +{ + long old; +#ifdef USE_THREADS + int res = ethr_atomic_xchg(xchgp, new, &old); + if (res) + erts_thr_fatal_error(res, "perform atomic exchange"); +#else + old = *xchgp; + *xchgp = new; +#endif + return old; +} + +ERTS_GLB_INLINE long +erts_atomic_cmpxchg(erts_atomic_t *xchgp, long new, long expected) +{ +#ifdef USE_THREADS + long old; + int res = ethr_atomic_cmpxchg(xchgp, new, expected, &old); + if (ERTS_UNLIKELY(res != 0)) + erts_thr_fatal_error(res, "perform atomic exchange"); + return old; +#else + long old = *xchgp; + if (old == expected) + *xchgp = new; + return old; +#endif +} + +ERTS_GLB_INLINE long +erts_atomic_bor(erts_atomic_t *var, long mask) +{ + long old; +#ifdef USE_THREADS + int res = ethr_atomic_or_old(var, mask, &old); + if (res != 0) + erts_thr_fatal_error(res, "perform atomic bitwise or"); +#else + old = *var; + *var |= mask; +#endif + return old; +} + +ERTS_GLB_INLINE long +erts_atomic_band(erts_atomic_t *var, long mask) +{ + long old; +#ifdef USE_THREADS + int res = ethr_atomic_and_old(var, mask, &old); + if (res != 0) + erts_thr_fatal_error(res, "perform atomic bitwise and"); +#else + old = *var; + *var &= mask; +#endif + return old; +} + +/* spinlock */ + +ERTS_GLB_INLINE void +erts_spinlock_init_x(erts_spinlock_t *lock, char *name, Eterm extra) +{ +#ifdef USE_THREADS + int res = ethr_spinlock_init(&lock->slck); + if (res) + erts_thr_fatal_error(res, "init spinlock"); +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_init_lock_x(&lock->lc, name, ERTS_LC_FLG_LT_SPINLOCK, extra); +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_init_lock_x(&lock->lcnt, name, ERTS_LCNT_LT_SPINLOCK, extra); +#endif +#else + (void)lock; +#endif +} + +ERTS_GLB_INLINE void +erts_spinlock_init(erts_spinlock_t *lock, char *name) +{ +#ifdef USE_THREADS + int res = ethr_spinlock_init(&lock->slck); + if (res) + erts_thr_fatal_error(res, "init spinlock"); +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_init_lock(&lock->lc, name, ERTS_LC_FLG_LT_SPINLOCK); +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_init_lock(&lock->lcnt, name, ERTS_LCNT_LT_SPINLOCK); +#endif +#else + (void)lock; +#endif +} + +ERTS_GLB_INLINE void +erts_spinlock_destroy(erts_spinlock_t *lock) +{ +#ifdef USE_THREADS + int res; +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_destroy_lock(&lock->lc); +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_destroy_lock(&lock->lcnt); +#endif + res = ethr_spinlock_destroy(&lock->slck); + if (res) + erts_thr_fatal_error(res, "destroy spinlock"); +#else + (void)lock; +#endif +} + +ERTS_GLB_INLINE void +erts_spin_unlock(erts_spinlock_t *lock) +{ +#ifdef USE_THREADS + int res; +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_unlock(&lock->lc); +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_unlock(&lock->lcnt); +#endif + res = ethr_spin_unlock(&lock->slck); + if (res) + erts_thr_fatal_error(res, "release spin lock"); +#else + (void)lock; +#endif +} + +ERTS_GLB_INLINE void +#ifdef ERTS_ENABLE_LOCK_COUNT +erts_spin_lock_x(erts_spinlock_t *lock, char *file, unsigned int line) +#else +erts_spin_lock(erts_spinlock_t *lock) +#endif +{ +#ifdef USE_THREADS + int res; +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_lock(&lock->lc); +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_lock(&lock->lcnt); +#endif + res = ethr_spin_lock(&lock->slck); +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_lock_post_x(&lock->lcnt, file, line); +#endif + if (res) + erts_thr_fatal_error(res, "take spin lock"); +#else + (void)lock; +#endif +} + +ERTS_GLB_INLINE int +erts_lc_spinlock_is_locked(erts_spinlock_t *lock) +{ +#if defined(USE_THREADS) && defined(ERTS_ENABLE_LOCK_CHECK) + int res; + erts_lc_lock_t lc = lock->lc; + lc.flags = 0; + erts_lc_have_locks(&res, &lc, 1); + return res; +#else + return 0; +#endif +} + +/* rwspinlock */ + +ERTS_GLB_INLINE void +erts_rwlock_init_x(erts_rwlock_t *lock, char *name, Eterm extra) +{ +#ifdef USE_THREADS + int res = ethr_rwlock_init(&lock->rwlck); + if (res) + erts_thr_fatal_error(res, "init rwlock"); +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_init_lock_x(&lock->lc, name, ERTS_LC_FLG_LT_RWSPINLOCK, extra); +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_init_lock_x(&lock->lcnt, name, ERTS_LCNT_LT_RWSPINLOCK, extra); +#endif +#else + (void)lock; +#endif +} + +ERTS_GLB_INLINE void +erts_rwlock_init(erts_rwlock_t *lock, char *name) +{ +#ifdef USE_THREADS + int res = ethr_rwlock_init(&lock->rwlck); + if (res) + erts_thr_fatal_error(res, "init rwlock"); +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_init_lock(&lock->lc, name, ERTS_LC_FLG_LT_RWSPINLOCK); +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_init_lock(&lock->lcnt, name, ERTS_LCNT_LT_RWSPINLOCK); +#endif +#else + (void)lock; +#endif +} + +ERTS_GLB_INLINE void +erts_rwlock_destroy(erts_rwlock_t *lock) +{ +#ifdef USE_THREADS + int res; +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_destroy_lock(&lock->lc); +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_destroy_lock(&lock->lcnt); +#endif + res = ethr_rwlock_destroy(&lock->rwlck); + if (res) + erts_thr_fatal_error(res, "destroy rwlock"); +#else + (void)lock; +#endif +} + +ERTS_GLB_INLINE void +erts_read_unlock(erts_rwlock_t *lock) +{ +#ifdef USE_THREADS + int res; +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_unlock_flg(&lock->lc, ERTS_LC_FLG_LO_READ); +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_unlock_opt(&lock->lcnt, ERTS_LCNT_LO_READ); +#endif + res = ethr_read_unlock(&lock->rwlck); + if (res) + erts_thr_fatal_error(res, "release read lock"); +#else + (void)lock; +#endif +} + +ERTS_GLB_INLINE void +#ifdef ERTS_ENABLE_LOCK_COUNT +erts_read_lock_x(erts_rwlock_t *lock, char *file, unsigned int line) +#else +erts_read_lock(erts_rwlock_t *lock) +#endif +{ +#ifdef USE_THREADS + int res; +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_lock_flg(&lock->lc, ERTS_LC_FLG_LO_READ); +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_lock_opt(&lock->lcnt, ERTS_LCNT_LO_READ); +#endif + res = ethr_read_lock(&lock->rwlck); +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_lock_post_x(&lock->lcnt, file, line); +#endif + if (res) + erts_thr_fatal_error(res, "take read lock"); +#else + (void)lock; +#endif +} + +ERTS_GLB_INLINE void +erts_write_unlock(erts_rwlock_t *lock) +{ +#ifdef USE_THREADS + int res; +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_unlock_flg(&lock->lc, ERTS_LC_FLG_LO_READ_WRITE); +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_unlock_opt(&lock->lcnt, ERTS_LCNT_LO_READ_WRITE); +#endif + res = ethr_write_unlock(&lock->rwlck); + if (res) + erts_thr_fatal_error(res, "release write lock"); +#else + (void)lock; +#endif +} + +ERTS_GLB_INLINE void +#ifdef ERTS_ENABLE_LOCK_COUNT +erts_write_lock_x(erts_rwlock_t *lock, char *file, unsigned int line) +#else +erts_write_lock(erts_rwlock_t *lock) +#endif +{ +#ifdef USE_THREADS + int res; +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_lock_flg(&lock->lc, ERTS_LC_FLG_LO_READ_WRITE); +#endif +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_lock_opt(&lock->lcnt, ERTS_LCNT_LO_READ_WRITE); +#endif + res = ethr_write_lock(&lock->rwlck); +#ifdef ERTS_ENABLE_LOCK_COUNT + erts_lcnt_lock_post_x(&lock->lcnt, file, line); +#endif + if (res) + erts_thr_fatal_error(res, "take write lock"); +#else + (void)lock; +#endif +} + +ERTS_GLB_INLINE int +erts_lc_rwlock_is_rlocked(erts_rwlock_t *lock) +{ +#if defined(USE_THREADS) && defined(ERTS_ENABLE_LOCK_CHECK) + int res; + erts_lc_lock_t lc = lock->lc; + lc.flags = ERTS_LC_FLG_LO_READ; + erts_lc_have_locks(&res, &lc, 1); + return res; +#else + return 0; +#endif +} + +ERTS_GLB_INLINE int +erts_lc_rwlock_is_rwlocked(erts_rwlock_t *lock) +{ +#if defined(USE_THREADS) && defined(ERTS_ENABLE_LOCK_CHECK) + int res; + erts_lc_lock_t lc = lock->lc; + lc.flags = ERTS_LC_FLG_LO_READ|ERTS_LC_FLG_LO_WRITE; + erts_lc_have_locks(&res, &lc, 1); + return res; +#else + return 0; +#endif +} + +ERTS_GLB_INLINE void +erts_thr_time_now(erts_thr_timeval_t *time) +{ +#ifdef USE_THREADS + int res = ethr_time_now(time); + if (res) + erts_thr_fatal_error(res, "get current time"); +#endif +} + +ERTS_GLB_INLINE void +erts_tsd_key_create(erts_tsd_key_t *keyp) +{ +#ifdef USE_THREADS + int res = ethr_tsd_key_create(keyp); + if (res) + erts_thr_fatal_error(res, "create thread specific data key"); +#endif +} + +ERTS_GLB_INLINE void +erts_tsd_key_delete(erts_tsd_key_t key) +{ +#ifdef USE_THREADS + int res = ethr_tsd_key_delete(key); + if (res) + erts_thr_fatal_error(res, "delete thread specific data key"); +#endif +} + +ERTS_GLB_INLINE void +erts_tsd_set(erts_tsd_key_t key, void *value) +{ +#ifdef USE_THREADS + int res = ethr_tsd_set(key, value); + if (res) + erts_thr_fatal_error(res, "set thread specific data"); +#endif +} + +ERTS_GLB_INLINE void * +erts_tsd_get(erts_tsd_key_t key) +{ +#ifdef USE_THREADS + return ethr_tsd_get(key); +#else + return NULL; +#endif +} + +ERTS_GLB_INLINE void +erts_gate_init(erts_gate_t *gp) +{ +#ifdef USE_THREADS + int res = ethr_gate_init((ethr_gate *) gp); + if (res != 0) + erts_thr_fatal_error(res, "initialize gate"); +#endif +} + +ERTS_GLB_INLINE void +erts_gate_destroy(erts_gate_t *gp) +{ +#ifdef USE_THREADS + int res = ethr_gate_destroy((ethr_gate *) gp); + if (res != 0) + erts_thr_fatal_error(res, "destroy gate"); +#endif +} + +ERTS_GLB_INLINE void +erts_gate_close(erts_gate_t *gp) +{ +#ifdef USE_THREADS + int res = ethr_gate_close((ethr_gate *) gp); + if (res != 0) + erts_thr_fatal_error(res, "close gate"); +#endif +} + +ERTS_GLB_INLINE void +erts_gate_let_through(erts_gate_t *gp, unsigned no) +{ +#ifdef USE_THREADS + int res = ethr_gate_let_through((ethr_gate *) gp, no); + if (res != 0) + erts_thr_fatal_error(res, "let through gate"); +#endif +} + +ERTS_GLB_INLINE void +erts_gate_wait(erts_gate_t *gp) +{ +#ifdef USE_THREADS + int res = ethr_gate_wait((ethr_gate *) gp); + if (res != 0) + erts_thr_fatal_error(res, "wait on gate"); +#endif +} + +ERTS_GLB_INLINE void +erts_gate_swait(erts_gate_t *gp, int spincount) +{ +#ifdef USE_THREADS + int res = ethr_gate_swait((ethr_gate *) gp, spincount); + if (res != 0) + erts_thr_fatal_error(res, "swait on gate"); +#endif +} + +#ifdef ETHR_HAVE_ETHR_SIG_FUNCS + +ERTS_GLB_INLINE void +erts_thr_sigmask(int how, const sigset_t *set, sigset_t *oset) +{ +#ifdef USE_THREADS + int res = ethr_sigmask(how, set, oset); + if (res) + erts_thr_fatal_error(res, "get or set signal mask"); +#endif +} + +ERTS_GLB_INLINE void +erts_thr_sigwait(const sigset_t *set, int *sig) +{ +#ifdef USE_THREADS + int res; + do { + res = ethr_sigwait(set, sig); + } while (res == EINTR); + if (res) + erts_thr_fatal_error(res, "to wait for signal"); +#endif +} + +#endif /* #ifdef HAVE_ETHR_SIG_FUNCS */ + +#endif /* #if ERTS_GLB_INLINE_INCL_FUNC_DEF */ + +#endif /* #ifndef ERL_THREAD_H__ */ diff --git a/erts/emulator/beam/erl_time.h b/erts/emulator/beam/erl_time.h new file mode 100644 index 0000000000..6f6b971d34 --- /dev/null +++ b/erts/emulator/beam/erl_time.h @@ -0,0 +1,67 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2006-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifndef ERL_TIME_H__ +#define ERL_TIME_H__ + +/* +** Timer entry: +*/ +typedef struct erl_timer { + struct erl_timer* next; /* next entry tiw slot or chain */ + Uint slot; /* slot in timer wheel */ + Uint count; /* number of loops remaining */ + int active; /* 1=activated, 0=deactivated */ + /* called when timeout */ + void (*timeout)(void*); + /* called when cancel (may be NULL) */ + void (*cancel)(void*); + void* arg; /* argument to timeout/cancel procs */ +} ErlTimer; + +typedef void (*ErlTimeoutProc)(void*); +typedef void (*ErlCancelProc)(void*); + +#ifdef ERTS_SMP + +/* + * Process and port timer + */ +typedef union ErtsSmpPTimer_ ErtsSmpPTimer; +union ErtsSmpPTimer_ { + struct { + ErlTimer tm; + Eterm id; + void (*timeout_func)(void*); + ErtsSmpPTimer **timer_ref; + Uint32 flags; + } timer; + ErtsSmpPTimer *next; +}; + + +void erts_create_smp_ptimer(ErtsSmpPTimer **timer_ref, + Eterm id, + ErlTimeoutProc timeout_func, + Uint timeout); +void erts_cancel_smp_ptimer(ErtsSmpPTimer *ptimer); + +#endif + +#endif diff --git a/erts/emulator/beam/erl_time_sup.c b/erts/emulator/beam/erl_time_sup.c new file mode 100644 index 0000000000..76bfdecd9f --- /dev/null +++ b/erts/emulator/beam/erl_time_sup.c @@ -0,0 +1,899 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1999-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* +** Support routines for the timer wheel +** +** This code contains two strategies for dealing with +** date/time changes in the system. +** If the system has some kind of high resolution timer (HAVE_GETHRTIME), +** the high resolution timer is used to correct the time-of-day and the +** timeouts, the base source is the hrtimer, but at certain intervals the +** OS time-of-day is checked and if it is not within certain bounds, the +** delivered time gets slowly adjusted for each call until +** it corresponds to the system time (built-in adjtime...). +** The call gethrtime() is detected by autoconf on Unix, but other +** platforms may define it in erl_*_sys.h and implement +** their own high resolution timer. The high resolution timer +** strategy is (probably) best on all systems where the timer have +** a resolution higher or equal to gettimeofday (or what's implemented +** is sys_gettimeofday()). The actual resolution is the interesting thing, +** not the unit's thats used (i.e. on VxWorks, nanoseconds can be +** retrieved in terms of units, but the actual resolution is the same as +** for the clock ticks). +** If the systems best timer routine is kernel ticks returned from +** sys_times(), and the actual resolution of sys_gettimeofday() is +** better (like most unixes that does not have any realtime extensions), +** another strategy is used. The tolerant gettimeofday() corrects +** the value with respect to uptime (sys_times() return value) and checks +** for correction both when delivering timeticks and delivering nowtime. +** this strategy is slower, but accurate on systems without better timer +** routines. The kernel tick resolution is not enough to implement +** a gethrtime routine. On Linux and other non solaris unix-boxes the second +** strategy is used, on all other platforms we use the first. +** +** The following is expected (from sys.[ch] and erl_*_sys.h): +** +** 64 bit integers. So it is, and so it will be. +** +** sys_init_time(), will return the clock resolution in MS and +** that's about it. More could be added of course +** If the clock-rate is constant (i.e. 1 ms) one can define +** SYS_CLOCK_RESOLUTION (to 1), +** which makes erts_deliver_time/erts_time_remaining a bit faster. +** +** if HAVE_GETHRTIME is defined: +** sys_gethrtime() will return a SysHrTime (long long) representing +** nanoseconds, sys_init_hrtime() will do any initialization. +** else +** a long (64bit) integer type called Sint64 should be defined. +** +** sys_times() will return clock_ticks since start and +** fill in a SysTimes structure (struct tms). Instead of CLK_TCK, +** SYS_CLK_TCK is used to determine the resolution of kernel ticks. +** +** sys_gettimeofday() will take a SysTimeval (a struct timeval) as parameter +** and fill it in as gettimeofday(X,NULL). +** +*/ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" + +static erts_smp_mtx_t erts_timeofday_mtx; + +static SysTimeval inittv; /* Used everywhere, the initial time-of-day */ + +static SysTimes t_start; /* Used in elapsed_time_both */ +static SysTimeval gtv; /* Used in wall_clock_elapsed_time_both */ +static SysTimeval then; /* Used in get_now */ +static SysTimeval last_emu_time; /* Used in erts_get_emu_time() */ +SysTimeval erts_first_emu_time; /* Used in erts_get_emu_time() */ + + +#ifdef HAVE_GETHRTIME + +int erts_disable_tolerant_timeofday; + +static SysHrTime hr_init_time, hr_last_correction_check, + hr_correction, hr_last_time; + +static void init_tolerant_timeofday(void) +{ + /* Should be in sys.c */ +#if defined(HAVE_SYSCONF) && defined(_SC_NPROCESSORS_CONF) + if (sysconf(_SC_NPROCESSORS_CONF) > 1) { + char b[1024]; + int maj,min,build; + os_flavor(b,1024); + os_version(&maj,&min,&build); + if (!strcmp(b,"sunos") && maj <= 5 && min <= 7) { + erts_disable_tolerant_timeofday = 1; + } + } +#endif + hr_init_time = sys_gethrtime(); + hr_last_correction_check = hr_last_time = hr_init_time; + hr_correction = 0; +} + +static void get_tolerant_timeofday(SysTimeval *tv) +{ + SysHrTime diff_time, curr; + + if (erts_disable_tolerant_timeofday) { + sys_gettimeofday(tv); + return; + } + *tv = inittv; + diff_time = ((curr = sys_gethrtime()) + hr_correction - hr_init_time) / 1000; + + if (curr < hr_init_time) { + erl_exit(1,"Unexpected behaviour from operating system high " + "resolution timer"); + } + + if ((curr - hr_last_correction_check) / 1000 > 1000000) { + /* Check the correction need */ + SysHrTime tv_diff, diffdiff; + SysTimeval tmp; + int done = 0; + + sys_gettimeofday(&tmp); + tv_diff = ((SysHrTime) tmp.tv_sec) * 1000000 + tmp.tv_usec; + tv_diff -= ((SysHrTime) inittv.tv_sec) * 1000000 + inittv.tv_usec; + diffdiff = diff_time - tv_diff; + if (diffdiff > 10000) { + SysHrTime corr = (curr - hr_last_time) / 100; + if (corr / 1000 >= diffdiff) { + ++done; + hr_correction -= ((SysHrTime)diffdiff) * 1000; + } else { + hr_correction -= corr; + } + diff_time = (curr + hr_correction - hr_init_time) / 1000; + } else if (diffdiff < -10000) { + SysHrTime corr = (curr - hr_last_time) / 100; + if (corr / 1000 >= -diffdiff) { + ++done; + hr_correction -= ((SysHrTime)diffdiff) * 1000; + } else { + hr_correction += corr; + } + diff_time = (curr + hr_correction - hr_init_time) / 1000; + } else { + ++done; + } + if (done) { + hr_last_correction_check = curr; + } + } + tv->tv_sec += (int) (diff_time / ((SysHrTime) 1000000)); + tv->tv_usec += (int) (diff_time % ((SysHrTime) 1000000)); + if (tv->tv_usec >= 1000000) { + tv->tv_usec -= 1000000; + tv->tv_sec += 1; + } + hr_last_time = curr; +} + +#define correction (hr_correction/1000000) + +#else /* !HAVE_GETHRTIME */ +#if !defined(CORRECT_USING_TIMES) +#define init_tolerant_timeofday() +#define get_tolerant_timeofday(tvp) sys_gettimeofday(tvp) +#else + +typedef Sint64 Milli; + +static clock_t init_ct; +static Sint64 ct_wrap; +static Milli init_tv_m; +static Milli correction_supress; +static Milli last_ct_diff; +static Milli last_cc; +static clock_t last_ct; + +/* sys_times() might need to be wrapped and the values shifted (right) + a bit to cope with newer linux (2.5.*) kernels, this has to be taken care + of dynamically to start with, a special version that uses + the times() return value as a high resolution timer can be made + to fully utilize the faster ticks, like on windows, but for now, we'll + settle with this silly workaround */ +#ifdef ERTS_WRAP_SYS_TIMES +#define KERNEL_TICKS() (sys_times_wrap() & \ + ((1UL << ((sizeof(clock_t) * 8) - 1)) - 1)) +#else +SysTimes dummy_tms; + +#define KERNEL_TICKS() (sys_times(&dummy_tms) & \ + ((1UL << ((sizeof(clock_t) * 8) - 1)) - 1)) + +#endif + +static void init_tolerant_timeofday(void) +{ + last_ct = init_ct = KERNEL_TICKS(); + last_cc = 0; + init_tv_m = (((Milli) inittv.tv_sec) * 1000) + + (inittv.tv_usec / 1000); + ct_wrap = 0; + correction_supress = 0; +} + + +static void get_tolerant_timeofday(SysTimeval *tvp) +{ + clock_t current_ct; + SysTimeval current_tv; + Milli ct_diff; + Milli tv_diff; + Milli current_correction; + Milli act_correction; /* long shown to be too small */ + Milli max_adjust; + + if (erts_disable_tolerant_timeofday) { + sys_gettimeofday(tvp); + return; + } + +#ifdef ERTS_WRAP_SYS_TIMES +#define TICK_MS (1000 / SYS_CLK_TCK_WRAP) +#else +#define TICK_MS (1000 / SYS_CLK_TCK) +#endif + current_ct = KERNEL_TICKS(); + sys_gettimeofday(¤t_tv); + + /* I dont know if uptime can move some units backwards + on some systems, but I allow for small backward + jumps to avoid such problems if they exist...*/ + if (last_ct > 100 && current_ct < (last_ct - 100)) { + ct_wrap += ((Sint64) 1) << ((sizeof(clock_t) * 8) - 1); + } + last_ct = current_ct; + ct_diff = ((ct_wrap + current_ct) - init_ct) * TICK_MS; + + /* + * We will adjust the time in milliseconds and we allow for 1% + * adjustments, but if this function is called more often then every 100 + * millisecond (which is obviously possible), we will never adjust, so + * we accumulate small times by setting last_ct_diff iff max_adjust > 0 + */ + if ((max_adjust = (ct_diff - last_ct_diff)/100) > 0) + last_ct_diff = ct_diff; + + tv_diff = ((((Milli) current_tv.tv_sec) * 1000) + + (current_tv.tv_usec / 1000)) - init_tv_m; + + current_correction = ((ct_diff - tv_diff) / TICK_MS) * TICK_MS; /* trunc */ + + /* + * We allow the current_correction value to wobble a little, as it + * suffers from the low resolution of the kernel ticks. + * if it hasn't changed more than one tick in either direction, + * we will keep the old value. + */ + if ((last_cc > current_correction + TICK_MS) || + (last_cc < current_correction - TICK_MS)) { + last_cc = current_correction; + } else { + current_correction = last_cc; + } + + /* + * As time goes, we try to get the actual correction to 0, + * that is, make erlangs time correspond to the systems dito. + * The act correction is what we seem to need (current_correction) + * minus the correction suppression. The correction supression + * will change slowly (max 1% of elapsed time) but in millisecond steps. + */ + act_correction = current_correction - correction_supress; + if (max_adjust > 0) { + /* + * Here we slowly adjust erlangs time to correspond with the + * system time by changing the correction_supress variable. + * It can change max_adjust milliseconds which is 1% of elapsed time + */ + if (act_correction > 0) { + if (current_correction - correction_supress > max_adjust) { + correction_supress += max_adjust; + } else { + correction_supress = current_correction; + } + act_correction = current_correction - correction_supress; + } else if (act_correction < 0) { + if (correction_supress - current_correction > max_adjust) { + correction_supress -= max_adjust; + } else { + correction_supress = current_correction; + } + act_correction = current_correction - correction_supress; + } + } + /* + * The actual correction will correct the timeval so that system + * time warps gets smothed down. + */ + current_tv.tv_sec += act_correction / 1000; + current_tv.tv_usec += (act_correction % 1000) * 1000; + + if (current_tv.tv_usec >= 1000000) { + ++current_tv.tv_sec ; + current_tv.tv_usec -= 1000000; + } else if (current_tv.tv_usec < 0) { + --current_tv.tv_sec; + current_tv.tv_usec += 1000000; + } + *tvp = current_tv; +#undef TICK_MS +} + +#endif /* CORRECT_USING_TIMES */ +#endif /* !HAVE_GETHRTIME */ + +/* +** Why this? Well, most platforms have a constant clock resolution of 1, +** we dont want the deliver_time/time_remaining routines to waste +** time dividing and multiplying by/with a variable that's always one. +** so the return value of sys_init_time is ignored on those platforms. +*/ + +#ifndef SYS_CLOCK_RESOLUTION +static int clock_resolution; +#define CLOCK_RESOLUTION clock_resolution +#else +#define CLOCK_RESOLUTION SYS_CLOCK_RESOLUTION +#endif + +/* +** The clock resolution should really be the resolution of the +** time function in use, which on most platforms +** is 1. On VxWorks the resolution shold be +** the number of ticks per second (or 1, which would work nicely to). +** +** Setting lower resolutions is mostly interesting when timers are used +** instead of something like select. +*/ + +#if defined(ERTS_TIMER_THREAD) +static ERTS_INLINE void init_erts_deliver_time(const SysTimeval *inittv) { } +static ERTS_INLINE void do_erts_deliver_time(const SysTimeval *current) { } +#else +static SysTimeval last_delivered; + +static void init_erts_deliver_time(const SysTimeval *inittv) +{ + /* We set the initial values for deliver_time here */ + last_delivered = *inittv; + last_delivered.tv_usec = 1000 * (last_delivered.tv_usec / 1000); + /* ms resolution */ +} + +static void do_erts_deliver_time(const SysTimeval *current) +{ + SysTimeval cur_time; + long elapsed; + + /* calculate and deliver appropriate number of ticks */ + cur_time = *current; + cur_time.tv_usec = 1000 * (cur_time.tv_usec / 1000); /* ms resolution */ + elapsed = (1000 * (cur_time.tv_sec - last_delivered.tv_sec) + + (cur_time.tv_usec - last_delivered.tv_usec) / 1000) / + CLOCK_RESOLUTION; + + /* Sometimes the time jump backwards, + resulting in a negative elapsed time. We compensate for + this by simply pretend as if the time stood still. :) */ + + if (elapsed > 0) { + do_time_add(elapsed); + last_delivered = cur_time; + } +} +#endif + +int +erts_init_time_sup(void) +{ + erts_smp_mtx_init(&erts_timeofday_mtx, "timeofday"); + + last_emu_time.tv_sec = 0; + last_emu_time.tv_usec = 0; + +#ifndef SYS_CLOCK_RESOLUTION + clock_resolution = sys_init_time(); +#else + (void) sys_init_time(); +#endif + sys_gettimeofday(&inittv); + +#ifdef HAVE_GETHRTIME + sys_init_hrtime(); +#endif + init_tolerant_timeofday(); + + init_erts_deliver_time(&inittv); + gtv = inittv; + then.tv_sec = then.tv_usec = 0; + + erts_get_emu_time(&erts_first_emu_time); + + return CLOCK_RESOLUTION; +} +/* info functions */ + +void +elapsed_time_both(unsigned long *ms_user, unsigned long *ms_sys, + unsigned long *ms_user_diff, unsigned long *ms_sys_diff) +{ + unsigned long prev_total_user, prev_total_sys; + unsigned long total_user, total_sys; + SysTimes now; + + sys_times(&now); + total_user = (now.tms_utime * 1000) / SYS_CLK_TCK; + total_sys = (now.tms_stime * 1000) / SYS_CLK_TCK; + + if (ms_user != NULL) + *ms_user = total_user; + if (ms_sys != NULL) + *ms_sys = total_sys; + + erts_smp_mtx_lock(&erts_timeofday_mtx); + + prev_total_user = (t_start.tms_utime * 1000) / SYS_CLK_TCK; + prev_total_sys = (t_start.tms_stime * 1000) / SYS_CLK_TCK; + t_start = now; + + erts_smp_mtx_unlock(&erts_timeofday_mtx); + + if (ms_user_diff != NULL) + *ms_user_diff = total_user - prev_total_user; + + if (ms_sys_diff != NULL) + *ms_sys_diff = total_sys - prev_total_sys; +} + + +/* wall clock routines */ + +void +wall_clock_elapsed_time_both(unsigned long *ms_total, unsigned long *ms_diff) +{ + unsigned long prev_total; + SysTimeval tv; + + erts_smp_mtx_lock(&erts_timeofday_mtx); + + get_tolerant_timeofday(&tv); + + *ms_total = 1000 * (tv.tv_sec - inittv.tv_sec) + + (tv.tv_usec - inittv.tv_usec) / 1000; + + prev_total = 1000 * (gtv.tv_sec - inittv.tv_sec) + + (gtv.tv_usec - inittv.tv_usec) / 1000; + *ms_diff = *ms_total - prev_total; + gtv = tv; + + /* must sync the machine's idea of time here */ + do_erts_deliver_time(&tv); + + erts_smp_mtx_unlock(&erts_timeofday_mtx); +} + +/* get current time */ +void +get_time(int *hour, int *minute, int *second) +{ + time_t the_clock; + struct tm *tm; +#ifdef HAVE_LOCALTIME_R + struct tm tmbuf; +#endif + + the_clock = time((time_t *)0); +#ifdef HAVE_LOCALTIME_R + localtime_r(&the_clock, (tm = &tmbuf)); +#else + tm = localtime(&the_clock); +#endif + *hour = tm->tm_hour; + *minute = tm->tm_min; + *second = tm->tm_sec; +} + +/* get current date */ +void +get_date(int *year, int *month, int *day) +{ + time_t the_clock; + struct tm *tm; +#ifdef HAVE_LOCALTIME_R + struct tm tmbuf; +#endif + + + the_clock = time((time_t *)0); +#ifdef HAVE_LOCALTIME_R + localtime_r(&the_clock, (tm = &tmbuf)); +#else + tm = localtime(&the_clock); +#endif + *year = tm->tm_year + 1900; + *month = tm->tm_mon +1; + *day = tm->tm_mday; +} + +/* get localtime */ +void +get_localtime(int *year, int *month, int *day, + int *hour, int *minute, int *second) +{ + time_t the_clock; + struct tm *tm; +#ifdef HAVE_LOCALTIME_R + struct tm tmbuf; +#endif + + the_clock = time((time_t *)0); +#ifdef HAVE_LOCALTIME_R + localtime_r(&the_clock, (tm = &tmbuf)); +#else + tm = localtime(&the_clock); +#endif + *year = tm->tm_year + 1900; + *month = tm->tm_mon +1; + *day = tm->tm_mday; + *hour = tm->tm_hour; + *minute = tm->tm_min; + *second = tm->tm_sec; +} + + +/* get universaltime */ +void +get_universaltime(int *year, int *month, int *day, + int *hour, int *minute, int *second) +{ + time_t the_clock; + struct tm *tm; +#ifdef HAVE_GMTIME_R + struct tm tmbuf; +#endif + + the_clock = time((time_t *)0); +#ifdef HAVE_GMTIME_R + gmtime_r(&the_clock, (tm = &tmbuf)); +#else + tm = gmtime(&the_clock); +#endif + *year = tm->tm_year + 1900; + *month = tm->tm_mon +1; + *day = tm->tm_mday; + *hour = tm->tm_hour; + *minute = tm->tm_min; + *second = tm->tm_sec; +} + + +/* days in month = 1, 2, ..., 12 */ +static const int mdays[14] = {0, 31, 28, 31, 30, 31, 30, + 31, 31, 30, 31, 30, 31}; + +#define IN_RANGE(a,x,b) (((a) <= (x)) && ((x) <= (b))) +#define is_leap_year(y) (((((y) % 4) == 0) && \ + (((y) % 100) != 0)) || \ + (((y) % 400) == 0)) + +#define BASEYEAR 1970 + +/* + * gregday + * + * Returns the number of days since Jan 1, 1600, if year is + * greater of equal to 1600 , and month [1-12] and day [1-31] + * are within range. Otherwise it returns -1. + */ +static int long gregday(int year, int month, int day) +{ + int long ndays = 0; + int gyear, pyear, m; + + /* number of days in previous years */ + gyear = year - 1600; + if (gyear > 0) { + pyear = gyear - 1; + ndays = (pyear/4) - (pyear/100) + (pyear/400) + pyear*365 + 366; + } + /* number of days in all months preceeding month */ + for (m = 1; m < month; m++) + ndays += mdays[m]; + /* Extra day if leap year and March or later */ + if (is_leap_year(year) && (month > 2)) + ndays++; + ndays += day - 1; + return ndays - 135140; /* 135140 = Jan 1, 1970 */ +} + + + +int +local_to_univ(Sint *year, Sint *month, Sint *day, + Sint *hour, Sint *minute, Sint *second, int isdst) +{ + time_t the_clock; + struct tm *tm, t; +#ifdef HAVE_GMTIME_R + struct tm tmbuf; +#endif + + if (!(IN_RANGE(BASEYEAR, *year, INT_MAX - 1) && + IN_RANGE(1, *month, 12) && + IN_RANGE(1, *day, (mdays[*month] + + (*month == 2 + && (*year % 4 == 0) + && (*year % 100 != 0 || *year % 400 == 0)))) && + IN_RANGE(0, *hour, 23) && + IN_RANGE(0, *minute, 59) && + IN_RANGE(0, *second, 59))) { + return 0; + } + + t.tm_year = *year - 1900; + t.tm_mon = *month - 1; + t.tm_mday = *day; + t.tm_hour = *hour; + t.tm_min = *minute; + t.tm_sec = *second; + t.tm_isdst = isdst; + the_clock = mktime(&t); +#ifdef HAVE_GMTIME_R + gmtime_r(&the_clock, (tm = &tmbuf)); +#else + tm = gmtime(&the_clock); +#endif + *year = tm->tm_year + 1900; + *month = tm->tm_mon +1; + *day = tm->tm_mday; + *hour = tm->tm_hour; + *minute = tm->tm_min; + *second = tm->tm_sec; + return 1; +} + +int +univ_to_local(Sint *year, Sint *month, Sint *day, + Sint *hour, Sint *minute, Sint *second) +{ + time_t the_clock; + struct tm *tm; +#ifdef HAVE_LOCALTIME_R + struct tm tmbuf; +#endif + + if (!(IN_RANGE(BASEYEAR, *year, INT_MAX - 1) && + IN_RANGE(1, *month, 12) && + IN_RANGE(1, *day, (mdays[*month] + + (*month == 2 + && (*year % 4 == 0) + && (*year % 100 != 0 || *year % 400 == 0)))) && + IN_RANGE(0, *hour, 23) && + IN_RANGE(0, *minute, 59) && + IN_RANGE(0, *second, 59))) { + return 0; + } + + the_clock = *second + 60 * (*minute + 60 * (*hour + 24 * + gregday(*year, *month, *day))); +#ifdef HAVE_POSIX2TIME + /* + * Addition from OpenSource - affects FreeBSD. + * No valid test case /PaN + * + * leap-second correction performed + * if system is configured so; + * do nothing if not + * See FreeBSD 6.x and 7.x + * /usr/src/lib/libc/stdtime/localtime.c + * for the details + */ + the_clock = posix2time(the_clock); +#endif + +#ifdef HAVE_LOCALTIME_R + localtime_r(&the_clock, (tm = &tmbuf)); +#else + tm = localtime(&the_clock); +#endif + *year = tm->tm_year + 1900; + *month = tm->tm_mon +1; + *day = tm->tm_mday; + *hour = tm->tm_hour; + *minute = tm->tm_min; + *second = tm->tm_sec; + return 1; +} + + +/* get a timestamp */ +void +get_now(Uint* megasec, Uint* sec, Uint* microsec) +{ + SysTimeval now; + + erts_smp_mtx_lock(&erts_timeofday_mtx); + + get_tolerant_timeofday(&now); + do_erts_deliver_time(&now); + + /* Make sure time is later than last */ + if (then.tv_sec > now.tv_sec || + (then.tv_sec == now.tv_sec && then.tv_usec >= now.tv_usec)) { + now = then; + now.tv_usec++; + } + /* Check for carry from above + general reasonability */ + if (now.tv_usec >= 1000000) { + now.tv_usec = 0; + now.tv_sec++; + } + then = now; + + erts_smp_mtx_unlock(&erts_timeofday_mtx); + + *megasec = (Uint) (now.tv_sec / 1000000); + *sec = (Uint) (now.tv_sec % 1000000); + *microsec = (Uint) (now.tv_usec); +} + +void +get_sys_now(Uint* megasec, Uint* sec, Uint* microsec) +{ + SysTimeval now; + + erts_smp_mtx_lock(&erts_timeofday_mtx); + + sys_gettimeofday(&now); + + erts_smp_mtx_unlock(&erts_timeofday_mtx); + + *megasec = (Uint) (now.tv_sec / 1000000); + *sec = (Uint) (now.tv_sec % 1000000); + *microsec = (Uint) (now.tv_usec); +} + + +/* deliver elapsed *ticks* to the machine - takes a pointer + to a struct timeval representing current time (to save + a gettimeofday() where possible) or NULL */ + +#if !defined(ERTS_TIMER_THREAD) +void erts_deliver_time(void) { + SysTimeval now; + + erts_smp_mtx_lock(&erts_timeofday_mtx); + + get_tolerant_timeofday(&now); + do_erts_deliver_time(&now); + + erts_smp_mtx_unlock(&erts_timeofday_mtx); +} +#endif + +/* get *real* time (not ticks) remaining until next timeout - if there + isn't one, give a "long" time, that is guaranteed + to not cause overflow when we report elapsed time later on */ + +void erts_time_remaining(SysTimeval *rem_time) +{ + int ticks; +#if !defined(ERTS_TIMER_THREAD) + SysTimeval cur_time; +#endif + long elapsed; + + /* next_time() returns no of ticks to next timeout or -1 if none */ + + if ((ticks = next_time()) == -1) { + /* timer queue empty */ + /* this will cause at most 100000000 ticks */ + rem_time->tv_sec = 100000; + rem_time->tv_usec = 0; + } else { + /* next timeout after ticks ticks */ + ticks *= CLOCK_RESOLUTION; + +#if defined(ERTS_TIMER_THREAD) + elapsed = 0; +#else + erts_smp_mtx_lock(&erts_timeofday_mtx); + + get_tolerant_timeofday(&cur_time); + cur_time.tv_usec = 1000 * + (cur_time.tv_usec / 1000);/* ms resolution*/ + elapsed = 1000 * (cur_time.tv_sec - last_delivered.tv_sec) + + (cur_time.tv_usec - last_delivered.tv_usec) / 1000; + + erts_smp_mtx_unlock(&erts_timeofday_mtx); + + if (ticks <= elapsed) { /* Ooops, better hurry */ + rem_time->tv_sec = rem_time->tv_usec = 0; + return; + } +#endif + rem_time->tv_sec = (ticks - elapsed) / 1000; + rem_time->tv_usec = 1000 * ((ticks - elapsed) % 1000); + } +} + +void erts_get_timeval(SysTimeval *tv) +{ + erts_smp_mtx_lock(&erts_timeofday_mtx); + get_tolerant_timeofday(tv); + erts_smp_mtx_unlock(&erts_timeofday_mtx); +} + +long +erts_get_time(void) +{ + SysTimeval sys_tv; + + erts_smp_mtx_lock(&erts_timeofday_mtx); + + get_tolerant_timeofday(&sys_tv); + + erts_smp_mtx_unlock(&erts_timeofday_mtx); + + return sys_tv.tv_sec; +} + +#ifdef HAVE_ERTS_NOW_CPU +void erts_get_now_cpu(Uint* megasec, Uint* sec, Uint* microsec) { + SysCpuTime t; + SysTimespec tp; + + sys_get_proc_cputime(t, tp); + *microsec = (Uint)(tp.tv_nsec / 1000); + t = (tp.tv_sec / 1000000); + *megasec = (Uint)(t % 1000000); + *sec = (Uint)(tp.tv_sec % 1000000); +} +#endif + + +/* + * erts_get_emu_time() is similar to get_now(). You will + * always get different times from erts_get_emu_time(), but they + * may equal a time from get_now(). + * + * erts_get_emu_time() is only used internally in the emulator in + * order to order emulator internal events. + */ + +void +erts_get_emu_time(SysTimeval *this_emu_time_p) +{ + erts_smp_mtx_lock(&erts_timeofday_mtx); + + get_tolerant_timeofday(this_emu_time_p); + + /* Make sure time is later than last */ + if (last_emu_time.tv_sec > this_emu_time_p->tv_sec || + (last_emu_time.tv_sec == this_emu_time_p->tv_sec + && last_emu_time.tv_usec >= this_emu_time_p->tv_usec)) { + *this_emu_time_p = last_emu_time; + this_emu_time_p->tv_usec++; + } + /* Check for carry from above + general reasonability */ + if (this_emu_time_p->tv_usec >= 1000000) { + this_emu_time_p->tv_usec = 0; + this_emu_time_p->tv_sec++; + } + + last_emu_time = *this_emu_time_p; + + erts_smp_mtx_unlock(&erts_timeofday_mtx); +} diff --git a/erts/emulator/beam/erl_trace.c b/erts/emulator/beam/erl_trace.c new file mode 100644 index 0000000000..2afb16fc52 --- /dev/null +++ b/erts/emulator/beam/erl_trace.c @@ -0,0 +1,3260 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1999-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* + * Support functions for tracing. + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "erl_process.h" +#include "big.h" +#include "bif.h" +#include "dist.h" +#include "beam_bp.h" +#include "error.h" +#include "erl_binary.h" +#include "erl_bits.h" + +#if 0 +#define DEBUG_PRINTOUTS +#else +#undef DEBUG_PRINTOUTS +#endif + +extern Eterm beam_return_to_trace[1]; /* OpCode(i_return_to_trace) */ +extern Eterm beam_return_trace[1]; /* OpCode(i_return_trace) */ + +/* Pseudo export entries. Never filled in with data, only used to + yield unique pointers of the correct type. */ +Export exp_send, exp_receive, exp_timeout; + +static Eterm system_seq_tracer; +static Uint default_trace_flags; +static Eterm default_tracer; + +static Eterm system_monitor; +static Eterm system_profile; + +#ifdef HAVE_ERTS_NOW_CPU +int erts_cpu_timestamp; +#endif + +static erts_smp_mtx_t smq_mtx; +static erts_smp_mtx_t sys_trace_mtx; + +enum ErtsSysMsgType { + SYS_MSG_TYPE_UNDEFINED, + SYS_MSG_TYPE_TRACE, + SYS_MSG_TYPE_SEQTRACE, + SYS_MSG_TYPE_SYSMON, + SYS_MSG_TYPE_ERRLGR, + SYS_MSG_TYPE_PROC_MSG, + SYS_MSG_TYPE_SYSPROF +}; + +#ifdef ERTS_SMP +static void enqueue_sys_msg_unlocked(enum ErtsSysMsgType type, + Eterm from, + Eterm to, + Eterm msg, + ErlHeapFragment *bp); +static void enqueue_sys_msg(enum ErtsSysMsgType type, + Eterm from, + Eterm to, + Eterm msg, + ErlHeapFragment *bp); +static void init_sys_msg_dispatcher(void); +#endif + +void erts_init_trace(void) { + erts_smp_mtx_init(&sys_trace_mtx, "sys_tracers"); +#ifdef HAVE_ERTS_NOW_CPU + erts_cpu_timestamp = 0; +#endif + erts_bif_trace_init(); + erts_system_monitor_clear(NULL); + erts_system_profile_clear(NULL); + default_trace_flags = F_INITIAL_TRACE_FLAGS; + default_tracer = NIL; + system_seq_tracer = am_false; +#ifdef ERTS_SMP + init_sys_msg_dispatcher(); +#endif +} + +static Eterm system_seq_tracer; + +#ifdef ERTS_SMP +#define ERTS_ALLOC_SYSMSG_HEAP(SZ, BPP, OHPP, UNUSED) \ + (*(BPP) = new_message_buffer((SZ)), \ + *(OHPP) = &(*(BPP))->off_heap, \ + (*(BPP))->mem) +#else +#define ERTS_ALLOC_SYSMSG_HEAP(SZ, BPP, OHPP, RPP) \ + erts_alloc_message_heap((SZ), (BPP), (OHPP), (RPP), 0) +#endif + +#ifdef ERTS_SMP +#define ERTS_ENQ_TRACE_MSG(FPID, TPID, MSG, BP) \ +do { \ + ERTS_LC_ASSERT(erts_smp_lc_mtx_is_locked(&smq_mtx)); \ + enqueue_sys_msg_unlocked(SYS_MSG_TYPE_TRACE, (FPID), (TPID), (MSG), (BP)); \ +} while(0) +#else +#define ERTS_ENQ_TRACE_MSG(FPID, TPROC, MSG, BP) \ + erts_queue_message((TPROC), NULL, (BP), (MSG), NIL) +#endif + +/* + * NOTE that the ERTS_GET_TRACER_REF() returns from the function (!!!) + * using it, and resets the parameters used if the tracer is invalid, i.e., + * use it with extreme care! + */ +#ifdef ERTS_SMP +#define ERTS_NULL_TRACER_REF NIL +#define ERTS_TRACER_REF_TYPE Eterm + /* In the smp case, we never find the tracer invalid here (the sys + message dispatcher thread takes care of that). */ +#define ERTS_GET_TRACER_REF(RES, TPID, TRACEE_FLGS) \ +do { (RES) = (TPID); } while(0) +#else +#define ERTS_NULL_TRACER_REF NULL +#define ERTS_TRACER_REF_TYPE Process * +#define ERTS_GET_TRACER_REF(RES, TPID, TRACEE_FLGS) \ +do { \ + (RES) = process_tab[internal_pid_index((TPID))]; \ + if (INVALID_PID((RES), (TPID)) || !((RES)->trace_flags & F_TRACER)) { \ + (TPID) = NIL; \ + (TRACEE_FLGS) &= ~TRACEE_FLAGS; \ + return; \ + } \ +} while (0) +#endif + +static Uint active_sched; + +void +erts_system_profile_setup_active_schedulers(void) +{ + ERTS_SMP_LC_ASSERT(erts_is_system_blocked(0)); + active_sched = erts_active_schedulers(); +} + +void +erts_trace_check_exiting(Eterm exiting) +{ + erts_smp_mtx_lock(&sys_trace_mtx); + if (exiting == default_tracer) { + default_tracer = NIL; + default_trace_flags &= TRACEE_FLAGS; +#ifdef DEBUG + default_trace_flags |= F_INITIAL_TRACE_FLAGS; +#endif + } + if (exiting == system_seq_tracer) { +#ifdef DEBUG_PRINTOUTS + erts_fprintf(stderr, "seq tracer %T exited\n", exiting); +#endif + system_seq_tracer = am_false; + } + if (exiting == system_monitor) { +#ifdef ERTS_SMP + system_monitor = NIL; + /* Let the trace message dispatcher clear flags, etc */ +#else + erts_system_monitor_clear(NULL); +#endif + } + if (exiting == system_profile) { +#ifdef ERTS_SMP + system_profile = NIL; + /* Let the trace message dispatcher clear flags, etc */ +#else + erts_system_profile_clear(NULL); +#endif + } + erts_smp_mtx_unlock(&sys_trace_mtx); +} + +Eterm +erts_set_system_seq_tracer(Process *c_p, ErtsProcLocks c_p_locks, Eterm new) +{ + Eterm old = THE_NON_VALUE; + + if (new != am_false) { + if (!erts_pid2proc(c_p, c_p_locks, new, 0) + && !erts_is_valid_tracer_port(new)) { + return old; + } + } + + erts_smp_mtx_lock(&sys_trace_mtx); + old = system_seq_tracer; + system_seq_tracer = new; + +#ifdef DEBUG_PRINTOUTS + erts_fprintf(stderr, "set seq tracer new=%T old=%T\n", new, old); +#endif + erts_smp_mtx_unlock(&sys_trace_mtx); + return old; +} + +Eterm +erts_get_system_seq_tracer(void) +{ + Eterm st; + erts_smp_mtx_lock(&sys_trace_mtx); + st = system_seq_tracer; +#ifdef DEBUG_PRINTOUTS + erts_fprintf(stderr, "get seq tracer %T\n", st); +#endif + erts_smp_mtx_unlock(&sys_trace_mtx); + return st; +} + +static ERTS_INLINE void +get_default_tracing(Uint *flagsp, Eterm *tracerp) +{ + if (!(default_trace_flags & TRACEE_FLAGS)) + default_tracer = NIL; + + if (is_nil(default_tracer)) { + default_trace_flags &= ~TRACEE_FLAGS; + } else if (is_internal_pid(default_tracer)) { + if (!erts_pid2proc(NULL, 0, default_tracer, 0)) { + reset_tracer: + default_trace_flags &= ~TRACEE_FLAGS; + default_tracer = NIL; + } + } else { + ASSERT(is_internal_port(default_tracer)); + if (!erts_is_valid_tracer_port(default_tracer)) + goto reset_tracer; + } + + if (flagsp) + *flagsp = default_trace_flags; + if (tracerp) + *tracerp = default_tracer; +} + +void +erts_change_default_tracing(int setflags, Uint *flagsp, Eterm *tracerp) +{ + erts_smp_mtx_lock(&sys_trace_mtx); + if (flagsp) { + if (setflags) + default_trace_flags |= *flagsp; + else + default_trace_flags &= ~(*flagsp); + } + if (tracerp) + default_tracer = *tracerp; + get_default_tracing(flagsp, tracerp); + erts_smp_mtx_unlock(&sys_trace_mtx); +} + +void +erts_get_default_tracing(Uint *flagsp, Eterm *tracerp) +{ + erts_smp_mtx_lock(&sys_trace_mtx); + get_default_tracing(flagsp, tracerp); + erts_smp_mtx_unlock(&sys_trace_mtx); +} + +void +erts_set_system_monitor(Eterm monitor) +{ + erts_smp_mtx_lock(&sys_trace_mtx); + system_monitor = monitor; + erts_smp_mtx_unlock(&sys_trace_mtx); +} + +Eterm +erts_get_system_monitor(void) +{ + Eterm monitor; + erts_smp_mtx_lock(&sys_trace_mtx); + monitor = system_monitor; + erts_smp_mtx_unlock(&sys_trace_mtx); + return monitor; +} + +/* Performance monitoring */ +void erts_set_system_profile(Eterm profile) { + erts_smp_mtx_lock(&sys_trace_mtx); + system_profile = profile; + erts_smp_mtx_unlock(&sys_trace_mtx); +} + +Eterm +erts_get_system_profile(void) { + Eterm profile; + erts_smp_mtx_lock(&sys_trace_mtx); + profile = system_profile; + erts_smp_mtx_unlock(&sys_trace_mtx); + return profile; +} + + +#ifdef HAVE_ERTS_NOW_CPU +# define GET_NOW(m, s, u) \ +do { \ + if (erts_cpu_timestamp) \ + erts_get_now_cpu(m, s, u); \ + else \ + get_now(m, s, u); \ +} while (0) +#else +# define GET_NOW(m, s, u) do {get_now(m, s, u);} while (0) +#endif + + + +static Eterm* patch_ts(Eterm tuple4, Eterm* hp); + +#ifdef ERTS_SMP +static void +do_send_to_port(Eterm to, + Port* unused_port, + Eterm from, + enum ErtsSysMsgType type, + Eterm message) +{ + Uint sz = size_object(message); + ErlHeapFragment *bp = new_message_buffer(sz); + Uint *hp = bp->mem; + Eterm msg = copy_struct(message, sz, &hp, &bp->off_heap); + + enqueue_sys_msg_unlocked(type, from, to, msg, bp); +} + +#define WRITE_SYS_MSG_TO_PORT write_sys_msg_to_port +#else +#define WRITE_SYS_MSG_TO_PORT do_send_to_port +#endif + +static void +WRITE_SYS_MSG_TO_PORT(Eterm unused_to, + Port* trace_port, + Eterm unused_from, + enum ErtsSysMsgType unused_type, + Eterm message) { + byte *buffer; + byte *ptr; + unsigned size; + + size = erts_encode_ext_size(message); + buffer = (byte *) erts_alloc(ERTS_ALC_T_TMP, size); + + ptr = buffer; + + erts_encode_ext(message, &ptr); + if (!(ptr <= buffer+size)) { + erl_exit(1, "Internal error in do_send_to_port: %d\n", ptr-buffer); + } + +#ifndef ERTS_SMP + if (!INVALID_TRACER_PORT(trace_port, trace_port->id)) { +#endif + erts_raw_port_command(trace_port, buffer, ptr-buffer); +#ifndef ERTS_SMP + erts_port_release(trace_port); + } +#endif + + erts_free(ERTS_ALC_T_TMP, (void *) buffer); +} + + +#ifndef ERTS_SMP +/* Send {trace_ts, Pid, out, 0, Timestamp} + * followed by {trace_ts, Pid, in, 0, NewTimestamp} + * + * 'NewTimestamp' is fetched from GET_NOW() through patch_ts(). + */ +static void +do_send_schedfix_to_port(Port *trace_port, Eterm pid, Eterm timestamp) { + Eterm local_heap[4+5+5]; + Eterm message; + Eterm *hp; + Eterm mfarity; + + ASSERT(is_pid(pid)); + ASSERT(is_tuple(timestamp)); + ASSERT(*tuple_val(timestamp) == make_arityval(3)); + + hp = local_heap; + mfarity = make_small(0); + message = TUPLE5(hp, am_trace_ts, pid, am_out, mfarity, timestamp); + /* Note, hp is deliberately NOT incremented since it will be reused */ + + do_send_to_port(trace_port->id, + trace_port, + pid, + SYS_MSG_TYPE_UNDEFINED, + message); + + message = TUPLE4(hp, am_trace_ts, pid, am_in, mfarity); + hp += 5; + hp = patch_ts(message, hp); + + do_send_to_port(trace_port->id, + trace_port, + pid, + SYS_MSG_TYPE_UNDEFINED, + message); +} +#endif + +/* If (c_p != NULL), a fake schedule out/in message pair will be sent, + * if the driver so requests. + * It is assumed that 'message' is not an 'out' message. + * + * 'c_p' is the currently executing process, "tracee" is the traced process + * which 'message' concerns => if (*tracee_flags & F_TIMESTAMP), + * 'message' must contain a timestamp. + */ +static void +send_to_port(Process *c_p, Eterm message, + Eterm *tracer_pid, Uint *tracee_flags) { + Port* trace_port; +#ifndef ERTS_SMP + Eterm ts, local_heap[4], *hp; +#endif + + ASSERT(is_internal_port(*tracer_pid)); +#ifdef ERTS_SMP + if (is_not_internal_port(*tracer_pid)) + return; + + trace_port = NULL; +#else + if (is_not_internal_port(*tracer_pid)) + goto invalid_tracer_port; + + trace_port = &erts_port[internal_port_index(*tracer_pid)]; + + if (INVALID_TRACER_PORT(trace_port, *tracer_pid)) { + invalid_tracer_port: + *tracee_flags &= ~TRACEE_FLAGS; + *tracer_pid = NIL; + return; + } + + /* + * Make a fake schedule only if the current process is traced + * with 'running' and 'timestamp'. + */ + + if ( c_p == NULL || + (! IS_TRACED_FL(c_p, F_TRACE_SCHED | F_TIMESTAMP))) { +#endif + do_send_to_port(*tracer_pid, + trace_port, + c_p ? c_p->id : NIL, + SYS_MSG_TYPE_TRACE, + message); +#ifndef ERTS_SMP + return; + } + + /* + * Note that the process being traced for some type of trace messages + * (e.g. getting_linked) need not be the current process. That other + * process might not have timestamps enabled. + */ + if (*tracee_flags & F_TIMESTAMP) { + ASSERT(is_tuple(message)); + hp = tuple_val(message); + ts = hp[arityval(hp[0])]; + } else { + /* A fake schedule might be needed, + * but this message does not contain a timestamp. + * Create a dummy trace message with timestamp to be + * passed to do_send_schedfix_to_port(). + */ + Uint ms,s,us; + GET_NOW(&ms, &s, &us); + hp = local_heap; + ts = TUPLE3(hp, make_small(ms), make_small(s), make_small(us)); + hp += 4; + } + + trace_port->control_flags &= ~PORT_CONTROL_FLAG_HEAVY; + do_send_to_port(*tracer_pid, + trace_port, + c_p ? c_p->id : NIL, + SYS_MSG_TYPE_TRACE, + message); + + if (trace_port->control_flags & PORT_CONTROL_FLAG_HEAVY) { + /* The driver has just informed us that the last write took a + * non-neglectible amount of time. + * + * We need to fake some trace messages to compensate for the time the + * current process had to sacrifice for the writing of the previous + * trace message. We pretend that the process got scheduled out + * just after writning the real trace message, and now gets scheduled + * in again. + */ + do_send_schedfix_to_port(trace_port, c_p->id, ts); + } +#endif +} + +#ifndef ERTS_SMP +/* Profile send + * Checks if profiler is port or process + * Eterm msg is local, need copying. + */ + +static void +profile_send(Eterm message) { + Uint sz = 0; + ErlHeapFragment *bp = NULL; + Uint *hp = NULL; + Eterm msg = NIL; + Process *profile_p = NULL; + ErlOffHeap *off_heap = NULL; + + Eterm profiler = erts_get_system_profile(); + + if (is_internal_port(profiler)) { + Port *profiler_port = NULL; + + /* not smp */ + + + profiler_port = &erts_port[internal_port_index(profiler)]; + + do_send_to_port(profiler, + profiler_port, + NIL, /* or current process->id */ + SYS_MSG_TYPE_SYSPROF, + message); + + } else { + ASSERT(is_internal_pid(profiler) + && internal_pid_index(profiler) < erts_max_processes); + + profile_p = process_tab[internal_pid_index(profiler)]; + + if (INVALID_PID(profile_p, profiler)) return; + + sz = size_object(message); + hp = erts_alloc_message_heap(sz, &bp, &off_heap, profile_p, 0); + msg = copy_struct(message, sz, &hp, &bp->off_heap); + + erts_queue_message(profile_p, NULL, bp, msg, NIL); + } +} + +#endif + + +/* A fake schedule out/in message pair will be sent, + * if the driver so requests. + * If (timestamp == NIL), one is fetched from GET_NOW(). + * + * 'c_p' is the currently executing process, may be NULL. + */ +static void +seq_trace_send_to_port(Process *c_p, + Eterm seq_tracer, + Eterm message, + Eterm timestamp) +{ + Port* trace_port; +#ifndef ERTS_SMP + Eterm ts, local_heap[4], *hp; +#endif + + ASSERT(is_internal_port(seq_tracer)); +#ifdef ERTS_SMP + if (is_not_internal_port(seq_tracer)) + return; + + trace_port = NULL; +#else + if (is_not_internal_port(seq_tracer)) + goto invalid_tracer_port; + + trace_port = &erts_port[internal_port_index(seq_tracer)]; + + if (INVALID_TRACER_PORT(trace_port, seq_tracer)) { + invalid_tracer_port: + system_seq_tracer = am_false; + return; + } + + if (c_p == NULL + || (! IS_TRACED_FL(c_p, F_TRACE_SCHED | F_TIMESTAMP))) { +#endif + do_send_to_port(seq_tracer, + trace_port, + c_p ? c_p->id : NIL, + SYS_MSG_TYPE_SEQTRACE, + message); + +#ifndef ERTS_SMP + return; + } + /* Make a fake schedule only if the current process is traced + * with 'running' and 'timestamp'. + */ + + if (timestamp != NIL) { + ts = timestamp; + } else { + /* A fake schedule might be needed, + * but this message does not contain a timestamp. + * Create a dummy trace message with timestamp to be + * passed to do_send_schedfix_to_port(). + */ + Uint ms,s,us; + GET_NOW(&ms, &s, &us); + hp = local_heap; + ts = TUPLE3(hp, make_small(ms), make_small(s), make_small(us)); + hp += 4; + } + + trace_port->control_flags &= ~PORT_CONTROL_FLAG_HEAVY; + do_send_to_port(seq_tracer, + trace_port, + c_p ? c_p->id : NIL, + SYS_MSG_TYPE_SEQTRACE, + message); + + if (trace_port->control_flags & PORT_CONTROL_FLAG_HEAVY) { + /* The driver has just informed us that the last write took a + * non-neglectible amount of time. + * + * We need to fake some trace messages to compensate for the time the + * current process had to sacrifice for the writing of the previous + * trace message. We pretend that the process got scheduled out + * just after writing the real trace message, and now gets scheduled + * in again. + */ + do_send_schedfix_to_port(trace_port, c_p->id, ts); + } +#endif +} + +#define TS_HEAP_WORDS 5 +#define TS_SIZE(p) (((p)->trace_flags & F_TIMESTAMP) ? TS_HEAP_WORDS : 0) + +/* + * Patch a timestamp into a tuple. The tuple must be the last thing + * built on the heap. + * + * Returns the new hp pointer. +*/ +static Eterm* +patch_ts(Eterm tuple, Eterm* hp) +{ + Uint ms, s, us; + Eterm* ptr = tuple_val(tuple); + int arity = arityval(*ptr); + + ASSERT((ptr+arity+1) == hp); + ptr[0] = make_arityval(arity+1); + ptr[1] = am_trace_ts; + GET_NOW(&ms, &s, &us); + *hp = TUPLE3(hp+1, make_small(ms), make_small(s), make_small(us)); + return hp+5; +} + +static ERTS_INLINE void +send_to_tracer(Process *tracee, + ERTS_TRACER_REF_TYPE tracer_ref, + Eterm msg, + Eterm **hpp, + ErlHeapFragment *bp, + int no_fake_sched) +{ + ERTS_SMP_LC_ASSERT(erts_proc_lc_my_proc_locks(tracee)); + + erts_smp_mtx_lock(&smq_mtx); + + if (tracee->trace_flags & F_TIMESTAMP) + *hpp = patch_ts(msg, *hpp); + + if (is_internal_pid(tracee->tracer_proc)) + ERTS_ENQ_TRACE_MSG(tracee->id, tracer_ref, msg, bp); + else { + ASSERT(is_internal_port(tracee->tracer_proc)); + send_to_port(no_fake_sched ? NULL : tracee, + msg, + &tracee->tracer_proc, + &tracee->trace_flags); + } + + erts_smp_mtx_unlock(&smq_mtx); + +} + +static void +trace_sched_aux(Process *p, Eterm what, int never_fake_sched) +{ + Eterm local_heap[5+4+1+TS_HEAP_WORDS]; + Eterm tmp, mess, *hp; + ErlHeapFragment *bp = NULL; + ErlOffHeap *off_heap; + ERTS_TRACER_REF_TYPE tracer_ref = ERTS_NULL_TRACER_REF; + int sched_no, curr_func, to_port, no_fake_sched; + + if (is_nil(p->tracer_proc)) + return; + + no_fake_sched = never_fake_sched; + + switch (what) { + case am_out: + case am_out_exiting: + case am_out_exited: + no_fake_sched = 1; + break; + case am_in: + case am_in_exiting: + break; + default: + ASSERT(0); + break; + } + + sched_no = IS_TRACED_FL(p, F_TRACE_SCHED_NO); + to_port = is_internal_port(p->tracer_proc); + + if (!to_port) { + ASSERT(is_internal_pid(p->tracer_proc) + && internal_pid_index(p->tracer_proc) < erts_max_processes); + + ERTS_GET_TRACER_REF(tracer_ref, p->tracer_proc, p->trace_flags); + } + + if (ERTS_PROC_IS_EXITING(p) +#ifndef ERTS_SMP + || p->status == P_FREE +#endif + ) { + curr_func = 0; + } + else { + if (!p->current) + p->current = find_function_from_pc(p->i); + curr_func = p->current != NULL; + } + + if (to_port) + hp = &local_heap[0]; + else { + Uint size = 5; + if (curr_func) + size += 4; + if (sched_no) + size += 1; + size += TS_SIZE(p); + hp = ERTS_ALLOC_SYSMSG_HEAP(size, &bp, &off_heap, tracer_ref); + } + + if (!curr_func) { + tmp = make_small(0); + } else { + tmp = TUPLE3(hp,p->current[0],p->current[1],make_small(p->current[2])); + hp += 4; + } + + if (!sched_no) { + mess = TUPLE4(hp, am_trace, p->id, what, tmp); + hp += 5; + } + else { +#ifdef ERTS_SMP + Eterm sched_id = make_small(p->scheduler_data->no); +#else + Eterm sched_id = make_small(1); +#endif + mess = TUPLE5(hp, am_trace, p->id, what, sched_id, tmp); + hp += 6; + } + + send_to_tracer(p, tracer_ref, mess, &hp, bp, no_fake_sched); +} + +/* Send {trace_ts, Pid, What, {Mod, Func, Arity}, Timestamp} + * or {trace, Pid, What, {Mod, Func, Arity}} + * + * where 'What' is supposed to be 'in', 'out', 'in_exiting', + * 'out_exiting', or 'out_exited'. + */ +void +trace_sched(Process *p, Eterm what) +{ + trace_sched_aux(p, what, 0); +} + +/* Send {trace_ts, Pid, Send, Msg, DestPid, Timestamp} + * or {trace, Pid, Send, Msg, DestPid} + * + * where 'Send' is 'send' or 'send_to_non_existing_process'. + */ +void +trace_send(Process *p, Eterm to, Eterm msg) +{ + Eterm operation; + unsigned sz_msg; + unsigned sz_to; + Eterm* hp; + Eterm mess; + + if (!ARE_TRACE_FLAGS_ON(p, F_TRACE_SEND)) { + return; + } + + operation = am_send; + if (is_internal_pid(to)) { + if (!erts_pid2proc(p, ERTS_PROC_LOCK_MAIN, to, 0)) + goto send_to_non_existing_process; + } + else if(is_external_pid(to) + && external_pid_dist_entry(to) == erts_this_dist_entry) { + char *s; + send_to_non_existing_process: + s = "send_to_non_existing_process"; + operation = am_atom_put(s, sys_strlen(s)); + } + + if (is_internal_port(p->tracer_proc)) { + Eterm local_heap[11]; + hp = local_heap; + mess = TUPLE5(hp, am_trace, p->id, operation, msg, to); + hp += 6; + erts_smp_mtx_lock(&smq_mtx); + if (p->trace_flags & F_TIMESTAMP) { + hp = patch_ts(mess, hp); + } + send_to_port(p, mess, &p->tracer_proc, &p->trace_flags); + erts_smp_mtx_unlock(&smq_mtx); + } else { + Uint need; + ErlHeapFragment *bp; + ErlOffHeap *off_heap; + ERTS_TRACER_REF_TYPE tracer_ref; + + ASSERT(is_internal_pid(p->tracer_proc) + && internal_pid_index(p->tracer_proc) < erts_max_processes); + + ERTS_GET_TRACER_REF(tracer_ref, p->tracer_proc, p->trace_flags); + + sz_msg = size_object(msg); + sz_to = size_object(to); + need = sz_msg + sz_to + 6 + TS_SIZE(p); + + hp = ERTS_ALLOC_SYSMSG_HEAP(need, &bp, &off_heap, tracer_ref); + + to = copy_struct(to, + sz_to, + &hp, + off_heap); + msg = copy_struct(msg, + sz_msg, + &hp, + off_heap); + mess = TUPLE5(hp, am_trace, p->id/* Local pid */, operation, msg, to); + hp += 6; + + erts_smp_mtx_lock(&smq_mtx); + + if (p->trace_flags & F_TIMESTAMP) { + patch_ts(mess, hp); + } + + ERTS_ENQ_TRACE_MSG(p->id, tracer_ref, mess, bp); + erts_smp_mtx_unlock(&smq_mtx); + } +} + +/* Send {trace_ts, Pid, receive, Msg, Timestamp} + * or {trace, Pid, receive, Msg} + */ +void +trace_receive(Process *rp, Eterm msg) +{ + Eterm mess; + size_t sz_msg; + Eterm* hp; + + if (is_internal_port(rp->tracer_proc)) { + Eterm local_heap[10]; + hp = local_heap; + mess = TUPLE4(hp, am_trace, rp->id, am_receive, msg); + hp += 5; + erts_smp_mtx_lock(&smq_mtx); + if (rp->trace_flags & F_TIMESTAMP) { + hp = patch_ts(mess, hp); + } + send_to_port(rp, mess, &rp->tracer_proc, &rp->trace_flags); + erts_smp_mtx_unlock(&smq_mtx); + } else { + Uint hsz; + ErlHeapFragment *bp; + ErlOffHeap *off_heap; + ERTS_TRACER_REF_TYPE tracer_ref; + + ASSERT(is_internal_pid(rp->tracer_proc) + && internal_pid_index(rp->tracer_proc) < erts_max_processes); + + ERTS_GET_TRACER_REF(tracer_ref, rp->tracer_proc, rp->trace_flags); + + sz_msg = size_object(msg); + + hsz = sz_msg + 5 + TS_SIZE(rp); + + hp = ERTS_ALLOC_SYSMSG_HEAP(hsz, &bp, &off_heap, tracer_ref); + + msg = copy_struct(msg, sz_msg, &hp, off_heap); + mess = TUPLE4(hp, am_trace, rp->id/* Local pid */, am_receive, msg); + hp += 5; + + erts_smp_mtx_lock(&smq_mtx); + + if (rp->trace_flags & F_TIMESTAMP) { + patch_ts(mess, hp); + } + + ERTS_ENQ_TRACE_MSG(rp->id, tracer_ref, mess, bp); + erts_smp_mtx_unlock(&smq_mtx); + } +} + +int +seq_trace_update_send(Process *p) +{ + Eterm seq_tracer = erts_get_system_seq_tracer(); + ASSERT((is_tuple(SEQ_TRACE_TOKEN(p)) || is_nil(SEQ_TRACE_TOKEN(p)))); + if ( (p->id == seq_tracer) || (SEQ_TRACE_TOKEN(p) == NIL)) + return 0; + + SEQ_TRACE_TOKEN_SENDER(p) = p->id; /* Internal pid */ + SEQ_TRACE_TOKEN_SERIAL(p) = + make_small(++(p -> seq_trace_clock)); + SEQ_TRACE_TOKEN_LASTCNT(p) = + make_small(p -> seq_trace_lastcnt); + return 1; +} + + +/* Send a sequential trace message to the sequential tracer. + * p is the caller (which contains the trace token), + * msg is the original message, type is trace type (SEQ_TRACE_SEND etc), + * and receiver is the receiver of the message. + * + * The message to be received by the sequential tracer is: + * + * TraceMsg = + * {seq_trace, Label, {Type, {Lastcnt, Serial}, Sender, Receiver, Msg} [,Timestamp] } + * + */ +void +seq_trace_output_generic(Eterm token, Eterm msg, Uint type, + Eterm receiver, Process *process, Eterm exitfrom) +{ + Eterm mess; + ErlHeapFragment* bp; + Eterm* hp; + Eterm label; + Eterm lastcnt_serial; + Eterm type_atom; + int sz_exit; + Eterm seq_tracer; + + seq_tracer = erts_get_system_seq_tracer(); + + ASSERT(is_tuple(token) || is_nil(token)); + if (SEQ_TRACE_T_SENDER(token) == seq_tracer || token == NIL || + (process && process->trace_flags & F_SENSITIVE)) { + return; + } + + switch (type) { + case SEQ_TRACE_SEND: type_atom = am_send; break; + case SEQ_TRACE_PRINT: type_atom = am_print; break; + case SEQ_TRACE_RECEIVE: type_atom = am_receive; break; + default: + erl_exit(1, "invalid type in seq_trace_output_generic: %d:\n", type); + return; /* To avoid warning */ + } + + if ((unsigned_val(SEQ_TRACE_T_FLAGS(token)) & type) == 0) { + /* No flags set, nothing to do */ + return; + } + + if (seq_tracer == am_false) { + return; /* no need to send anything */ + } + + if (is_internal_port(seq_tracer)) { + Eterm local_heap[64]; + hp = local_heap; + label = SEQ_TRACE_T_LABEL(token); + lastcnt_serial = TUPLE2(hp, SEQ_TRACE_T_LASTCNT(token), + SEQ_TRACE_T_SERIAL(token)); + hp += 3; + if (exitfrom != NIL) { + msg = TUPLE3(hp, am_EXIT, exitfrom, msg); + hp += 4; + } + mess = TUPLE5(hp, type_atom, lastcnt_serial, SEQ_TRACE_T_SENDER(token), + receiver, msg); + hp += 6; + erts_smp_mtx_lock(&smq_mtx); + if ((unsigned_val(SEQ_TRACE_T_FLAGS(token)) & SEQ_TRACE_TIMESTAMP) == 0) { + mess = TUPLE3(hp, am_seq_trace, label, mess); + seq_trace_send_to_port(NULL, seq_tracer, mess, NIL); + } else { + Uint ms,s,us,ts; + GET_NOW(&ms, &s, &us); + ts = TUPLE3(hp, make_small(ms),make_small(s), make_small(us)); + hp += 4; + mess = TUPLE4(hp, am_seq_trace, label, mess, ts); + seq_trace_send_to_port(process, seq_tracer, mess, ts); + } + erts_smp_mtx_unlock(&smq_mtx); + } else { +#ifndef ERTS_SMP + Process* tracer; +#endif + Eterm sender_copy; + Eterm receiver_copy; + Eterm m2; + Uint sz_label, sz_lastcnt_serial, sz_msg, sz_ts, sz_sender, + sz_exitfrom, sz_receiver; + + ASSERT(is_internal_pid(seq_tracer) + && internal_pid_index(seq_tracer) < erts_max_processes); + +#ifndef ERTS_SMP + + tracer = process_tab[internal_pid_index(seq_tracer)]; + if (INVALID_PID(tracer, tracer->id)) { + system_seq_tracer = am_false; + return; /* no need to send anything */ + } +#endif + if (receiver == seq_tracer) { + return; /* no need to send anything */ + } + + sz_label = size_object(SEQ_TRACE_T_LABEL(token)); + sz_sender = size_object(SEQ_TRACE_T_SENDER(token)); + sz_receiver = size_object(receiver); + sz_lastcnt_serial = 3; /* TUPLE2 */ + sz_msg = size_object(msg); + + sz_ts = ((unsigned_val(SEQ_TRACE_T_FLAGS(token)) & SEQ_TRACE_TIMESTAMP) ? + 5 : 0); + if (exitfrom != NIL) { + sz_exit = 4; /* create {'EXIT',exitfrom,msg} */ + sz_exitfrom = size_object(exitfrom); + } + else { + sz_exit = 0; + sz_exitfrom = 0; + } + bp = new_message_buffer(4 /* TUPLE3 */ + sz_ts + 6 /* TUPLE5 */ + + sz_lastcnt_serial + sz_label + sz_msg + + sz_exit + sz_exitfrom + + sz_sender + sz_receiver); + hp = bp->mem; + label = copy_struct(SEQ_TRACE_T_LABEL(token), sz_label, &hp, &bp->off_heap); + lastcnt_serial = TUPLE2(hp,SEQ_TRACE_T_LASTCNT(token),SEQ_TRACE_T_SERIAL(token)); + hp += 3; + m2 = copy_struct(msg, sz_msg, &hp, &bp->off_heap); + if (sz_exit) { + Eterm exitfrom_copy = copy_struct(exitfrom, + sz_exitfrom, + &hp, + &bp->off_heap); + m2 = TUPLE3(hp, am_EXIT, exitfrom_copy, m2); + hp += 4; + } + sender_copy = copy_struct(SEQ_TRACE_T_SENDER(token), + sz_sender, + &hp, + &bp->off_heap); + receiver_copy = copy_struct(receiver, + sz_receiver, + &hp, + &bp->off_heap); + mess = TUPLE5(hp, + type_atom, + lastcnt_serial, + sender_copy, + receiver_copy, + m2); + hp += 6; + + erts_smp_mtx_lock(&smq_mtx); + + if (sz_ts) {/* timestamp should be included */ + Uint ms,s,us,ts; + GET_NOW(&ms, &s, &us); + ts = TUPLE3(hp, make_small(ms),make_small(s), make_small(us)); + hp += 4; + mess = TUPLE4(hp, am_seq_trace, label, mess, ts); + } else { + mess = TUPLE3(hp, am_seq_trace, label, mess); + } + +#ifdef ERTS_SMP + enqueue_sys_msg_unlocked(SYS_MSG_TYPE_SEQTRACE, NIL, NIL, mess, bp); + erts_smp_mtx_unlock(&smq_mtx); +#else + erts_queue_message(tracer, NULL, bp, mess, NIL); /* trace_token must be NIL here */ +#endif + } +} + +/* Send {trace_ts, Pid, return_to, {Mod, Func, Arity}, Timestamp} + * or {trace, Pid, return_to, {Mod, Func, Arity}} + */ +void +erts_trace_return_to(Process *p, Uint *pc) +{ + Eterm* hp; + Eterm mfa; + Eterm mess; + Eterm local_heap[4+5+5]; + + Eterm *code_ptr = find_function_from_pc(pc); + + hp = local_heap; + + if (!code_ptr) { + mfa = am_undefined; + } else { + mfa = TUPLE3(hp, code_ptr[0], code_ptr[1], make_small(code_ptr[2])); + hp += 4; + } + + mess = TUPLE4(hp, am_trace, p->id, am_return_to, mfa); + hp += 5; + + erts_smp_mtx_lock(&smq_mtx); + + if (p->trace_flags & F_TIMESTAMP) { + hp = patch_ts(mess, hp); + } + + if (is_internal_port(p->tracer_proc)) { + send_to_port(p, mess, &p->tracer_proc, &p->trace_flags); + } else { + ErlHeapFragment *bp; + ErlOffHeap *off_heap; + ERTS_TRACER_REF_TYPE tracer_ref; + unsigned size; + + /* + * Find the tracer. + */ + ASSERT(is_internal_pid(p->tracer_proc) + && internal_pid_index(p->tracer_proc) < erts_max_processes); + + ERTS_GET_TRACER_REF(tracer_ref, p->tracer_proc, p->trace_flags); + + size = size_object(mess); + + hp = ERTS_ALLOC_SYSMSG_HEAP(size, &bp, &off_heap, tracer_ref); + + /* + * Copy the trace message into the buffer and enqueue it. + */ + mess = copy_struct(mess, size, &hp, off_heap); + ERTS_ENQ_TRACE_MSG(p->id, tracer_ref, mess, bp); + } + erts_smp_mtx_unlock(&smq_mtx); +} + + +/* Send {trace_ts, Pid, return_from, {Mod, Name, Arity}, Retval, Timestamp} + * or {trace, Pid, return_from, {Mod, Name, Arity}, Retval} + */ +void +erts_trace_return(Process* p, Eterm* fi, Eterm retval, Eterm *tracer_pid) +{ + Eterm* hp; + Eterm mfa; + Eterm mess; + Eterm mod, name; + int arity; + Uint meta_flags, *tracee_flags; +#ifdef ERTS_SMP + Eterm tracee; +#endif + + ASSERT(tracer_pid); + if (*tracer_pid == am_true) { + /* Breakpoint trace enabled without specifying tracer => + * use process tracer and flags + */ + tracer_pid = &p->tracer_proc; + } + if (is_nil(*tracer_pid)) { + /* Trace disabled */ + return; + } + ASSERT(is_internal_pid(*tracer_pid) || is_internal_port(*tracer_pid)); + if (*tracer_pid == p->id) { + /* Do not generate trace messages to oneself */ + return; + } + if (tracer_pid == &p->tracer_proc) { + /* Tracer specified in process structure => + * non-breakpoint trace => + * use process flags + */ + tracee_flags = &p->trace_flags; +#ifdef ERTS_SMP + tracee = p->id; +#endif + } else { + /* Tracer not specified in process structure => + * tracer specified in breakpoint => + * meta trace => + * use fixed flag set instead of process flags + */ + meta_flags = F_TRACE_CALLS | F_TIMESTAMP; + tracee_flags = &meta_flags; +#ifdef ERTS_SMP + tracee = NIL; +#endif + } + if (! (*tracee_flags & F_TRACE_CALLS)) { + return; + } + + mod = fi[0]; + name = fi[1]; + arity = fi[2]; + + if (is_internal_port(*tracer_pid)) { + Eterm local_heap[4+6+5]; + hp = local_heap; + mfa = TUPLE3(hp, mod, name, make_small(arity)); + hp += 4; + mess = TUPLE5(hp, am_trace, p->id, am_return_from, mfa, retval); + hp += 6; + erts_smp_mtx_lock(&smq_mtx); + if (*tracee_flags & F_TIMESTAMP) { + hp = patch_ts(mess, hp); + } + send_to_port(p, mess, tracer_pid, tracee_flags); + erts_smp_mtx_unlock(&smq_mtx); + } else { + ErlHeapFragment *bp; + ErlOffHeap *off_heap; + ERTS_TRACER_REF_TYPE tracer_ref; + unsigned size; + unsigned retval_size; +#ifdef DEBUG + Eterm* limit; +#endif + + ASSERT(is_internal_pid(*tracer_pid) + && internal_pid_index(*tracer_pid) < erts_max_processes); + + ERTS_GET_TRACER_REF(tracer_ref, *tracer_pid, *tracee_flags); + + retval_size = size_object(retval); + size = 6 + 4 + retval_size; + if (*tracee_flags & F_TIMESTAMP) { + size += 1+4; + } + + hp = ERTS_ALLOC_SYSMSG_HEAP(size, &bp, &off_heap, tracer_ref); +#ifdef DEBUG + limit = hp + size; +#endif + + /* + * Build the trace tuple and put it into receive queue of the tracer process. + */ + + mfa = TUPLE3(hp, mod, name, make_small(arity)); + hp += 4; + retval = copy_struct(retval, retval_size, &hp, off_heap); + mess = TUPLE5(hp, am_trace, p->id/* Local pid */, am_return_from, mfa, retval); + hp += 6; + + erts_smp_mtx_lock(&smq_mtx); + + if (*tracee_flags & F_TIMESTAMP) { + hp = patch_ts(mess, hp); + } + + ASSERT(hp == limit); + + ERTS_ENQ_TRACE_MSG(tracee, tracer_ref, mess, bp); + erts_smp_mtx_unlock(&smq_mtx); + } +} + +/* Send {trace_ts, Pid, exception_from, {Mod, Name, Arity}, {Class,Value}, + * Timestamp} + * or {trace, Pid, exception_from, {Mod, Name, Arity}, {Class,Value}, + * Timestamp} + * + * Where Class is atomic but Value is any term. + */ +void +erts_trace_exception(Process* p, Eterm mfa[3], Eterm class, Eterm value, + Eterm *tracer_pid) +{ + Eterm* hp; + Eterm mfa_tuple; + Eterm cv; + Eterm mess; + Uint meta_flags, *tracee_flags; +#ifdef ERTS_SMP + Eterm tracee; +#endif + + ASSERT(tracer_pid); + if (*tracer_pid == am_true) { + /* Breakpoint trace enabled without specifying tracer => + * use process tracer and flags + */ + tracer_pid = &p->tracer_proc; + } + if (is_nil(*tracer_pid)) { + /* Trace disabled */ + return; + } + ASSERT(is_internal_pid(*tracer_pid) || is_internal_port(*tracer_pid)); + if (*tracer_pid == p->id) { + /* Do not generate trace messages to oneself */ + return; + } + if (tracer_pid == &p->tracer_proc) { + /* Tracer specified in process structure => + * non-breakpoint trace => + * use process flags + */ + tracee_flags = &p->trace_flags; +#ifdef ERTS_SMP + tracee = p->id; +#endif + if (! (*tracee_flags & F_TRACE_CALLS)) { + return; + } + } else { + /* Tracer not specified in process structure => + * tracer specified in breakpoint => + * meta trace => + * use fixed flag set instead of process flags + */ + meta_flags = F_TRACE_CALLS | F_TIMESTAMP; + tracee_flags = &meta_flags; +#ifdef ERTS_SMP + tracee = NIL; +#endif + } + + if (is_internal_port(*tracer_pid)) { + Eterm local_heap[4+3+6+5]; + hp = local_heap; + mfa_tuple = TUPLE3(hp, mfa[0], mfa[1], make_small(mfa[2])); + hp += 4; + cv = TUPLE2(hp, class, value); + hp += 3; + mess = TUPLE5(hp, am_trace, p->id, am_exception_from, mfa_tuple, cv); + hp += 6; + ASSERT((hp - local_heap)*sizeof(*hp) <= sizeof(local_heap)); + erts_smp_mtx_lock(&smq_mtx); + if (*tracee_flags & F_TIMESTAMP) { + hp = patch_ts(mess, hp); /* hp += 5 */ + ASSERT((hp - local_heap)*sizeof(*hp) == sizeof(local_heap)); + } + send_to_port(p, mess, tracer_pid, tracee_flags); + erts_smp_mtx_unlock(&smq_mtx); + } else { + ErlHeapFragment *bp; + ErlOffHeap *off_heap; + ERTS_TRACER_REF_TYPE tracer_ref; + unsigned size; + unsigned value_size; +#ifdef DEBUG + Eterm* limit; +#endif + + ASSERT(is_internal_pid(*tracer_pid) + && internal_pid_index(*tracer_pid) < erts_max_processes); + + ERTS_GET_TRACER_REF(tracer_ref, *tracer_pid, *tracee_flags); + + value_size = size_object(value); + size = 6 + 4 + 3 + value_size; + if (*tracee_flags & F_TIMESTAMP) { + size += 1+4; + } + + hp = ERTS_ALLOC_SYSMSG_HEAP(size, &bp, &off_heap, tracer_ref); +#ifdef DEBUG + limit = hp + size; +#endif + + /* + * Build the trace tuple and put it into receive queue of the tracer process. + */ + + mfa_tuple = TUPLE3(hp, mfa[0], mfa[1], make_small(mfa[2])); + hp += 4; + value = copy_struct(value, value_size, &hp, off_heap); + cv = TUPLE2(hp, class, value); + hp += 3; + mess = TUPLE5(hp, am_trace, p->id/* Local pid */, + am_exception_from, mfa_tuple, cv); + hp += 6; + + erts_smp_mtx_lock(&smq_mtx); + + if (*tracee_flags & F_TIMESTAMP) { + hp = patch_ts(mess, hp); + } + + ASSERT(hp == limit); + + ERTS_ENQ_TRACE_MSG(tracee, tracer_ref, mess, bp); + erts_smp_mtx_unlock(&smq_mtx); + } +} + +/* + * This function implements the new call trace. + * + * Send {trace_ts, Pid, call, {Mod, Func, A}, PamResult, Timestamp} + * or {trace_ts, Pid, call, {Mod, Func, A}, Timestamp} + * or {trace, Pid, call, {Mod, Func, A}, PamResult} + * or {trace, Pid, call, {Mod, Func, A} + * + * where 'A' is arity or argument list depending on trace flag 'arity'. + * + * If *tracer_pid is am_true, it is a breakpoint trace that shall use + * the process tracer, if it is NIL no trace message is generated, + * if it is a pid or port we do a meta trace. + */ +Uint32 +erts_call_trace(Process* p, Eterm mfa[3], Binary *match_spec, + Eterm* args, int local, Eterm *tracer_pid) +{ + Eterm* hp; + Eterm mfa_tuple; + int arity; + int i; + Uint32 return_flags; + Eterm pam_result = am_true; + Eterm mess; + Uint meta_flags, *tracee_flags; +#ifdef ERTS_SMP + Eterm tracee; +#endif + Eterm transformed_args[MAX_ARG]; + ErlSubBin sub_bin_heap; + + ASSERT(tracer_pid); + if (*tracer_pid == am_true) { + /* Breakpoint trace enabled without specifying tracer => + * use process tracer and flags + */ + tracer_pid = &p->tracer_proc; + } + if (is_nil(*tracer_pid)) { + /* Trace disabled */ + return 0; + } + ASSERT(is_internal_pid(*tracer_pid) || is_internal_port(*tracer_pid)); + if (*tracer_pid == p->id) { + /* Do not generate trace messages to oneself */ + return 0; + } + if (tracer_pid == &p->tracer_proc) { + /* Tracer specified in process structure => + * non-breakpoint trace => + * use process flags + */ + tracee_flags = &p->trace_flags; +#ifdef ERTS_SMP + tracee = p->id; +#endif + } else { + /* Tracer not specified in process structure => + * tracer specified in breakpoint => + * meta trace => + * use fixed flag set instead of process flags + */ + if (p->trace_flags & F_SENSITIVE) { + /* No trace messages for sensitive processes. */ + return 0; + } + meta_flags = F_TRACE_CALLS | F_TIMESTAMP; + tracee_flags = &meta_flags; +#ifdef ERTS_SMP + tracee = NIL; +#endif + } + + /* + * Because of the delayed sub-binary creation optimization introduced in + * R12B, (at most) one of arguments can be a match context instead of + * a binary. Since we don't want to handle match contexts in utility functions + * such as size_object() and copy_struct(), we must make sure that we + * temporarily convert any match contexts to sub binaries. + */ + arity = mfa[2]; +#ifdef DEBUG + sub_bin_heap.thing_word = 0; +#endif + for (i = 0; i < arity; i++) { + Eterm arg = args[i]; + if (is_boxed(arg) && header_is_bin_matchstate(*boxed_val(arg))) { + ErlBinMatchState* ms = (ErlBinMatchState *) boxed_val(arg); + ErlBinMatchBuffer* mb = &ms->mb; + ErlSubBin* sb = &sub_bin_heap; + Uint bit_size; + + ASSERT(sub_bin_heap.thing_word == 0); /* At most one of match context */ + + bit_size = mb->size - mb->offset; + sb->thing_word = HEADER_SUB_BIN; + sb->size = BYTE_OFFSET(bit_size); + sb->bitsize = BIT_OFFSET(bit_size); + sb->offs = BYTE_OFFSET(mb->offset); + sb->bitoffs = BIT_OFFSET(mb->offset); + sb->is_writable = 0; + sb->orig = mb->orig; + + arg = make_binary(sb); + } + transformed_args[i] = arg; + } + args = transformed_args; + + if (is_internal_port(*tracer_pid)) { + Eterm local_heap[64+MAX_ARG]; + hp = local_heap; + + if (!erts_is_valid_tracer_port(*tracer_pid)) { +#ifdef ERTS_SMP + ASSERT(is_nil(tracee) || tracer_pid == &p->tracer_proc); + if (is_not_nil(tracee)) + erts_smp_proc_lock(p, ERTS_PROC_LOCKS_ALL_MINOR); +#endif + *tracee_flags &= ~TRACEE_FLAGS; + *tracer_pid = NIL; +#ifdef ERTS_SMP + if (is_not_nil(tracee)) + erts_smp_proc_unlock(p, ERTS_PROC_LOCKS_ALL_MINOR); +#endif + return 0; + } + + /* + * If there is a PAM program, run it. Return if it fails. + * + * Some precedence rules: + * + * - No proc flags, e.g 'silent' or 'return_to' + * has any effect on meta trace. + * - The 'silent' process trace flag silences all call + * related messages, e.g 'call', 'return_to' and 'return_from'. + * - The {message,_} PAM function does not affect {return_trace}. + * - The {message,false} PAM function shall give the same + * 'call' trace message as no PAM match. + * - The {message,true} PAM function shall give the same + * 'call' trace message as a nonexistent PAM program. + */ + + /* BEGIN this code should be the same for port and pid trace */ + return_flags = 0; + if (match_spec) { + pam_result = erts_match_set_run(p, match_spec, args, arity, + &return_flags); + if (is_non_value(pam_result)) { + erts_match_set_release_result(p); + return 0; + } + } + if (tracee_flags == &meta_flags) { + /* Meta trace */ + if (pam_result == am_false) { + erts_match_set_release_result(p); + return return_flags; + } + } else { + /* Non-meta trace */ + if (*tracee_flags & F_TRACE_SILENT) { + erts_match_set_release_result(p); + return 0; + } + if (pam_result == am_false) { + erts_match_set_release_result(p); + return return_flags; + } + if (local && (*tracee_flags & F_TRACE_RETURN_TO)) { + return_flags |= MATCH_SET_RETURN_TO_TRACE; + } + } + /* END this code should be the same for port and pid trace */ + + /* + * Build the the {M,F,A} tuple in the local heap. + * (A is arguments or arity.) + */ + + if (*tracee_flags & F_TRACE_ARITY_ONLY) { + mfa_tuple = make_small(arity); + } else { + mfa_tuple = NIL; + for (i = arity-1; i >= 0; i--) { + mfa_tuple = CONS(hp, args[i], mfa_tuple); + hp += 2; + } + } + mfa_tuple = TUPLE3(hp, mfa[0], mfa[1], mfa_tuple); + hp += 4; + + /* + * Build the trace tuple and send it to the port. + */ + + mess = TUPLE4(hp, am_trace, p->id, am_call, mfa_tuple); + hp += 5; + if (pam_result != am_true) { + hp[-5] = make_arityval(5); + *hp++ = pam_result; + } + erts_smp_mtx_lock(&smq_mtx); + if (*tracee_flags & F_TIMESTAMP) { + hp = patch_ts(mess, hp); + } + send_to_port(p, mess, tracer_pid, tracee_flags); + erts_smp_mtx_unlock(&smq_mtx); + erts_match_set_release_result(p); + return *tracer_pid == NIL ? 0 : return_flags; + + } else { + ErlHeapFragment *bp; + ErlOffHeap *off_heap; + Process *tracer; + ERTS_TRACER_REF_TYPE tracer_ref; +#ifdef ERTS_SMP + Eterm tpid; +#endif + unsigned size; + unsigned sizes[MAX_ARG]; + unsigned pam_result_size = 0; + int invalid_tracer; +#ifdef DEBUG + Eterm* limit; +#endif + + ASSERT(is_internal_pid(*tracer_pid) + && internal_pid_index(*tracer_pid) < erts_max_processes); + + tracer = erts_pid2proc(p, ERTS_PROC_LOCK_MAIN, + *tracer_pid, ERTS_PROC_LOCK_STATUS); + if (!tracer) + invalid_tracer = 1; + else { + invalid_tracer = (tracer->trace_flags & F_TRACER) == 0; + erts_smp_proc_unlock(tracer, ERTS_PROC_LOCK_STATUS); + } + + if (invalid_tracer) { +#ifdef ERTS_SMP + ASSERT(is_nil(tracee) || tracer_pid == &p->tracer_proc); + if (is_not_nil(tracee)) + erts_smp_proc_lock(p, ERTS_PROC_LOCKS_ALL_MINOR); +#endif + *tracee_flags &= ~TRACEE_FLAGS; + *tracer_pid = NIL; +#ifdef ERTS_SMP + if (is_not_nil(tracee)) + erts_smp_proc_unlock(p, ERTS_PROC_LOCKS_ALL_MINOR); +#endif + return 0; + } + +#ifdef ERTS_SMP + tpid = *tracer_pid; /* Need to save tracer pid, + since *tracer_pid might + be reset by erts_match_set_run() */ + tracer_ref = tpid; +#else + tracer_ref = tracer; +#endif + + /* + * If there is a PAM program, run it. Return if it fails. + * + * See the rules above in the port trace code. + */ + + /* BEGIN this code should be the same for port and pid trace */ + return_flags = 0; + if (match_spec) { + pam_result = erts_match_set_run(p, match_spec, args, arity, + &return_flags); + if (is_non_value(pam_result)) { + erts_match_set_release_result(p); + return 0; + } + } + if (tracee_flags == &meta_flags) { + /* Meta trace */ + if (pam_result == am_false) { + erts_match_set_release_result(p); + return return_flags; + } + } else { + /* Non-meta trace */ + if (*tracee_flags & F_TRACE_SILENT) { + erts_match_set_release_result(p); + return 0; + } + if (pam_result == am_false) { + erts_match_set_release_result(p); + return return_flags; + } + if (local && (*tracee_flags & F_TRACE_RETURN_TO)) { + return_flags |= MATCH_SET_RETURN_TO_TRACE; + } + } + /* END this code should be the same for port and pid trace */ + + /* + * Calculate number of words needed on heap. + */ + + size = 4 + 5; /* Trace tuple + MFA tuple. */ + if (! (*tracee_flags & F_TRACE_ARITY_ONLY)) { + size += 2*arity; + for (i = arity-1; i >= 0; i--) { + sizes[i] = size_object(args[i]); + size += sizes[i]; + } + } + if (*tracee_flags & F_TIMESTAMP) { + size += 1 + 4; + /* One element in trace tuple + timestamp tuple. */ + } + if (pam_result != am_true) { + pam_result_size = size_object(pam_result); + size += 1 + pam_result_size; + /* One element in trace tuple + term size. */ + } + + hp = ERTS_ALLOC_SYSMSG_HEAP(size, &bp, &off_heap, tracer_ref); +#ifdef DEBUG + limit = hp + size; +#endif + + /* + * Build the the {M,F,A} tuple in the message buffer. + * (A is arguments or arity.) + */ + + if (*tracee_flags & F_TRACE_ARITY_ONLY) { + mfa_tuple = make_small(arity); + } else { + mfa_tuple = NIL; + for (i = arity-1; i >= 0; i--) { + Eterm term = copy_struct(args[i], sizes[i], &hp, off_heap); + mfa_tuple = CONS(hp, term, mfa_tuple); + hp += 2; + } + } + mfa_tuple = TUPLE3(hp, mfa[0], mfa[1], mfa_tuple); + hp += 4; + + /* + * Copy the PAM result (if any) onto the heap. + */ + + if (pam_result != am_true) { + pam_result = copy_struct(pam_result, pam_result_size, &hp, off_heap); + } + + erts_match_set_release_result(p); + + /* + * Build the trace tuple and enqueue it. + */ + + mess = TUPLE4(hp, am_trace, p->id/* Local pid */, am_call, mfa_tuple); + hp += 5; + if (pam_result != am_true) { + hp[-5] = make_arityval(5); + *hp++ = pam_result; + } + + erts_smp_mtx_lock(&smq_mtx); + + if (*tracee_flags & F_TIMESTAMP) { + hp = patch_ts(mess, hp); + } + + ASSERT(hp == limit); + ERTS_ENQ_TRACE_MSG(tracee, tracer_ref, mess, bp); + erts_smp_mtx_unlock(&smq_mtx); + return return_flags; + } +} + +/* Sends trace message: + * {trace_ts, ProcessPid, What, Data, Timestamp} + * or {trace, ProcessPid, What, Data} + * + * 'what' must be atomic, 'data' may be a deep term. + * 'c_p' is the currently executing process, may be NULL. + * 't_p' is the traced process. + */ +void +trace_proc(Process *c_p, Process *t_p, Eterm what, Eterm data) +{ + Eterm mess; + Eterm* hp; + int need; + + if (is_internal_port(t_p->tracer_proc)) { + Eterm local_heap[5+5]; + hp = local_heap; + mess = TUPLE4(hp, am_trace, t_p->id, what, data); + hp += 5; + erts_smp_mtx_lock(&smq_mtx); + if (t_p->trace_flags & F_TIMESTAMP) { + hp = patch_ts(mess, hp); + } + send_to_port( +#ifndef ERTS_SMP + /* No fake schedule out and in again after an exit */ + what == am_exit ? NULL : c_p, +#else + /* Fake schedule out and in are never sent when smp enabled */ + c_p, +#endif + mess, &t_p->tracer_proc, &t_p->trace_flags); + erts_smp_mtx_unlock(&smq_mtx); + } else { + Eterm tmp; + ErlHeapFragment *bp; + ErlOffHeap *off_heap; + ERTS_TRACER_REF_TYPE tracer_ref; + size_t sz_data; + + ASSERT(is_internal_pid(t_p->tracer_proc) + && internal_pid_index(t_p->tracer_proc) < erts_max_processes); + + ERTS_GET_TRACER_REF(tracer_ref, t_p->tracer_proc, t_p->trace_flags); + + sz_data = size_object(data); + + need = sz_data + 5 + TS_SIZE(t_p); + + hp = ERTS_ALLOC_SYSMSG_HEAP(need, &bp, &off_heap, tracer_ref); + + tmp = copy_struct(data, sz_data, &hp, off_heap); + mess = TUPLE4(hp, am_trace, t_p->id/* Local pid */, what, tmp); + hp += 5; + + erts_smp_mtx_lock(&smq_mtx); + + if (t_p->trace_flags & F_TIMESTAMP) { + hp = patch_ts(mess, hp); + } + + ERTS_ENQ_TRACE_MSG(t_p->id, tracer_ref, mess, bp); + erts_smp_mtx_unlock(&smq_mtx); + } +} + + +/* Sends trace message: + * {trace_ts, ParentPid, spawn, ChildPid, {Mod, Func, Args}, Timestamp} + * or {trace, ParentPid, spawn, ChildPid, {Mod, Func, Args}} + * + * 'pid' is the ChildPid, 'mod' and 'func' must be atomic, + * and 'args' may be a deep term. + */ +void +trace_proc_spawn(Process *p, Eterm pid, + Eterm mod, Eterm func, Eterm args) +{ + Eterm mfa; + Eterm mess; + Eterm* hp; + + if (is_internal_port(p->tracer_proc)) { + Eterm local_heap[4+6+5]; + hp = local_heap; + mfa = TUPLE3(hp, mod, func, args); + hp += 4; + mess = TUPLE5(hp, am_trace, p->id, am_spawn, pid, mfa); + hp += 6; + erts_smp_mtx_lock(&smq_mtx); + if (p->trace_flags & F_TIMESTAMP) { + hp = patch_ts(mess, hp); + } + send_to_port(p, mess, &p->tracer_proc, &p->trace_flags); + erts_smp_mtx_unlock(&smq_mtx); + } else { + Eterm tmp; + ErlHeapFragment *bp; + ErlOffHeap *off_heap; + ERTS_TRACER_REF_TYPE tracer_ref; + size_t sz_args, sz_pid; + Uint need; + + ASSERT(is_internal_pid(p->tracer_proc) + && internal_pid_index(p->tracer_proc) < erts_max_processes); + + ERTS_GET_TRACER_REF(tracer_ref, p->tracer_proc, p->trace_flags); + + sz_args = size_object(args); + sz_pid = size_object(pid); + need = sz_args + 4 + 6 + TS_SIZE(p); + + hp = ERTS_ALLOC_SYSMSG_HEAP(need, &bp, &off_heap, tracer_ref); + + tmp = copy_struct(args, sz_args, &hp, off_heap); + mfa = TUPLE3(hp, mod, func, tmp); + hp += 4; + tmp = copy_struct(pid, sz_pid, &hp, off_heap); + mess = TUPLE5(hp, am_trace, p->id, am_spawn, tmp, mfa); + hp += 6; + + erts_smp_mtx_lock(&smq_mtx); + + if (p->trace_flags & F_TIMESTAMP) { + hp = patch_ts(mess, hp); + } + + ERTS_ENQ_TRACE_MSG(p->id, tracer_ref, mess, bp); + erts_smp_mtx_unlock(&smq_mtx); + } +} + +void save_calls(Process *p, Export *e) +{ + struct saved_calls *scb = ERTS_PROC_GET_SAVED_CALLS_BUF(p); + if (scb) { + Export **ct = &scb->ct[0]; + int len = scb->len; + + ct[scb->cur] = e; + if (++scb->cur >= len) + scb->cur = 0; + if (scb->n < len) + scb->n++; + } +} + +/* + * Entry point called by the trace wrap functions in erl_bif_wrap.c + * + * The trace wrap functions are themselves called through the export + * entries instead of the original BIF functions. + */ +Eterm +erts_bif_trace(int bif_index, Process* p, + Eterm arg1, Eterm arg2, Eterm arg3, Uint *I) +{ + Eterm result; + int meta = !!(erts_bif_trace_flags[bif_index] & BIF_TRACE_AS_META); + + ERTS_SMP_CHK_HAVE_ONLY_MAIN_PROC_LOCK(p); + + if (!ARE_TRACE_FLAGS_ON(p, F_TRACE_CALLS) && (! meta)) { + /* Warning! This is an Optimization. + * + * If neither meta trace is active nor process trace flags then + * no tracing will occur. Doing the whole else branch will + * also do nothing, only slower. + */ + Eterm (*func)(Process*, Eterm, Eterm, Eterm, Uint*) = bif_table[bif_index].f; + result = func(p, arg1, arg2, arg3, I); + } else { + Eterm (*func)(Process*, Eterm, Eterm, Eterm, Uint*); + Export* ep = bif_export[bif_index]; + Uint32 flags = 0, flags_meta = 0; + int global = !!(erts_bif_trace_flags[bif_index] & BIF_TRACE_AS_GLOBAL); + int local = !!(erts_bif_trace_flags[bif_index] & BIF_TRACE_AS_LOCAL); + Eterm meta_tracer_pid = NIL; + int applying = (I == &(ep->code[3])); /* Yup, the apply code for a bif + * is actually in the + * export entry */ + Eterm *cp = p->cp; + +#ifndef _OSE_ + Eterm args[3] = {arg1, arg2, arg3}; +#else + Eterm args[3]; + args[0] = arg1; + args[1] = arg2; + args[2] = arg3; +#endif + + /* + * Make continuation pointer OK, it is not during direct BIF calls, + * but it is correct during apply of bif. + */ + if (!applying) { + p->cp = I; + } + if (global || local) { + flags = erts_call_trace(p, ep->code, ep->match_prog_set, args, + local, &p->tracer_proc); + } + if (meta) { + flags_meta = erts_bif_mtrace(p, ep->code+3, args, local, + &meta_tracer_pid); + } + /* Restore original continuation pointer (if changed). */ + p->cp = cp; + + func = bif_table[bif_index].f; + + result = func(p, arg1, arg2, arg3, I); + + if (applying && (flags & MATCH_SET_RETURN_TO_TRACE)) { + Uint i_return_trace = beam_return_trace[0]; + Uint i_return_to_trace = beam_return_to_trace[0]; + Eterm *cpp; + /* Maybe advance cp to skip trace stack frames */ + for (cpp = p->stop; ; cp = cp_val(*cpp++)) { + ASSERT(is_CP((Eterm) cp)); + if (*cp_val((Eterm) cp) == i_return_trace) { + /* Skip stack frame variables */ + while (is_not_CP(*cpp)) cpp++; + cpp += 2; /* Skip return_trace parameters */ + } else if (*cp_val((Eterm) cp) == i_return_to_trace) { + /* A return_to trace message is going to be generated + * by normal means, so we do not have to. + */ + cp = NULL; + break; + } else break; + } + } + + /* Try to get these in the order + * they usually appear in normal code... */ + if (is_non_value(result)) { + Uint reason = p->freason; + if (reason != TRAP) { + Eterm class; + Eterm value = p->fvalue; + Eterm nocatch[3]; + /* Expand error value like in handle_error() */ + if (reason & EXF_ARGLIST) { + Eterm *tp; + ASSERT(is_tuple(value)); + tp = tuple_val(value); + value = tp[1]; + } + if ((reason & EXF_THROWN) && (p->catches <= 0)) { + value = TUPLE2(nocatch, am_nocatch, value); + reason = EXC_ERROR; + } + /* Note: expand_error_value() could theoretically + * allocate on the heap, but not for any error + * returned by a BIF, and it would do no harm, + * just be annoying. + */ + value = expand_error_value(p, reason, value); + class = exception_tag[GET_EXC_CLASS(reason)]; + + if (flags_meta & MATCH_SET_EXCEPTION_TRACE) { + erts_trace_exception(p, ep->code, class, value, + &meta_tracer_pid); + } + if (flags & MATCH_SET_EXCEPTION_TRACE) { + erts_trace_exception(p, ep->code, class, value, + &p->tracer_proc); + } + if ((flags & MATCH_SET_RETURN_TO_TRACE) && p->catches > 0) { + /* can only happen if(local)*/ + Eterm *ptr = p->stop; + ASSERT(is_CP(*ptr)); + ASSERT(ptr <= STACK_START(p)); + /* Search the nearest stack frame for a catch */ + while (++ptr < STACK_START(p)) { + if (is_CP(*ptr)) break; + if (is_catch(*ptr)) { + if (applying) { + /* Apply of BIF, cp is in calling function */ + if (cp) erts_trace_return_to(p, cp); + } else { + /* Direct bif call, I points into + * calling function */ + erts_trace_return_to(p, I); + } + } + } + } + if ((flags_meta|flags) & MATCH_SET_EXCEPTION_TRACE) { + erts_smp_proc_lock(p, ERTS_PROC_LOCKS_ALL_MINOR); + p->trace_flags |= F_EXCEPTION_TRACE; + erts_smp_proc_unlock(p, ERTS_PROC_LOCKS_ALL_MINOR); + } + } + } else { + if (flags_meta & MATCH_SET_RX_TRACE) { + erts_trace_return(p, ep->code, result, &meta_tracer_pid); + } + /* MATCH_SET_RETURN_TO_TRACE cannot occur if(meta) */ + if (flags & MATCH_SET_RX_TRACE) { + erts_trace_return(p, ep->code, result, &p->tracer_proc); + } + if (flags & MATCH_SET_RETURN_TO_TRACE) { + /* can only happen if(local)*/ + if (applying) { + /* Apply of BIF, cp is in calling function */ + if (cp) erts_trace_return_to(p, cp); + } else { + /* Direct bif call, I points into calling function */ + erts_trace_return_to(p, I); + } + } + } + } + ERTS_SMP_CHK_HAVE_ONLY_MAIN_PROC_LOCK(p); + return result; +} + +/* Sends trace message: + * {trace_ts, Pid, What, Msg, Timestamp} + * or {trace, Pid, What, Msg} + * + * where 'What' must be atomic and 'Msg' is: + * [{heap_size, HeapSize}, {old_heap_size, OldHeapSize}, + * {stack_size, StackSize}, {recent_size, RecentSize}, + * {mbuf_size, MbufSize}] + * + * where 'HeapSize', 'OldHeapSize', 'StackSize', 'RecentSize and 'MbufSize' + * are all small (atomic) integers. + */ +void +trace_gc(Process *p, Eterm what) +{ + ErlHeapFragment *bp = NULL; + ErlOffHeap *off_heap; + ERTS_TRACER_REF_TYPE tracer_ref = ERTS_NULL_TRACER_REF; /* Initialized + to eliminate + compiler + warning */ + Eterm* hp; + Eterm msg = NIL; + Uint size; + Eterm tags[] = { + am_old_heap_block_size, + am_heap_block_size, + am_mbuf_size, + am_recent_size, + am_stack_size, + am_old_heap_size, + am_heap_size + }; + Uint values[] = { + OLD_HEAP(p) ? OLD_HEND(p) - OLD_HEAP(p) : 0, + HEAP_SIZE(p), + MBUF_SIZE(p), + HIGH_WATER(p) - HEAP_START(p), + STACK_START(p) - p->stop, + OLD_HEAP(p) ? OLD_HTOP(p) - OLD_HEAP(p) : 0, + HEAP_TOP(p) - HEAP_START(p) + }; + Eterm local_heap[(sizeof(values)/sizeof(Uint)) + *(2/*cons*/ + 3/*2-tuple*/ + BIG_UINT_HEAP_SIZE) + + 5/*4-tuple */ + TS_HEAP_WORDS]; +#ifdef DEBUG + Eterm* limit; +#endif + + ASSERT(sizeof(values)/sizeof(Uint) == sizeof(tags)/sizeof(Eterm)); + + if (is_internal_port(p->tracer_proc)) { + hp = local_heap; +#ifdef DEBUG + size = 0; + (void) erts_bld_atom_uint_2tup_list(NULL, + &size, + sizeof(values)/sizeof(Uint), + tags, + values); + size += 5/*4-tuple*/ + TS_SIZE(p); +#endif + } else { + ASSERT(is_internal_pid(p->tracer_proc) + && internal_pid_index(p->tracer_proc) < erts_max_processes); + + ERTS_GET_TRACER_REF(tracer_ref, p->tracer_proc, p->trace_flags); + + size = 0; + (void) erts_bld_atom_uint_2tup_list(NULL, + &size, + sizeof(values)/sizeof(Uint), + tags, + values); + size += 5/*4-tuple*/ + TS_SIZE(p); + + hp = ERTS_ALLOC_SYSMSG_HEAP(size, &bp, &off_heap, tracer_ref); + } + +#ifdef DEBUG + limit = hp + size; + ASSERT(size <= sizeof(local_heap)/sizeof(Eterm)); +#endif + + msg = erts_bld_atom_uint_2tup_list(&hp, + NULL, + sizeof(values)/sizeof(Uint), + tags, + values); + + msg = TUPLE4(hp, am_trace, p->id/* Local pid */, what, msg); + hp += 5; + + erts_smp_mtx_lock(&smq_mtx); + + if (p->trace_flags & F_TIMESTAMP) { + hp = patch_ts(msg, hp); + } + ASSERT(hp == limit); + if (is_internal_port(p->tracer_proc)) + send_to_port(p, msg, &p->tracer_proc, &p->trace_flags); + else + ERTS_ENQ_TRACE_MSG(p->id, tracer_ref, msg, bp); + erts_smp_mtx_unlock(&smq_mtx); +} + + + +void +monitor_long_gc(Process *p, Uint time) { + ErlHeapFragment *bp; + ErlOffHeap *off_heap; +#ifndef ERTS_SMP + Process *monitor_p; +#endif + Uint hsz; + Eterm *hp, list, msg; + Eterm tags[] = { + am_timeout, + am_old_heap_block_size, + am_heap_block_size, + am_mbuf_size, + am_stack_size, + am_old_heap_size, + am_heap_size + }; + Eterm values[] = { + time, + OLD_HEAP(p) ? OLD_HEND(p) - OLD_HEAP(p) : 0, + HEAP_SIZE(p), + MBUF_SIZE(p), + STACK_START(p) - p->stop, + OLD_HEAP(p) ? OLD_HTOP(p) - OLD_HEAP(p) : 0, + HEAP_TOP(p) - HEAP_START(p) + }; +#ifdef DEBUG + Eterm *hp_end; +#endif + +#ifndef ERTS_SMP + ASSERT(is_internal_pid(system_monitor) + && internal_pid_index(system_monitor) < erts_max_processes); + monitor_p = process_tab[internal_pid_index(system_monitor)]; + if (INVALID_PID(monitor_p, system_monitor) || p == monitor_p) { + return; + } +#endif + + hsz = 0; + (void) erts_bld_atom_uint_2tup_list(NULL, + &hsz, + sizeof(values)/sizeof(Uint), + tags, + values); + hsz += 5 /* 4-tuple */; + + hp = ERTS_ALLOC_SYSMSG_HEAP(hsz, &bp, &off_heap, monitor_p); + +#ifdef DEBUG + hp_end = hp + hsz; +#endif + + list = erts_bld_atom_uint_2tup_list(&hp, + NULL, + sizeof(values)/sizeof(Uint), + tags, + values); + msg = TUPLE4(hp, am_monitor, p->id/* Local pid */, am_long_gc, list); + +#ifdef DEBUG + hp += 5 /* 4-tuple */; + ASSERT(hp == hp_end); +#endif + +#ifdef ERTS_SMP + enqueue_sys_msg(SYS_MSG_TYPE_SYSMON, p->id, NIL, msg, bp); +#else + erts_queue_message(monitor_p, NULL, bp, msg, NIL); +#endif +} + +void +monitor_large_heap(Process *p) { + ErlHeapFragment *bp; + ErlOffHeap *off_heap; +#ifndef ERTS_SMP + Process *monitor_p; +#endif + Uint hsz; + Eterm *hp, list, msg; + Eterm tags[] = { + am_old_heap_block_size, + am_heap_block_size, + am_mbuf_size, + am_stack_size, + am_old_heap_size, + am_heap_size + }; + Uint values[] = { + OLD_HEAP(p) ? OLD_HEND(p) - OLD_HEAP(p) : 0, + HEAP_SIZE(p), + MBUF_SIZE(p), + STACK_START(p) - p->stop, + OLD_HEAP(p) ? OLD_HTOP(p) - OLD_HEAP(p) : 0, + HEAP_TOP(p) - HEAP_START(p) + }; +#ifdef DEBUG + Eterm *hp_end; +#endif + + +#ifndef ERTS_SMP + ASSERT(is_internal_pid(system_monitor) + && internal_pid_index(system_monitor) < erts_max_processes); + monitor_p = process_tab[internal_pid_index(system_monitor)]; + if (INVALID_PID(monitor_p, system_monitor) || p == monitor_p) { + return; + } +#endif + + hsz = 0; + (void) erts_bld_atom_uint_2tup_list(NULL, + &hsz, + sizeof(values)/sizeof(Uint), + tags, + values); + hsz += 5 /* 4-tuple */; + + hp = ERTS_ALLOC_SYSMSG_HEAP(hsz, &bp, &off_heap, monitor_p); + +#ifdef DEBUG + hp_end = hp + hsz; +#endif + + list = erts_bld_atom_uint_2tup_list(&hp, + NULL, + sizeof(values)/sizeof(Uint), + tags, + values); + msg = TUPLE4(hp, am_monitor, p->id/* Local pid */, am_large_heap, list); + +#ifdef DEBUG + hp += 5 /* 4-tuple */; + ASSERT(hp == hp_end); +#endif + +#ifdef ERTS_SMP + enqueue_sys_msg(SYS_MSG_TYPE_SYSMON, p->id, NIL, msg, bp); +#else + erts_queue_message(monitor_p, NULL, bp, msg, NIL); +#endif +} + +void +monitor_generic(Process *p, Eterm type, Eterm spec) { + ErlHeapFragment *bp; + ErlOffHeap *off_heap; +#ifndef ERTS_SMP + Process *monitor_p; +#endif + Eterm *hp, msg; + +#ifndef ERTS_SMP + ASSERT(is_internal_pid(system_monitor) + && internal_pid_index(system_monitor) < erts_max_processes); + monitor_p = process_tab[internal_pid_index(system_monitor)]; + if (INVALID_PID(monitor_p, system_monitor) || p == monitor_p) { + return; + } +#endif + + hp = ERTS_ALLOC_SYSMSG_HEAP(5, &bp, &off_heap, monitor_p); + + msg = TUPLE4(hp, am_monitor, p->id/* Local pid */, type, spec); + hp += 5; + +#ifdef ERTS_SMP + enqueue_sys_msg(SYS_MSG_TYPE_SYSMON, p->id, NIL, msg, bp); +#else + erts_queue_message(monitor_p, NULL, bp, msg, NIL); +#endif + +} + + +/* Begin system_profile tracing */ +/* Scheduler profiling */ + +void +profile_scheduler(Eterm scheduler_id, Eterm state) { + Eterm *hp, msg, timestamp; + Uint Ms, s, us; + +#ifndef ERTS_SMP + Eterm local_heap[4 + 7]; + hp = local_heap; +#else + ErlHeapFragment *bp; + Uint hsz; + + hsz = 4 + 7; + + bp = new_message_buffer(hsz); + hp = bp->mem; +#endif + + erts_smp_mtx_lock(&smq_mtx); + + switch (state) { + case am_active: + active_sched++; + break; + case am_inactive: + active_sched--; + break; + default: + ASSERT(!"Invalid state"); + break; + } + + GET_NOW(&Ms, &s, &us); + timestamp = TUPLE3(hp, make_small(Ms), make_small(s), make_small(us)); hp += 4; + msg = TUPLE6(hp, am_profile, am_scheduler, scheduler_id, state, + make_small(active_sched), timestamp); hp += 7; + +#ifndef ERTS_SMP + profile_send(msg); +#else + enqueue_sys_msg_unlocked(SYS_MSG_TYPE_SYSPROF, NIL, NIL, msg, bp); +#endif + erts_smp_mtx_unlock(&smq_mtx); + +} + +void +profile_scheduler_q(Eterm scheduler_id, Eterm state, Eterm no_schedulers, Uint Ms, Uint s, Uint us) { + Eterm *hp, msg, timestamp; + +#ifndef ERTS_SMP + Eterm local_heap[4 + 7]; + hp = local_heap; +#else + ErlHeapFragment *bp; + Uint hsz; + + hsz = 4 + 7; + + bp = new_message_buffer(hsz); + hp = bp->mem; +#endif + + erts_smp_mtx_lock(&smq_mtx); + + timestamp = TUPLE3(hp, make_small(Ms), make_small(s), make_small(us)); hp += 4; + msg = TUPLE6(hp, am_profile, am_scheduler, scheduler_id, state, no_schedulers, timestamp); hp += 7; +#ifndef ERTS_SMP + profile_send(msg); +#else + enqueue_sys_msg_unlocked(SYS_MSG_TYPE_SYSPROF, NIL, NIL, msg, bp); +#endif + erts_smp_mtx_unlock(&smq_mtx); + +} + + +/* Send {trace_ts, Pid, What, {Mod, Func, Arity}, Timestamp} + * or {trace, Pid, What, {Mod, Func, Arity}} + * + * where 'What' is supposed to be 'in' or 'out'. + * + * Virtual scheduling do not fake scheduling for ports. + */ + + +void trace_virtual_sched(Process *p, Eterm what) +{ + trace_sched_aux(p, what, 1); +} + +/* Port profiling */ + +void +trace_port_open(Port *p, Eterm calling_pid, Eterm drv_name) { + Eterm mess; + Eterm* hp; + + if (is_internal_port(p->tracer_proc)) { + Eterm local_heap[5+6]; + hp = local_heap; + + mess = TUPLE5(hp, am_trace, calling_pid, am_open, p->id, drv_name); + hp += 6; + erts_smp_mtx_lock(&smq_mtx); + if (p->trace_flags & F_TIMESTAMP) { + hp = patch_ts(mess, hp); + } + /* No fake schedule */ + send_to_port(NULL, mess, &p->tracer_proc, &p->trace_flags); + erts_smp_mtx_unlock(&smq_mtx); + } else { + ErlHeapFragment *bp; + ErlOffHeap *off_heap; + size_t sz_data; + ERTS_TRACER_REF_TYPE tracer_ref; + + ASSERT(is_internal_pid(p->tracer_proc) + && internal_pid_index(p->tracer_proc) < erts_max_processes); + + sz_data = 6 + TS_SIZE(p); + + ERTS_GET_TRACER_REF(tracer_ref, p->tracer_proc, p->trace_flags); + + hp = ERTS_ALLOC_SYSMSG_HEAP(sz_data, &bp, &off_heap, tracer_ref); + + mess = TUPLE5(hp, am_trace, calling_pid, am_open, p->id, drv_name); + hp += 6; + + erts_smp_mtx_lock(&smq_mtx); + + if (p->trace_flags & F_TIMESTAMP) { + hp = patch_ts(mess, hp); + } + + ERTS_ENQ_TRACE_MSG(p->id, tracer_ref, mess, bp); + erts_smp_mtx_unlock(&smq_mtx); + } + +} + +/* Sends trace message: + * {trace_ts, PortPid, What, Data, Timestamp} + * or {trace, PortPid, What, Data} + * + * 'what' must be atomic, 'data' must be atomic. + * 't_p' is the traced port. + */ +void +trace_port(Port *t_p, Eterm what, Eterm data) { + Eterm mess; + Eterm* hp; + + if (is_internal_port(t_p->tracer_proc)) { + Eterm local_heap[5+5]; + hp = local_heap; + mess = TUPLE4(hp, am_trace, t_p->id, what, data); + hp += 5; + erts_smp_mtx_lock(&smq_mtx); + if (t_p->trace_flags & F_TIMESTAMP) { + hp = patch_ts(mess, hp); + } + /* No fake schedule */ + send_to_port(NULL, mess, &t_p->tracer_proc, &t_p->trace_flags); + erts_smp_mtx_unlock(&smq_mtx); + } else { + ErlHeapFragment *bp; + ErlOffHeap *off_heap; + size_t sz_data; + ERTS_TRACER_REF_TYPE tracer_ref; + + ASSERT(is_internal_pid(t_p->tracer_proc) + && internal_pid_index(t_p->tracer_proc) < erts_max_processes); + + sz_data = 5 + TS_SIZE(t_p); + + ERTS_GET_TRACER_REF(tracer_ref, t_p->tracer_proc, t_p->trace_flags); + + hp = ERTS_ALLOC_SYSMSG_HEAP(sz_data, &bp, &off_heap, tracer_ref); + + mess = TUPLE4(hp, am_trace, t_p->id, what, data); + hp += 5; + + erts_smp_mtx_lock(&smq_mtx); + + if (t_p->trace_flags & F_TIMESTAMP) { + hp = patch_ts(mess, hp); + } + + ERTS_ENQ_TRACE_MSG(t_p->id, tracer_ref, mess, bp); + erts_smp_mtx_unlock(&smq_mtx); + } +} + +/* Send {trace_ts, Pid, What, {Mod, Func, Arity}, Timestamp} + * or {trace, Pid, What, {Mod, Func, Arity}} + * + * where 'What' is supposed to be 'in' or 'out' and + * where 'where' is supposed to be location (callback) + * for the port. + */ + +void +trace_sched_ports(Port *p, Eterm what) { + trace_sched_ports_where(p,what, make_small(0)); +} + +void +trace_sched_ports_where(Port *p, Eterm what, Eterm where) { + Eterm mess; + Eterm* hp; + int ws = 5; + Eterm sched_id = am_undefined; + + if (is_internal_port(p->tracer_proc)) { + Eterm local_heap[5+6]; + hp = local_heap; + + if (IS_TRACED_FL(p, F_TRACE_SCHED_NO)) { +#ifdef ERTS_SMP + ErtsSchedulerData *esd = erts_get_scheduler_data(); + if (esd) sched_id = make_small(esd->no); + else sched_id = am_undefined; +#else + sched_id = make_small(1); +#endif + mess = TUPLE5(hp, am_trace, p->id, what, sched_id, where); + ws = 6; + } else { + mess = TUPLE4(hp, am_trace, p->id, what, where); + ws = 5; + } + hp += ws; + + erts_smp_mtx_lock(&smq_mtx); + if (p->trace_flags & F_TIMESTAMP) { + hp = patch_ts(mess, hp); + } + + /* No fake scheduling */ + send_to_port(NULL, mess, &p->tracer_proc, &p->trace_flags); + erts_smp_mtx_unlock(&smq_mtx); + } else { + ErlHeapFragment *bp; + ErlOffHeap *off_heap; + ERTS_TRACER_REF_TYPE tracer_ref; + + ASSERT(is_internal_pid(p->tracer_proc) + && internal_pid_index(p->tracer_proc) < erts_max_processes); + + if (IS_TRACED_FL(p, F_TRACE_SCHED_NO)) ws = 6; /* Make place for scheduler id */ + + ERTS_GET_TRACER_REF(tracer_ref, p->tracer_proc, p->trace_flags); + + hp = ERTS_ALLOC_SYSMSG_HEAP(ws+TS_SIZE(p), &bp, &off_heap, tracer_ref); + + if (IS_TRACED_FL(p, F_TRACE_SCHED_NO)) { +#ifdef ERTS_SMP + ErtsSchedulerData *esd = erts_get_scheduler_data(); + if (esd) sched_id = make_small(esd->no); + else sched_id = am_undefined; +#else + sched_id = make_small(1); +#endif + mess = TUPLE5(hp, am_trace, p->id, what, sched_id, where); + } else { + mess = TUPLE4(hp, am_trace, p->id, what, where); + } + hp += ws; + + erts_smp_mtx_lock(&smq_mtx); + + if (p->trace_flags & F_TIMESTAMP) { + hp = patch_ts(mess, hp); + } + + ERTS_ENQ_TRACE_MSG(p->id, tracer_ref, mess, bp); + erts_smp_mtx_unlock(&smq_mtx); + } +} + +/* Port profiling */ + +void +profile_runnable_port(Port *p, Eterm status) { + Uint Ms, s, us; + Eterm *hp, msg, timestamp; + + Eterm count = make_small(0); + +#ifndef ERTS_SMP + Eterm local_heap[4 + 6]; + hp = local_heap; + +#else + ErlHeapFragment *bp; + Uint hsz; + + hsz = 4 + 6; + + bp = new_message_buffer(hsz); + hp = bp->mem; +#endif + + erts_smp_mtx_lock(&smq_mtx); + + GET_NOW(&Ms, &s, &us); + timestamp = TUPLE3(hp, make_small(Ms), make_small(s), make_small(us)); hp += 4; + msg = TUPLE5(hp, am_profile, p->id, status, count, timestamp); hp += 6; + +#ifndef ERTS_SMP + profile_send(msg); +#else + enqueue_sys_msg_unlocked(SYS_MSG_TYPE_SYSPROF, NIL, NIL, msg, bp); +#endif + erts_smp_mtx_unlock(&smq_mtx); +} + +/* Process profiling */ +void +profile_runnable_proc(Process *p, Eterm status){ + Uint Ms, s, us; + Eterm *hp, msg, timestamp; + Eterm where = am_undefined; + +#ifndef ERTS_SMP + Eterm local_heap[4 + 6 + 4]; + hp = local_heap; +#else + ErlHeapFragment *bp; + Uint hsz = 4 + 6 + 4; +#endif + + if (!p->current) { + p->current = find_function_from_pc(p->i); + } + +#ifdef ERTS_SMP + if (!p->current) { + hsz = 4 + 6; + } + + bp = new_message_buffer(hsz); + hp = bp->mem; +#endif + + if (p->current) { + where = TUPLE3(hp, p->current[0], p->current[1], make_small(p->current[2])); hp += 4; + } else { + where = make_small(0); + } + + erts_smp_mtx_lock(&smq_mtx); + + GET_NOW(&Ms, &s, &us); + timestamp = TUPLE3(hp, make_small(Ms), make_small(s), make_small(us)); hp += 4; + msg = TUPLE5(hp, am_profile, p->id, status, where, timestamp); hp += 6; +#ifndef ERTS_SMP + profile_send(msg); +#else + enqueue_sys_msg_unlocked(SYS_MSG_TYPE_SYSPROF, NIL, NIL, msg, bp); +#endif + erts_smp_mtx_unlock(&smq_mtx); +} +/* End system_profile tracing */ + + + +#ifdef ERTS_SMP + +void +erts_check_my_tracer_proc(Process *p) +{ + if (is_internal_pid(p->tracer_proc)) { + Process *tracer = erts_pid2proc(p, ERTS_PROC_LOCK_MAIN, + p->tracer_proc, ERTS_PROC_LOCK_STATUS); + int invalid_tracer = !tracer || !(tracer->trace_flags & F_TRACER); + if (tracer) + erts_smp_proc_unlock(tracer, ERTS_PROC_LOCK_STATUS); + if (invalid_tracer) { + erts_smp_proc_lock(p, ERTS_PROC_LOCKS_ALL_MINOR); + p->trace_flags &= ~TRACEE_FLAGS; + p->tracer_proc = NIL; + erts_smp_proc_unlock(p, ERTS_PROC_LOCKS_ALL_MINOR); + } + } +} + + +typedef struct ErtsSysMsgQ_ ErtsSysMsgQ; +struct ErtsSysMsgQ_ { + ErtsSysMsgQ *next; + enum ErtsSysMsgType type; + Eterm from; + Eterm to; + Eterm msg; + ErlHeapFragment *bp; +}; + +static ErtsSysMsgQ *sys_message_queue; +static ErtsSysMsgQ *sys_message_queue_end; + +static erts_tid_t sys_msg_dispatcher_tid; +static erts_cnd_t smq_cnd; + +static int dispatcher_waiting; + +ERTS_QUALLOC_IMPL(smq_element, ErtsSysMsgQ, 20, ERTS_ALC_T_SYS_MSG_Q) + +static void +enqueue_sys_msg_unlocked(enum ErtsSysMsgType type, + Eterm from, + Eterm to, + Eterm msg, + ErlHeapFragment *bp) +{ + ErtsSysMsgQ *smqp; + + smqp = smq_element_alloc(); + smqp->next = NULL; + smqp->type = type; + smqp->from = from; + smqp->to = to; + smqp->msg = msg; + smqp->bp = bp; + + if (sys_message_queue_end) { + ASSERT(sys_message_queue); + sys_message_queue_end->next = smqp; + } + else { + ASSERT(!sys_message_queue); + sys_message_queue = smqp; + } + sys_message_queue_end = smqp; + erts_smp_cnd_signal(&smq_cnd); +} + +static void +enqueue_sys_msg(enum ErtsSysMsgType type, + Eterm from, + Eterm to, + Eterm msg, + ErlHeapFragment *bp) +{ + erts_smp_mtx_lock(&smq_mtx); + enqueue_sys_msg_unlocked(type, from, to, msg, bp); + erts_smp_mtx_unlock(&smq_mtx); +} + +static void +prepare_for_block(void *unused) +{ + erts_smp_mtx_unlock(&smq_mtx); +} + +static void +resume_after_block(void *unused) +{ + erts_smp_mtx_lock(&smq_mtx); +} + +void +erts_queue_error_logger_message(Eterm from, Eterm msg, ErlHeapFragment *bp) +{ + enqueue_sys_msg(SYS_MSG_TYPE_ERRLGR, from, am_error_logger, msg, bp); +} + +void +erts_send_sys_msg_proc(Eterm from, Eterm to, Eterm msg, ErlHeapFragment *bp) +{ + ASSERT(is_internal_pid(to)); + enqueue_sys_msg(SYS_MSG_TYPE_PROC_MSG, from, to, msg, bp); +} + +#ifdef DEBUG_PRINTOUTS +static void +print_msg_type(ErtsSysMsgQ *smqp) +{ + switch (smqp->type) { + case SYS_MSG_TYPE_TRACE: + erts_fprintf(stderr, "TRACE "); + break; + case SYS_MSG_TYPE_SEQTRACE: + erts_fprintf(stderr, "SEQTRACE "); + break; + case SYS_MSG_TYPE_SYSMON: + erts_fprintf(stderr, "SYSMON "); + break; + case SYS_MSG_TYPE_SYSPROF: + erts_fprintf(stderr, "SYSPROF "); + break; + case SYS_MSG_TYPE_ERRLGR: + erts_fprintf(stderr, "ERRLGR "); + break; + case SYS_MSG_TYPE_PROC_MSG: + erts_fprintf(stderr, "PROC_MSG "); + break; + default: + erts_fprintf(stderr, "??? "); + break; + } +} +#endif + +static void +sys_msg_disp_failure(ErtsSysMsgQ *smqp, Eterm receiver) +{ + switch (smqp->type) { + case SYS_MSG_TYPE_TRACE: + /* Invalid tracer_proc's are removed when processes + are scheduled in. */ + break; + case SYS_MSG_TYPE_SEQTRACE: + /* Reset seq_tracer if it hasn't changed */ + erts_smp_mtx_lock(&sys_trace_mtx); + if (system_seq_tracer == receiver) + system_seq_tracer = am_false; + erts_smp_mtx_unlock(&sys_trace_mtx); + break; + case SYS_MSG_TYPE_SYSMON: + if (receiver == NIL + && !erts_system_monitor_long_gc + && !erts_system_monitor_large_heap + && !erts_system_monitor_flags.busy_port + && !erts_system_monitor_flags.busy_dist_port) + break; /* Everything is disabled */ + erts_smp_block_system(ERTS_BS_FLG_ALLOW_GC); + if (system_monitor == receiver || receiver == NIL) + erts_system_monitor_clear(NULL); + erts_smp_release_system(); + break; + case SYS_MSG_TYPE_SYSPROF: + if (receiver == NIL + && !erts_system_profile_flags.runnable_procs + && !erts_system_profile_flags.runnable_ports + && !erts_system_profile_flags.exclusive + && !erts_system_profile_flags.scheduler) + break; + /* Block system to clear flags */ + erts_smp_block_system(0); + if (system_profile == receiver || receiver == NIL) { + erts_system_profile_clear(NULL); + } + erts_smp_release_system(); + break; + case SYS_MSG_TYPE_ERRLGR: { + char *no_elgger = "(no error logger present)"; + Eterm *tp; + Eterm tag; + if (is_not_tuple(smqp->msg)) { + unexpected_elmsg: + erts_fprintf(stderr, + "%s unexpected error logger message: %T\n", + no_elgger, + smqp->msg); + } + + tp = tuple_val(smqp->msg); + if (arityval(tp[0]) != 2) + goto unexpected_elmsg; + if (is_not_tuple(tp[2])) + goto unexpected_elmsg; + tp = tuple_val(tp[2]); + if (arityval(tp[0]) != 3) + goto unexpected_elmsg; + tag = tp[1]; + if (is_not_tuple(tp[3])) + goto unexpected_elmsg; + tp = tuple_val(tp[3]); + if (arityval(tp[0]) != 3) + goto unexpected_elmsg; + if (is_not_list(tp[3])) + goto unexpected_elmsg; + erts_fprintf(stderr, "%s %T: %T\n", + no_elgger, tag, CAR(list_val(tp[3]))); + break; + } + case SYS_MSG_TYPE_PROC_MSG: + break; + default: + ASSERT(0); + } +} + +static void * +sys_msg_dispatcher_func(void *unused) +{ + ErtsSysMsgQ *local_sys_message_queue = NULL; + +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_set_thread_name("system message dispatcher"); +#endif + + erts_register_blockable_thread(); + erts_smp_activity_begin(ERTS_ACTIVITY_IO, NULL, NULL, NULL); + + while (1) { + ErtsSysMsgQ *smqp; + + ERTS_SMP_LC_ASSERT(!ERTS_LC_IS_BLOCKING); + + erts_smp_mtx_lock(&smq_mtx); + + /* Free previously used queue ... */ + while (local_sys_message_queue) { + smqp = local_sys_message_queue; + local_sys_message_queue = smqp->next; + smq_element_free(smqp); + } + + /* Fetch current trace message queue ... */ + erts_smp_activity_change(ERTS_ACTIVITY_IO, + ERTS_ACTIVITY_WAIT, + prepare_for_block, + resume_after_block, + NULL); + dispatcher_waiting = 1; + while (!sys_message_queue) + erts_smp_cnd_wait(&smq_cnd, &smq_mtx); + dispatcher_waiting = 0; + erts_smp_activity_change(ERTS_ACTIVITY_WAIT, + ERTS_ACTIVITY_IO, + prepare_for_block, + resume_after_block, + NULL); + + local_sys_message_queue = sys_message_queue; + sys_message_queue = NULL; + sys_message_queue_end = NULL; + + erts_smp_mtx_unlock(&smq_mtx); + + /* Send trace messages ... */ + + ASSERT(local_sys_message_queue); + + for (smqp = local_sys_message_queue; smqp; smqp = smqp->next) { + Eterm receiver; + ErtsProcLocks proc_locks = ERTS_PROC_LOCKS_MSG_SEND; + Process *proc = NULL; + Port *port = NULL; + +#ifdef DEBUG_PRINTOUTS + print_msg_type(smqp); +#endif + switch (smqp->type) { + case SYS_MSG_TYPE_TRACE: + case SYS_MSG_TYPE_PROC_MSG: + receiver = smqp->to; + break; + case SYS_MSG_TYPE_SEQTRACE: + receiver = erts_get_system_seq_tracer(); + break; + case SYS_MSG_TYPE_SYSMON: + receiver = erts_get_system_monitor(); + if (smqp->from == receiver) { +#ifdef DEBUG_PRINTOUTS + erts_fprintf(stderr, "MSG=%T to %T... ", + smqp->msg, receiver); +#endif + goto drop_sys_msg; + } + break; + case SYS_MSG_TYPE_SYSPROF: + receiver = erts_get_system_profile(); + if (smqp->from == receiver) { +#ifdef DEBUG_PRINTOUTS + erts_fprintf(stderr, "MSG=%T to %T... ", + smqp->msg, receiver); +#endif + goto drop_sys_msg; + } + break; + case SYS_MSG_TYPE_ERRLGR: + receiver = am_error_logger; + break; + default: + receiver = NIL; + break; + } + +#ifdef DEBUG_PRINTOUTS + erts_fprintf(stderr, "MSG=%T to %T... ", smqp->msg, receiver); +#endif + + if (is_internal_pid(receiver)) { + proc = erts_pid2proc(NULL, 0, receiver, proc_locks); + if (!proc + || (smqp->type == SYS_MSG_TYPE_TRACE + && !(proc->trace_flags & F_TRACER))) { + /* Bad tracer */ +#ifdef DEBUG_PRINTOUTS + if (smqp->type == SYS_MSG_TYPE_TRACE && proc) + erts_fprintf(stderr, + " "); +#endif + goto failure; + } + else { + queue_proc_msg: + erts_queue_message(proc,&proc_locks,smqp->bp,smqp->msg,NIL); +#ifdef DEBUG_PRINTOUTS + erts_fprintf(stderr, "delivered\n"); +#endif + erts_smp_proc_unlock(proc, proc_locks); + } + } + else if (receiver == am_error_logger) { + proc = erts_whereis_process(NULL,0,receiver,proc_locks,0); + if (!proc) + goto failure; + else if (smqp->from == proc->id) + goto drop_sys_msg; + else + goto queue_proc_msg; + } + else if (is_internal_port(receiver)) { + port = erts_id2port(receiver, NULL, 0); + if (INVALID_TRACER_PORT(port, receiver)) { + if (port) + erts_port_release(port); + goto failure; + } + else { + write_sys_msg_to_port(receiver, + port, + smqp->from, + smqp->type, + smqp->msg); + if (port->control_flags & PORT_CONTROL_FLAG_HEAVY) + port->control_flags &= ~PORT_CONTROL_FLAG_HEAVY; +#ifdef DEBUG_PRINTOUTS + erts_fprintf(stderr, "delivered\n"); +#endif + erts_port_release(port); + if (smqp->bp) + free_message_buffer(smqp->bp); + } + } + else { + failure: + sys_msg_disp_failure(smqp, receiver); + drop_sys_msg: + if (proc) + erts_smp_proc_unlock(proc, proc_locks); + if (smqp->bp) + free_message_buffer(smqp->bp); +#ifdef DEBUG_PRINTOUTS + erts_fprintf(stderr, "dropped\n"); +#endif + } + } + } + + erts_smp_activity_end(ERTS_ACTIVITY_IO, NULL, NULL, NULL); + return NULL; +} + +void +erts_foreach_sys_msg_in_q(void (*func)(Eterm, + Eterm, + Eterm, + ErlHeapFragment *)) +{ + ErtsSysMsgQ *sm; + erts_smp_mtx_lock(&smq_mtx); + for (sm = sys_message_queue; sm; sm = sm->next) { + Eterm to; + switch (sm->type) { + case SYS_MSG_TYPE_TRACE: + to = sm->to; + break; + case SYS_MSG_TYPE_SEQTRACE: + to = erts_get_system_seq_tracer(); + break; + case SYS_MSG_TYPE_SYSMON: + to = erts_get_system_monitor(); + break; + case SYS_MSG_TYPE_SYSPROF: + to = erts_get_system_profile(); + break; + case SYS_MSG_TYPE_ERRLGR: + to = am_error_logger; + break; + default: + to = NIL; + break; + } + (*func)(sm->from, to, sm->msg, sm->bp); + } + erts_smp_mtx_unlock(&smq_mtx); +} + + +static void +init_sys_msg_dispatcher(void) +{ + erts_smp_thr_opts_t thr_opts = ERTS_SMP_THR_OPTS_DEFAULT_INITER; + thr_opts.detached = 1; + init_smq_element_alloc(); + sys_message_queue = NULL; + sys_message_queue_end = NULL; + erts_smp_cnd_init(&smq_cnd); + erts_smp_mtx_init(&smq_mtx, "sys_msg_q"); + dispatcher_waiting = 0; + erts_smp_thr_create(&sys_msg_dispatcher_tid, + sys_msg_dispatcher_func, + NULL, + &thr_opts); +} + +#endif diff --git a/erts/emulator/beam/erl_unicode.c b/erts/emulator/beam/erl_unicode.c new file mode 100644 index 0000000000..ab5811c70f --- /dev/null +++ b/erts/emulator/beam/erl_unicode.c @@ -0,0 +1,1815 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2008-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "erl_process.h" +#include "error.h" +#include "bif.h" +#include "erl_binary.h" +#include "big.h" + +#include "erl_unicode.h" + +typedef struct _restart_context { + byte *bytes; + Uint num_processed_bytes; + Uint num_bytes_to_process; + Uint num_resulting_chars; + int state; +} RestartContext; + + +#define LOOP_FACTOR 10 +#define LOOP_FACTOR_SIMPLE 50 /* When just counting */ + +static Uint max_loop_limit; + +static BIF_RETTYPE utf8_to_list(BIF_ALIST_1); +static BIF_RETTYPE finalize_list_to_list(Process *p, + byte *bytes, + Eterm rest, + Uint num_processed_bytes, + Uint num_bytes_to_process, + Uint num_resulting_chars, + int state, int left, + Eterm tail); +static int analyze_utf8(byte *source, Uint size, + byte **err_pos, Uint *num_chars, int *left); +#define UTF8_OK 0 +#define UTF8_INCOMPLETE 1 +#define UTF8_ERROR 2 +#define UTF8_ANALYZE_MORE 3 + +static BIF_RETTYPE characters_to_utf8_trap(BIF_ALIST_3); +static BIF_RETTYPE characters_to_list_trap_1(BIF_ALIST_3); +static BIF_RETTYPE characters_to_list_trap_2(BIF_ALIST_3); + +static BIF_RETTYPE characters_to_list_trap_3(BIF_ALIST_3); +static BIF_RETTYPE characters_to_list_trap_4(BIF_ALIST_1); + +static Export characters_to_utf8_trap_exp; +static Export characters_to_list_trap_1_exp; +static Export characters_to_list_trap_2_exp; + +static Export characters_to_list_trap_3_exp; +static Export characters_to_list_trap_4_exp; + +static Export *c_to_b_int_trap_exportp = NULL; +static Export *c_to_l_int_trap_exportp = NULL; + +void erts_init_unicode(void) +{ + max_loop_limit = CONTEXT_REDS * LOOP_FACTOR; + /* Non visual BIFs to trap to. */ + memset(&characters_to_utf8_trap_exp, 0, sizeof(Export)); + characters_to_utf8_trap_exp.address = + &characters_to_utf8_trap_exp.code[3]; + characters_to_utf8_trap_exp.code[0] = am_erlang; + characters_to_utf8_trap_exp.code[1] = + am_atom_put("characters_to_utf8_trap",23); + characters_to_utf8_trap_exp.code[2] = 3; + characters_to_utf8_trap_exp.code[3] = + (Eterm) em_apply_bif; + characters_to_utf8_trap_exp.code[4] = + (Eterm) &characters_to_utf8_trap; + + memset(&characters_to_list_trap_1_exp, 0, sizeof(Export)); + characters_to_list_trap_1_exp.address = + &characters_to_list_trap_1_exp.code[3]; + characters_to_list_trap_1_exp.code[0] = am_erlang; + characters_to_list_trap_1_exp.code[1] = + am_atom_put("characters_to_list_trap_1",25); + characters_to_list_trap_1_exp.code[2] = 3; + characters_to_list_trap_1_exp.code[3] = + (Eterm) em_apply_bif; + characters_to_list_trap_1_exp.code[4] = + (Eterm) &characters_to_list_trap_1; + + memset(&characters_to_list_trap_2_exp, 0, sizeof(Export)); + characters_to_list_trap_2_exp.address = + &characters_to_list_trap_2_exp.code[3]; + characters_to_list_trap_2_exp.code[0] = am_erlang; + characters_to_list_trap_2_exp.code[1] = + am_atom_put("characters_to_list_trap_2",25); + characters_to_list_trap_2_exp.code[2] = 3; + characters_to_list_trap_2_exp.code[3] = + (Eterm) em_apply_bif; + characters_to_list_trap_2_exp.code[4] = + (Eterm) &characters_to_list_trap_2; + + + memset(&characters_to_list_trap_3_exp, 0, sizeof(Export)); + characters_to_list_trap_3_exp.address = + &characters_to_list_trap_3_exp.code[3]; + characters_to_list_trap_3_exp.code[0] = am_erlang; + characters_to_list_trap_3_exp.code[1] = + am_atom_put("characters_to_list_trap_3",25); + characters_to_list_trap_3_exp.code[2] = 3; + characters_to_list_trap_3_exp.code[3] = + (Eterm) em_apply_bif; + characters_to_list_trap_3_exp.code[4] = + (Eterm) &characters_to_list_trap_3; + + memset(&characters_to_list_trap_4_exp, 0, sizeof(Export)); + characters_to_list_trap_4_exp.address = + &characters_to_list_trap_4_exp.code[3]; + characters_to_list_trap_4_exp.code[0] = am_erlang; + characters_to_list_trap_4_exp.code[1] = + am_atom_put("characters_to_list_trap_4",25); + characters_to_list_trap_4_exp.code[2] = 1; + characters_to_list_trap_4_exp.code[3] = + (Eterm) em_apply_bif; + characters_to_list_trap_4_exp.code[4] = + (Eterm) &characters_to_list_trap_4; + + c_to_b_int_trap_exportp = erts_export_put(am_unicode,am_characters_to_binary_int,2); + c_to_l_int_trap_exportp = erts_export_put(am_unicode,am_characters_to_list_int,2); + + +} + + +static ERTS_INLINE void *alloc_restart(size_t size) +{ + return erts_alloc(ERTS_ALC_T_UNICODE_BUFFER,size); +} + +static ERTS_INLINE void free_restart(void *ptr) +{ + erts_free(ERTS_ALC_T_UNICODE_BUFFER, ptr); +} + +static void cleanup_restart_context(RestartContext *rc) +{ + if (rc->bytes != NULL) { + free_restart(rc->bytes); + rc->bytes = NULL; + } +} + +static void cleanup_restart_context_bin(Binary *bp) +{ + RestartContext *rc = ERTS_MAGIC_BIN_DATA(bp); + cleanup_restart_context(rc); +} + +static RestartContext *get_rc_from_bin(Eterm bin) +{ + Binary *mbp; + ASSERT(ERTS_TERM_IS_MAGIC_BINARY(bin)); + + mbp = ((ProcBin *) binary_val(bin))->val; + + ASSERT(ERTS_MAGIC_BIN_DESTRUCTOR(mbp) + == cleanup_restart_context_bin); + return (RestartContext *) ERTS_MAGIC_BIN_DATA(mbp); +} + +static Eterm make_magic_bin_for_restart(Process *p, RestartContext *rc) +{ + Binary *mbp = erts_create_magic_binary(sizeof(RestartContext), + cleanup_restart_context_bin); + RestartContext *restartp = ERTS_MAGIC_BIN_DATA(mbp); + Eterm *hp; + memcpy(restartp,rc,sizeof(RestartContext)); + hp = HAlloc(p, PROC_BIN_SIZE); + return erts_mk_magic_binary_term(&hp, &MSO(p), mbp); +} + + +Sint erts_unicode_set_loop_limit(Sint limit) +{ + Sint save = (Sint) max_loop_limit; + if (limit <= 0) { + max_loop_limit = CONTEXT_REDS * LOOP_FACTOR; + } else { + max_loop_limit = (Uint) limit; + } + return save; +} + +static ERTS_INLINE int allowed_iterations(Process *p) +{ + int tmp = ERTS_BIF_REDS_LEFT(p) * LOOP_FACTOR; + int tmp2 = max_loop_limit; + if (tmp2 < tmp) + return tmp2; + else + return tmp; +} +static ERTS_INLINE int cost_to_proc(Process *p, int cost) +{ + int x = (cost / LOOP_FACTOR); + BUMP_REDS(p,x); + return x; +} +static ERTS_INLINE int simple_loops_to_common(int cost) +{ + int factor = (LOOP_FACTOR_SIMPLE / LOOP_FACTOR); + return (cost / factor); +} + +static Sint aligned_binary_size(Eterm binary) +{ + unsigned char *bytes; + Uint bitoffs; + Uint bitsize; + + ERTS_GET_BINARY_BYTES(binary, bytes, bitoffs, bitsize); + if (bitsize != 0) { + return (Sint) -1; + } + return binary_size(binary); +} + +static Sint latin1_binary_need(Eterm binary) +{ + unsigned char *bytes; + byte *temp_alloc = NULL; + Uint bitoffs; + Uint bitsize; + Uint size; + Sint need = 0; + Sint i; + + ERTS_GET_BINARY_BYTES(binary, bytes, bitoffs, bitsize); + if (bitsize != 0) { + return (Sint) -1; + } + if (bitoffs != 0) { + bytes = erts_get_aligned_binary_bytes(binary, &temp_alloc); + /* The call to erts_get_aligned_binary_bytes cannot fail as + we'we already checked bitsize and that this is a binary */ + } + size = binary_size(binary); + for(i = 0; i < size; ++i) { + if (bytes[i] & ((byte) 0x80)) { + need += 2; + } else { + need += 1; + } + } + erts_free_aligned_binary_bytes(temp_alloc); + return need; +} + +static int utf8_len(byte first) +{ + if ((first & ((byte) 0x80)) == 0) { + return 1; + } else if ((first & ((byte) 0xE0)) == 0xC0) { + return 2; + } else if ((first & ((byte) 0xF0)) == 0xE0) { + return 3; + } else if ((first & ((byte) 0xF8)) == 0xF0) { + return 4; + } + return -1; +} + +static int copy_utf8_bin(byte *target, byte *source, Uint size, + byte *leftover, int *num_leftovers, + byte **err_pos, Uint *characters) { + int copied = 0; + if (leftover != NULL && *num_leftovers) { + int need = utf8_len(leftover[0]); + int from_source = need - (*num_leftovers); + int c; + byte *tmp_err_pos = NULL; + ASSERT(need > 0); + ASSERT(from_source > 0); + if (size < from_source) { + memcpy(leftover + (*num_leftovers), source, size); + *num_leftovers += size; + return 0; + } + /* leftover has room for four bytes (see bif) */ + memcpy(leftover + (*num_leftovers),source,from_source); + c = copy_utf8_bin(target, leftover, need, NULL, NULL, &tmp_err_pos, characters); + if (tmp_err_pos != 0) { + *err_pos = source; + return 0; + } + copied += c; + *num_leftovers = 0; + size -= from_source; + target += c; + source += from_source; + } + while (size) { + if (((*source) & ((byte) 0x80)) == 0) { + *(target++) = *(source++); + --size; ++copied; + } else if (((*source) & ((byte) 0xE0)) == 0xC0) { + if (leftover && size < 2) { + *leftover = *source; + *num_leftovers = 1; + break; + } + if (size < 2 || ((source[1] & ((byte) 0xC0)) != 0x80) || + ((*source) < 0xC2) /* overlong */) { + *err_pos = source; + return copied; + } + *(target++) = *(source++); + *(target++) = *(source++); + size -= 2; copied += 2; + } else if (((*source) & ((byte) 0xF0)) == 0xE0) { + if (leftover && size < 3) { + memcpy(leftover, source, (int) size); + *num_leftovers = (int) size; + break; + } + if (size < 3 || ((source[1] & ((byte) 0xC0)) != 0x80) || + ((source[2] & ((byte) 0xC0)) != 0x80) || + (((*source) == 0xE0) && (source[1] < 0xA0)) /* overlong */ ) { + *err_pos = source; + return copied; + } + if ((((*source) & ((byte) 0xF)) == 0xD) && + ((source[1] & 0x20) != 0)) { + *err_pos = source; + return copied; + } + + if (((*source) == 0xEF) && (source[1] == 0xBF) && + ((source[2] == 0xBE) || (source[2] == 0xBF))) { + *err_pos = source; + return copied; + } + + *(target++) = *(source++); + *(target++) = *(source++); + *(target++) = *(source++); + size -= 3; copied += 3; + } else if (((*source) & ((byte) 0xF8)) == 0xF0) { + if (leftover && size < 4) { + memcpy(leftover, source, (int) size); + *num_leftovers = (int) size; + break; + } + if (size < 4 || ((source[1] & ((byte) 0xC0)) != 0x80) || + ((source[2] & ((byte) 0xC0)) != 0x80) || + ((source[3] & ((byte) 0xC0)) != 0x80) || + (((*source) == 0xF0) && (source[1] < 0x90)) /* overlong */) { + *err_pos = source; + return copied; + } + if ((((*source) & ((byte)0x7)) > 0x4U) || + ((((*source) & ((byte)0x7)) == 0x4U) && + ((source[1] & ((byte)0x3F)) > 0xFU))) { + *err_pos = source; + return copied; + } + *(target++) = *(source++); + *(target++) = *(source++); + *(target++) = *(source++); + *(target++) = *(source++); + size -= 4; copied +=4; + } else { + *err_pos = source; + return copied; + } + ++(*characters); + } + return copied; +} + + + +static Sint utf8_need(Eterm ioterm, int latin1, Uint *costp) +{ + Eterm *objp; + Eterm obj; + DECLARE_ESTACK(stack); + Sint need = 0; + Uint cost = 0; + + if (is_nil(ioterm)) { + DESTROY_ESTACK(stack); + *costp = 0; + return need; + } + if(is_binary(ioterm)) { + DESTROY_ESTACK(stack); + if (latin1) { + Sint x = latin1_binary_need(ioterm); + *costp = x; + return x; + } else { + *costp = 1; + return aligned_binary_size(ioterm); + } + } + + if (!is_list(ioterm)) { + DESTROY_ESTACK(stack); + *costp = 0; + return (Sint) -1; + } + /* OK a list, needs to be processed in order, handling each flat list-level + as they occur, just like io_list_to_binary would */ + ESTACK_PUSH(stack,ioterm); + while (!ESTACK_ISEMPTY(stack)) { + ioterm = ESTACK_POP(stack); + if (is_nil(ioterm)) { + /* ignore empty lists */ + continue; + } + if(is_list(ioterm)) { +L_Again: /* Restart with sublist, old listend was pushed on stack */ + objp = list_val(ioterm); + obj = CAR(objp); + for(;;) { /* loop over one flat list of bytes and binaries + until sublist or list end is encountered */ + if (is_small(obj)) { /* Always small */ + for(;;) { + Uint x = unsigned_val(obj); + if (x < 0x80) + need +=1; + else if (x < 0x800) + need += 2; + else if (x < 0x10000) + need += 3; + else + need += 4; + /* everything else will give badarg later + in the process, so we dont check */ + ++cost; + ioterm = CDR(objp); + if (!is_list(ioterm)) { + break; + } + objp = list_val(ioterm); + obj = CAR(objp); + if (!is_byte(obj)) + break; + } + } else if (is_nil(obj)) { + ioterm = CDR(objp); + if (!is_list(ioterm)) { + break; + } + objp = list_val(ioterm); + obj = CAR(objp); + } else if (is_list(obj)) { + /* push rest of list for later processing, start + again with sublist */ + ESTACK_PUSH(stack,CDR(objp)); + ioterm = obj; + goto L_Again; + } else if (is_binary(obj)) { + Sint x; + + if (latin1) { + x = latin1_binary_need(obj); + if (x < 0) { + DESTROY_ESTACK(stack); + *costp = cost; + return x; + } + cost += x; + } else { + x = aligned_binary_size(obj); + if (x < 0) { + DESTROY_ESTACK(stack); + *costp = cost; + return x; + } + ++cost; + } + need += x; + ioterm = CDR(objp); + if (is_list(ioterm)) { + /* objp and obj need to be updated if + loop is to continue */ + objp = list_val(ioterm); + obj = CAR(objp); + } + } else { + DESTROY_ESTACK(stack); + *costp = cost; + return ((Sint) -1); + } + if (is_nil(ioterm) || !is_list(ioterm)) { + break; + } + } /* for(;;) */ + } /* is_list(ioterm) */ + + if (!is_list(ioterm) && !is_nil(ioterm)) { + /* inproper list end */ + if (is_binary(ioterm)) { + Sint x; + if (latin1) { + x = latin1_binary_need(ioterm); + if (x < 0) { + DESTROY_ESTACK(stack); + *costp = cost; + return x; + } + cost += x; + } else { + x = aligned_binary_size(ioterm); + if (x < 0) { + DESTROY_ESTACK(stack); + *costp = cost; + return x; + } + ++cost; + } + need += x; + } else { + DESTROY_ESTACK(stack); + *costp = cost; + return ((Sint) -1); + } + } + } /* while not estack empty */ + DESTROY_ESTACK(stack); + *costp = cost; + return need; +} + + +static Eterm do_build_utf8(Process *p, Eterm ioterm, int *left, int latin1, + byte *target, int *pos, Uint *characters, int *err, + byte *leftover, int *num_leftovers) +{ + int c; + Eterm *objp; + Eterm obj; + DECLARE_ESTACK(stack); + + *err = 0; + if ((*left) <= 0 || is_nil(ioterm)) { + DESTROY_ESTACK(stack); + return ioterm; + } + if(is_binary(ioterm)) { + Uint bitoffs; + Uint bitsize; + Uint size; + Uint i; + Eterm res_term = NIL; + unsigned char *bytes; + byte *temp_alloc = NULL; + Uint orig_size; + + ERTS_GET_BINARY_BYTES(ioterm, bytes, bitoffs, bitsize); + if (bitsize != 0) { + *err = 1; + DESTROY_ESTACK(stack); + return ioterm; + } + if (bitoffs != 0) { + bytes = erts_get_aligned_binary_bytes(ioterm, &temp_alloc); + /* The call to erts_get_aligned_binary_bytes cannot fail as + we'we already checked bitsize and that this is a binary */ + } + + orig_size = size = binary_size(ioterm); + + /* This is done to avoid splitting binaries in two + and then create an unnecessary rest that eventually gives an error. + For cases where errors are not returned this is unnecessary */ + if (!latin1) { + /* Find a valid character boundary */ + while (size > (*left) && + (((byte) bytes[(*left)]) & ((byte) 0xC0)) == ((byte) 0x80)) { + ++(*left); + } + } + + if (size > (*left)) { + Eterm *hp; + ErlSubBin *sb; + Eterm orig; + Uint offset; + /* Split the binary in two parts, of which we + only process the first */ + hp = HAlloc(p, ERL_SUB_BIN_SIZE); + sb = (ErlSubBin *) hp; + ERTS_GET_REAL_BIN(ioterm, orig, offset, bitoffs, bitsize); + sb->thing_word = HEADER_SUB_BIN; + sb->size = size - (*left); + sb->offs = offset + (*left); + sb->orig = orig; + sb->bitoffs = bitoffs; + sb->bitsize = bitsize; + sb->is_writable = 0; + res_term = make_binary(sb); + size = (*left); + } + + if (!latin1) { + int num; + byte *err_pos = NULL; + num = copy_utf8_bin(target + (*pos), bytes, + size, leftover, num_leftovers,&err_pos,characters); + *pos += num; + if (err_pos != NULL) { + int rest_bin_offset; + int rest_bin_size; + Eterm *hp; + ErlSubBin *sb; + Eterm orig; + Uint offset; + + *err = 1; + /* we have no real stack, just build a list of the binaries + we have not decoded... */ + DESTROY_ESTACK(stack); + + rest_bin_offset = (err_pos - bytes); + rest_bin_size = orig_size - rest_bin_offset; + + hp = HAlloc(p, ERL_SUB_BIN_SIZE); + sb = (ErlSubBin *) hp; + ERTS_GET_REAL_BIN(ioterm, orig, offset, bitoffs, bitsize); + sb->thing_word = HEADER_SUB_BIN; + sb->size = rest_bin_size; + sb->offs = offset + rest_bin_offset; + sb->orig = orig; + sb->bitoffs = bitoffs; + sb->bitsize = bitsize; + sb->is_writable = 0; + res_term = make_binary(sb); + erts_free_aligned_binary_bytes(temp_alloc); + return res_term; + } + } else { + i = 0; + while(i < size) { + if (bytes[i] < 0x80) { + target[(*pos)++] = bytes[i++]; + } else { + target[(*pos)++] = ((bytes[i] >> 6) | ((byte) 0xC0)); + target[(*pos)++] = ((bytes[i] & 0x3F) | ((byte) 0x80)); + ++i; + } + ++(*characters); + } + } + *left -= size; + DESTROY_ESTACK(stack); + erts_free_aligned_binary_bytes(temp_alloc); + return res_term; + } + + if (!is_list(ioterm)) { + *err = 1; + goto done; + } + + /* OK a list, needs to be processed in order, handling each flat list-level + as they occur, just like io_list_to_binary would */ + ESTACK_PUSH(stack,ioterm); + while (!ESTACK_ISEMPTY(stack) && (*left)) { + ioterm = ESTACK_POP(stack); + if (is_nil(ioterm)) { + /* ignore empty lists */ + continue; + } + if(is_list(ioterm)) { +L_Again: /* Restart with sublist, old listend was pushed on stack */ + objp = list_val(ioterm); + obj = CAR(objp); + for(;;) { /* loop over one flat list of bytes and binaries + until sublist or list end is encountered */ + if (is_small(obj)) { /* Always small in unicode*/ + if (*num_leftovers) { + /* Have rest from previous bin and this is an integer, not allowed */ + *err = 1; + goto done; + } + for(;;) { + Uint x = unsigned_val(obj); + if (latin1 && x > 255) { + *err = 1; + goto done; + } + if (x < 0x80) { + target[(*pos)++] = (byte) x; + } + else if (x < 0x800) { + target[(*pos)++] = (((byte) (x >> 6)) | + ((byte) 0xC0)); + target[(*pos)++] = (((byte) (x & 0x3F)) | + ((byte) 0x80)); + } else if (x < 0x10000) { + if ((x >= 0xD800 && x <= 0xDFFF) || + (x == 0xFFFE) || + (x == 0xFFFF)) { /* Invalid unicode range */ + *err = 1; + goto done; + } + target[(*pos)++] = (((byte) (x >> 12)) | + ((byte) 0xE0)); + target[(*pos)++] = ((((byte) (x >> 6)) & 0x3F) | + ((byte) 0x80)); + target[(*pos)++] = (((byte) (x & 0x3F)) | + ((byte) 0x80)); + } else if (x < 0x110000) { /* Standard imposed max */ + target[(*pos)++] = (((byte) (x >> 18)) | + ((byte) 0xF0)); + target[(*pos)++] = ((((byte) (x >> 12)) & 0x3F) | + ((byte) 0x80)); + target[(*pos)++] = ((((byte) (x >> 6)) & 0x3F) | + ((byte) 0x80)); + target[(*pos)++] = (((byte) (x & 0x3F)) | + ((byte) 0x80)); + } else { + *err = 1; + goto done; + } + ++(*characters); + --(*left); + ioterm = CDR(objp); + if (!is_list(ioterm) || !(*left)) { + break; + } + objp = list_val(ioterm); + obj = CAR(objp); + if (!is_small(obj)) + break; + } + } else if (is_nil(obj)) { + ioterm = CDR(objp); + if (!is_list(ioterm)) { + break; + } + objp = list_val(ioterm); + obj = CAR(objp); + } else if (is_list(obj)) { + /* push rest of list for later processing, start + again with sublist */ + ESTACK_PUSH(stack,CDR(objp)); + ioterm = obj; + goto L_Again; + } else if (is_binary(obj)) { + Eterm rest_term; + rest_term = do_build_utf8(p,obj,left,latin1,target,pos, characters, err, + leftover, num_leftovers); + if ((*err) != 0) { + Eterm *hp; + hp = HAlloc(p, 2); + obj = CDR(objp); + ioterm = CONS(hp, rest_term, obj); + //(*left) = 0; + goto done; + } + if (rest_term != NIL) { + Eterm *hp; + hp = HAlloc(p, 2); + obj = CDR(objp); + ioterm = CONS(hp, rest_term, obj); + (*left) = 0; + break; + } + ioterm = CDR(objp); + if (is_list(ioterm)) { + /* objp and obj need to be updated if + loop is to continue */ + objp = list_val(ioterm); + obj = CAR(objp); + } + } else { + *err = 1; + goto done; + } + if (!(*left) || is_nil(ioterm) || !is_list(ioterm)) { + break; + } + } /* for(;;) */ + } /* is_list(ioterm) */ + + if ((*left) && !is_list(ioterm) && !is_nil(ioterm)) { + /* inproper list end */ + if (is_binary(ioterm)) { + ioterm = do_build_utf8(p,ioterm,left,latin1,target,pos,characters,err,leftover,num_leftovers); + if ((*err) != 0) { + goto done; + } + } else { + *err = 1; + goto done; + } + } + } /* while left and not estack empty */ + done: + c = ESTACK_COUNT(stack); + if (c > 0) { + Eterm *hp = HAlloc(p,2*c); + while(!ESTACK_ISEMPTY(stack)) { + Eterm st = ESTACK_POP(stack); + ioterm = CONS(hp, ioterm, st); + hp += 2; + } + } + DESTROY_ESTACK(stack); + return ioterm; + +} + +static int check_leftovers(byte *source, int size) +{ + if (((*source) & ((byte) 0xE0)) == 0xC0) { + return 0; + } else if (((*source) & ((byte) 0xF0)) == 0xE0) { + if (size < 2 || + (size < 3 && ((source[1] & ((byte) 0xC0)) == 0x80))) { + return 0; + } + } else if (((*source) & ((byte) 0xF8)) == 0xF0) { + if (size < 2 || + (size < 3 && ((source[1] & ((byte) 0xC0)) == 0x80)) || + (size < 4 && + ((source[1] & ((byte) 0xC0)) == 0x80) && + ((source[2] & ((byte) 0xC0)) == 0x80))) { + return 0; + } + } + return -1; +} + + + +static BIF_RETTYPE build_utf8_return(Process *p,Eterm bin,int pos, + Eterm rest_term,int err, + byte *leftover,int num_leftovers,Eterm latin1) +{ + Eterm *hp; + Eterm ret; + + binary_size(bin) = pos; + if (err) { + if (num_leftovers > 0) { + Eterm leftover_bin = new_binary(p, leftover, num_leftovers); + hp = HAlloc(p,8); + rest_term = CONS(hp,rest_term,NIL); + hp += 2; + rest_term = CONS(hp,leftover_bin,rest_term); + hp += 2; + } else { + hp = HAlloc(p,4); + } + ret = TUPLE3(hp,am_error,bin,rest_term); + } else if (rest_term == NIL && num_leftovers != 0) { + Eterm leftover_bin = new_binary(p, leftover, num_leftovers); + if (check_leftovers(leftover,num_leftovers) != 0) { + hp = HAlloc(p,4); + ret = TUPLE3(hp,am_error,bin,leftover_bin); + } else { + hp = HAlloc(p,4); + ret = TUPLE3(hp,am_incomplete,bin,leftover_bin); + } + } else { /* All OK */ + if (rest_term != NIL) { /* Trap */ + if (num_leftovers > 0) { + Eterm rest_bin = new_binary(p, leftover, num_leftovers); + hp = HAlloc(p,2); + rest_term = CONS(hp,rest_bin,rest_term); + } + BUMP_ALL_REDS(p); + BIF_TRAP3(&characters_to_utf8_trap_exp, p, bin, rest_term, latin1); + } else { /* Success */ + /*hp = HAlloc(p,5); + ret = TUPLE4(hp,bin,rest_term,make_small(pos),make_small(err));*/ + ret = bin; + } + } + BIF_RET(ret); +} + + +static BIF_RETTYPE characters_to_utf8_trap(BIF_ALIST_3) +{ + Eterm *real_bin; + Sint need; + byte* bytes; + Eterm rest_term; + int left, sleft; + int pos; + int err; + byte leftover[4]; /* used for temp buffer too, + otherwise 3 bytes would have been enough */ + int num_leftovers = 0; + int latin1 = 0; + Uint characters = 0; + + /*erts_printf("Trap %T!\r\n",BIF_ARG_2);*/ + ASSERT(is_binary(BIF_ARG_1)); + real_bin = binary_val(BIF_ARG_1); + ASSERT(*real_bin == HEADER_PROC_BIN); + need = ((ProcBin *) real_bin)->val->orig_size; + pos = (int) binary_size(BIF_ARG_1); + bytes = binary_bytes(BIF_ARG_1); + sleft = left = allowed_iterations(BIF_P); + err = 0; + if (BIF_ARG_3 == am_latin1) { + latin1 = 1; + } + rest_term = do_build_utf8(BIF_P, BIF_ARG_2, &left, latin1, + bytes, &pos, &characters, &err, leftover, &num_leftovers); + cost_to_proc(BIF_P, sleft - left); + return build_utf8_return(BIF_P,BIF_ARG_1,pos,rest_term,err, + leftover,num_leftovers,BIF_ARG_3); +} + +BIF_RETTYPE unicode_bin_is_7bit_1(BIF_ALIST_1) +{ + Sint need; + if(!is_binary(BIF_ARG_1)) { + BIF_RET(am_false); + } + need = latin1_binary_need(BIF_ARG_1); + if(need >= 0 && aligned_binary_size(BIF_ARG_1) == need) { + BIF_RET(am_true); + } + BIF_RET(am_false); +} + +static int is_valid_utf8(Eterm orig_bin) +{ + Uint bitoffs; + Uint bitsize; + Uint size; + byte *temp_alloc = NULL; + byte *endpos; + Uint numchar; + byte *bytes; + int ret; + + ERTS_GET_BINARY_BYTES(orig_bin, bytes, bitoffs, bitsize); + if (bitsize != 0) { + return 0; + } + if (bitoffs != 0) { + bytes = erts_get_aligned_binary_bytes(orig_bin, &temp_alloc); + } + size = binary_size(orig_bin); + ret = analyze_utf8(bytes, + size, + &endpos,&numchar,NULL); + erts_free_aligned_binary_bytes(temp_alloc); + return (ret == UTF8_OK); +} + +BIF_RETTYPE unicode_characters_to_binary_2(BIF_ALIST_2) +{ + Sint need; + Uint characters; + int latin1; + Eterm bin; + byte *bytes; + int pos; + int err; + int left, sleft; + Eterm rest_term, subject; + byte leftover[4]; /* used for temp buffer too, o + therwise 3 bytes would have been enough */ + int num_leftovers = 0; + Uint cost_of_utf8_need; + + + if (BIF_ARG_2 == am_latin1) { + latin1 = 1; + } else if (BIF_ARG_2 == am_unicode || BIF_ARG_2 == am_utf8) { + latin1 = 0; + } else { + BIF_TRAP2(c_to_b_int_trap_exportp, BIF_P, BIF_ARG_1, BIF_ARG_2); + } + if (is_list(BIF_ARG_1) && is_binary(CAR(list_val(BIF_ARG_1))) && + is_nil(CDR(list_val(BIF_ARG_1)))) { + subject = CAR(list_val(BIF_ARG_1)); + } else { + subject = BIF_ARG_1; + } + + need = utf8_need(subject,latin1,&cost_of_utf8_need); + if (need < 0) { + BIF_ERROR(BIF_P,BADARG); + } + if (is_binary(subject) && need >= 0 && aligned_binary_size(subject) == need + && (latin1 || is_valid_utf8(subject))) { + cost_to_proc(BIF_P, simple_loops_to_common(cost_of_utf8_need)); + BIF_RET(subject); + } + + + bin = erts_new_mso_binary(BIF_P, (byte *)NULL, need); + bytes = binary_bytes(bin); + cost_to_proc(BIF_P, simple_loops_to_common(cost_of_utf8_need)); + left = allowed_iterations(BIF_P) - + simple_loops_to_common(cost_of_utf8_need); + if (left <= 0) { + /* simplified - let everything be setup by setting left to 1 */ + left = 1; + } + sleft = left; + pos = 0; + err = 0; + + + rest_term = do_build_utf8(BIF_P, subject, &left, latin1, + bytes, &pos, &characters, &err, leftover, &num_leftovers); +#ifdef HARDDEBUG + if (left == 0) { + Eterm bin; + if (is_binary(subject)) { + bin = subject; + } else if(is_list(subject) && is_binary(CAR(list_val(subject)))) { + bin = CAR(list_val(subject)); + } else { + bin = NIL; + } + if (is_binary(bin)) { + byte *t = NULL; + Uint sz = binary_size(bin); + byte *by = erts_get_aligned_binary_bytes(bin,&t); + int i; + erts_printf("<<"); + for (i = 0;i < sz; ++i) { + erts_printf((i == sz -1) ? "0x%X" : "0x%X, ", (unsigned) by[i]); + } + erts_printf(">>: "); + erts_free_aligned_binary_bytes(t); + } + erts_printf("%d - %d = %d\n",sleft,left,sleft - left); + } +#endif + cost_to_proc(BIF_P, sleft - left); + return build_utf8_return(BIF_P,bin,pos,rest_term,err, + leftover,num_leftovers,BIF_ARG_2); +} + +static BIF_RETTYPE build_list_return(Process *p, byte *bytes, int pos, Uint characters, + Eterm rest_term, int err, + byte *leftover, int num_leftovers, + Eterm latin1, int left) +{ + Eterm *hp; + + if (left <= 0) { + left = 1; + } + + if (err) { + if (num_leftovers > 0) { + Eterm leftover_bin = new_binary(p, leftover, num_leftovers); + hp = HAlloc(p,4); + rest_term = CONS(hp,rest_term,NIL); + hp += 2; + rest_term = CONS(hp,leftover_bin,rest_term); + } + BIF_RET(finalize_list_to_list(p, bytes, rest_term, 0U, pos, characters, UTF8_ERROR, left, NIL)); + } else if (rest_term == NIL && num_leftovers != 0) { + Eterm leftover_bin = new_binary(p, leftover, num_leftovers); + if (check_leftovers(leftover,num_leftovers) != 0) { + BIF_RET(finalize_list_to_list(p, bytes, leftover_bin, 0U, pos, characters, UTF8_ERROR, + left, NIL)); + } else { + BIF_RET(finalize_list_to_list(p, bytes, leftover_bin, 0U, pos, characters, UTF8_INCOMPLETE, + left, NIL)); + } + } else { /* All OK */ + if (rest_term != NIL) { /* Trap */ + RestartContext rc; + if (num_leftovers > 0) { + Eterm rest_bin = new_binary(p, leftover, num_leftovers); + hp = HAlloc(p,2); + rest_term = CONS(hp,rest_bin,rest_term); + } + BUMP_ALL_REDS(p); + rc.bytes = bytes; + rc.num_processed_bytes = 0; /* not used */ + rc.num_bytes_to_process = pos; + rc.num_resulting_chars = characters; + rc.state = UTF8_OK; /* not used */ + BIF_TRAP3(&characters_to_list_trap_1_exp, p, make_magic_bin_for_restart(p,&rc), + rest_term, latin1); + } else { /* Success */ + BIF_RET(finalize_list_to_list(p, bytes, NIL, 0U, pos, characters, UTF8_OK, left, NIL)); + } + } +} + +static BIF_RETTYPE characters_to_list_trap_1(BIF_ALIST_3) +{ + RestartContext *rc; + byte* bytes; + int pos; + Uint characters; + int err; + Eterm rest_term; + int left, sleft; + + int latin1 = 0; + byte leftover[4]; /* used for temp buffer too, + otherwise 3 bytes would have been enough */ + int num_leftovers = 0; + + + rc = get_rc_from_bin(BIF_ARG_1); + + bytes = rc->bytes; + rc->bytes = NULL; /* to avoid free due to later GC */ + pos = rc->num_bytes_to_process; + characters = rc->num_resulting_chars; + + sleft = left = allowed_iterations(BIF_P); + err = 0; + if (BIF_ARG_3 == am_latin1) { + latin1 = 1; + } + rest_term = do_build_utf8(BIF_P, BIF_ARG_2, &left, latin1, + bytes, &pos, &characters, &err, leftover, &num_leftovers); + cost_to_proc(BIF_P, sleft - left); + return build_list_return(BIF_P,bytes,pos,characters,rest_term,err, + leftover,num_leftovers,BIF_ARG_3,left); +} + +BIF_RETTYPE unicode_characters_to_list_2(BIF_ALIST_2) +{ + Sint need; + int latin1; + Uint characters = 0; + byte *bytes; + int pos; + int err; + int left, sleft; + Eterm rest_term; + byte leftover[4]; /* used for temp buffer too, o + therwise 3 bytes would have been enough */ + int num_leftovers = 0; + Uint cost_of_utf8_need; + + if (BIF_ARG_2 == am_latin1) { + latin1 = 1; + } else if (BIF_ARG_2 == am_unicode || BIF_ARG_2 == am_utf8) { + latin1 = 0; + } else { + BIF_TRAP2(c_to_l_int_trap_exportp, BIF_P, BIF_ARG_1, BIF_ARG_2); + } + if (is_binary(BIF_ARG_1) && !latin1) { /* Optimized behaviour for this case */ + return utf8_to_list(BIF_P,BIF_ARG_1); + } + need = utf8_need(BIF_ARG_1,latin1,&cost_of_utf8_need); + if (need < 0) { + BIF_ERROR(BIF_P,BADARG); + } + bytes = alloc_restart(need); + cost_to_proc(BIF_P, simple_loops_to_common(cost_of_utf8_need)); + left = allowed_iterations(BIF_P) - + simple_loops_to_common(cost_of_utf8_need); + if (left <= 0) { + /* simplified - let everything be setup by setting left to 1 */ + left = 1; + } + sleft = left; + pos = 0; + err = 0; + + + rest_term = do_build_utf8(BIF_P, BIF_ARG_1, &left, latin1, + bytes, &pos, &characters, &err, leftover, &num_leftovers); + cost_to_proc(BIF_P, sleft - left); + return build_list_return(BIF_P,bytes,pos,characters,rest_term,err, + leftover,num_leftovers,BIF_ARG_2,left); +} + + +/* + * When input to characters_to_list is a plain binary and the format is 'unicode', we do + * a faster analyze and size count with this function. + */ +static int analyze_utf8(byte *source, Uint size, + byte **err_pos, Uint *num_chars, int *left) +{ + *err_pos = source; + *num_chars = 0; + while (size) { + if (((*source) & ((byte) 0x80)) == 0) { + source++; + --size; + } else if (((*source) & ((byte) 0xE0)) == 0xC0) { + if (size < 2) { + return UTF8_INCOMPLETE; + } + if (((source[1] & ((byte) 0xC0)) != 0x80) || + ((*source) < 0xC2) /* overlong */) { + return UTF8_ERROR; + } + source += 2; + size -= 2; + } else if (((*source) & ((byte) 0xF0)) == 0xE0) { + if (size < 3) { + return UTF8_INCOMPLETE; + } + if (((source[1] & ((byte) 0xC0)) != 0x80) || + ((source[2] & ((byte) 0xC0)) != 0x80) || + (((*source) == 0xE0) && (source[1] < 0xA0)) /* overlong */ ) { + return UTF8_ERROR; + } + if ((((*source) & ((byte) 0xF)) == 0xD) && + ((source[1] & 0x20) != 0)) { + return UTF8_ERROR; + } + if (((*source) == 0xEF) && (source[1] == 0xBF) && + ((source[2] == 0xBE) || (source[2] == 0xBF))) { + return UTF8_ERROR; + } + source += 3; + size -= 3; + } else if (((*source) & ((byte) 0xF8)) == 0xF0) { + if (size < 4) { + return UTF8_INCOMPLETE; + } + if (((source[1] & ((byte) 0xC0)) != 0x80) || + ((source[2] & ((byte) 0xC0)) != 0x80) || + ((source[3] & ((byte) 0xC0)) != 0x80) || + (((*source) == 0xF0) && (source[1] < 0x90)) /* overlong */) { + return UTF8_ERROR; + } + if ((((*source) & ((byte)0x7)) > 0x4U) || + ((((*source) & ((byte)0x7)) == 0x4U) && + ((source[1] & ((byte)0x3F)) > 0xFU))) { + return UTF8_ERROR; + } + source += 4; + size -= 4; + } else { + return UTF8_ERROR; + } + ++(*num_chars); + *err_pos = source; + if (left && --(*left) <= 0) { + return UTF8_ANALYZE_MORE; + } + } + return UTF8_OK; +} + +/* + * No errors should be able to occur - no overlongs, no malformed, no nothing + */ +static Eterm do_utf8_to_list(Process *p, Uint num, byte *bytes, Uint sz, + Uint left, + Uint *num_built, Uint *num_eaten, Eterm tail) +{ + Eterm *hp; + Eterm ret; + byte *source, *ssource; + Uint unipoint; + + ASSERT(num > 0); + if (left < num) { + if (left > 0) + num = left; + else + num = 1; + } + + *num_built = num; /* Always */ + + hp = HAlloc(p,num * 2); + ret = tail; + source = bytes + sz; + ssource = source; + while(--source >= bytes) { + if (((*source) & ((byte) 0x80)) == 0) { + unipoint = (Uint) *source; + } else if (((*source) & ((byte) 0xE0)) == 0xC0) { + unipoint = + (((Uint) ((*source) & ((byte) 0x1F))) << 6) | + ((Uint) (source[1] & ((byte) 0x3F))); + } else if (((*source) & ((byte) 0xF0)) == 0xE0) { + unipoint = + (((Uint) ((*source) & ((byte) 0xF))) << 12) | + (((Uint) (source[1] & ((byte) 0x3F))) << 6) | + ((Uint) (source[2] & ((byte) 0x3F))); + } else if (((*source) & ((byte) 0xF8)) == 0xF0) { + unipoint = + (((Uint) ((*source) & ((byte) 0x7))) << 18) | + (((Uint) (source[1] & ((byte) 0x3F))) << 12) | + (((Uint) (source[2] & ((byte) 0x3F))) << 6) | + ((Uint) (source[3] & ((byte) 0x3F))); + } else { + /* ignore 2#10XXXXXX */ + continue; + } + ret = CONS(hp,make_small(unipoint),ret); + hp += 2; + if (--num <= 0) { + break; + } + } + *num_eaten = (ssource - source); + return ret; +} + +/* + * The last step of characters_to_list, build a list from the buffer 'bytes' (created in the same way + * as for characters_to_utf8). All sizes are known in advance and most data will be held in a + * "magic binary" during trapping. + */ +static BIF_RETTYPE finalize_list_to_list(Process *p, + byte *bytes, + Eterm rest, + Uint num_processed_bytes, + Uint num_bytes_to_process, + Uint num_resulting_chars, + int state, int left, + Eterm tail) +{ + Uint num_built; /* characters */ + Uint num_eaten; /* bytes */ + Eterm *hp; + Eterm converted,ret; + + if (!num_bytes_to_process) { + converted = tail; + } else { + num_built = 0; + num_eaten = 0; + converted = do_utf8_to_list(p, num_resulting_chars, + bytes, num_bytes_to_process, + left, &num_built, &num_eaten, tail); + cost_to_proc(p,num_built); + + if (num_built != num_resulting_chars) { /* work left to do */ + RestartContext rc; + + rc.num_resulting_chars = num_resulting_chars - num_built; + rc.num_bytes_to_process = num_bytes_to_process - num_eaten; + rc.num_processed_bytes = num_processed_bytes + num_eaten; + rc.state = state; + rc.bytes = bytes; + BUMP_ALL_REDS(p); + BIF_TRAP3(&characters_to_list_trap_2_exp, p, + make_magic_bin_for_restart(p, &rc), rest, converted); + } + } + + /* + * OK, no more trapping, let's get rid of the temporary array... + */ + + free_restart(bytes); + if (state == UTF8_INCOMPLETE) { + hp = HAlloc(p,4); + ret = TUPLE3(hp,am_incomplete,converted,rest); + } else if (state == UTF8_ERROR) { + hp = HAlloc(p,4); + ret = TUPLE3(hp,am_error,converted,rest); + } else { + ret = converted; + } + + BIF_RET(ret); +} + +static BIF_RETTYPE characters_to_list_trap_2(BIF_ALIST_3) +{ + RestartContext *rc; + byte *bytes; + + rc = get_rc_from_bin(BIF_ARG_1); + + bytes = rc->bytes; + rc->bytes = NULL; /* Don't want this freed just yet... */ + return finalize_list_to_list(BIF_P, bytes, BIF_ARG_2, rc->num_processed_bytes, + rc->num_bytes_to_process, rc->num_resulting_chars, + rc->state, allowed_iterations(BIF_P), BIF_ARG_3); +} + + +/* + * Hooks into the process of decoding a binary depending on state. + * If last_state is UTF8_ANALYZE_MORE, num_bytes_to_process + * and num_resulting_chars will grow + * until we're done analyzing the binary. Then we'll eat + * the bytes to process, lowering num_bytes_to_process and num_resulting_chars, + * while increasing num_processed_bytes until we're done. the state + * indicates how to return (error, incomplete or ok) in this stage. + * note that num_processed_bytes and num_bytes_to_process will make up the + * length of the binary part to process, not necessarily the length of the + * whole binary (if there are errors or an incomplete tail). + * + * Analyzing happens from the beginning of the binary towards the end, + * while result is built from the end of the analyzed/accepted part + * towards the beginning. + * + * Note that this routine is *only* called when original input was a plain utf8 binary, + * otherwise the rest and the sizes are known in advance, so finalize_list_to_list is + * used to build the resulting list (no analyzing needed). + */ +static BIF_RETTYPE do_bif_utf8_to_list(Process *p, + Eterm orig_bin, + Uint num_processed_bytes, + Uint num_bytes_to_process, + Uint num_resulting_chars, + int state, + Eterm tail) +{ + int left; + Uint bitoffs; + Uint bitsize; + Uint size; + byte *bytes; + Eterm converted = NIL; + Eterm rest = NIL; + Eterm *hp; + Eterm ret; + byte *temp_alloc = NULL; + byte *endpos; + Uint numchar; + + Uint b_sz; /* size of the non analyzed tail */ + Uint num_built; /* characters */ + Uint num_eaten; /* bytes */ + + ERTS_GET_BINARY_BYTES(orig_bin, bytes, bitoffs, bitsize); + if (bitsize != 0) { + converted = NIL; + rest = orig_bin; + goto error_return; + } + if (bitoffs != 0) { + bytes = erts_get_aligned_binary_bytes(orig_bin, &temp_alloc); + } + + size = binary_size(orig_bin); + + left = allowed_iterations(p); + + if (state == UTF8_ANALYZE_MORE) { + state = analyze_utf8(bytes + num_bytes_to_process, + size - num_bytes_to_process, + &endpos,&numchar,&left); + cost_to_proc(p,numchar); + num_resulting_chars += numchar; + num_bytes_to_process = endpos - bytes; + if (state == UTF8_ANALYZE_MORE) { + Eterm epos = erts_make_integer(num_bytes_to_process,p); + Eterm enumchar = erts_make_integer(num_resulting_chars,p); + erts_free_aligned_binary_bytes(temp_alloc); + BUMP_ALL_REDS(p); + BIF_TRAP3(&characters_to_list_trap_3_exp, p, orig_bin, epos, + enumchar); + } + } + + /* + * If we're here, we have everything analyzed and are instead building + */ + + + if (!num_bytes_to_process) { + converted = tail; + } else { + num_built = 0; + num_eaten = 0; + converted = do_utf8_to_list(p, num_resulting_chars, + bytes, num_bytes_to_process, + left, &num_built, &num_eaten, tail); + cost_to_proc(p,num_built); + + if (num_built != num_resulting_chars) { /* work left to do */ + Eterm newnum_resulting_chars = + erts_make_integer(num_resulting_chars - num_built,p); + Eterm newnum_bytes_to_process = + erts_make_integer(num_bytes_to_process - num_eaten,p); + Eterm newnum_processed_bytes = + erts_make_integer(num_processed_bytes + num_eaten,p); + Eterm traptuple; + hp = HAlloc(p,7); + traptuple = TUPLE6(hp,orig_bin,newnum_processed_bytes, + newnum_bytes_to_process, + newnum_resulting_chars, + make_small(state), + converted); + BUMP_ALL_REDS(p); + erts_free_aligned_binary_bytes(temp_alloc); + BIF_TRAP1(&characters_to_list_trap_4_exp,p,traptuple); + } + } + + /* + * OK, no more trapping, let's build rest binary if there should + * be one. + */ + + b_sz = size - (num_bytes_to_process + num_processed_bytes); + + if (b_sz) { + ErlSubBin *sb; + Eterm orig; + Uint offset; + ASSERT(state != UTF8_OK); + hp = HAlloc(p, ERL_SUB_BIN_SIZE); + sb = (ErlSubBin *) hp; + ERTS_GET_REAL_BIN(orig_bin, orig, offset, bitoffs, bitsize); + sb->thing_word = HEADER_SUB_BIN; + sb->size = b_sz; + sb->offs = num_bytes_to_process + num_processed_bytes; + sb->orig = orig; + sb->bitoffs = bitoffs; + sb->bitsize = bitsize; + sb->is_writable = 0; + rest = make_binary(sb); + } + + /* Done */ + + if (state == UTF8_INCOMPLETE) { + if (check_leftovers(bytes + num_bytes_to_process + num_processed_bytes, + b_sz) != 0) { + goto error_return; + } + hp = HAlloc(p,4); + ret = TUPLE3(hp,am_incomplete,converted,rest); + } else if (state == UTF8_ERROR) { + error_return: + hp = HAlloc(p,4); + ret = TUPLE3(hp,am_error,converted,rest); + } else { + ret = converted; + } + + erts_free_aligned_binary_bytes(temp_alloc); + BIF_RET(ret); +} + + +/* + * This is called when there's still analyzing left to do, + * we only reach this if original input was a binary. + */ + +static BIF_RETTYPE characters_to_list_trap_3(BIF_ALIST_3) +{ + Uint num_bytes_to_process; + Uint num_resulting_chars; + + term_to_Uint(BIF_ARG_2, &num_bytes_to_process); /* The number of already + analyzed and accepted + bytes */ + term_to_Uint(BIF_ARG_3, &num_resulting_chars); /* The number of chars + procuced by the + already analyzed + part of the binary */ + + /*erts_printf("Trap: %T, %T, %T\n",BIF_ARG_1, BIF_ARG_2, BIF_ARG_3);*/ + + return do_bif_utf8_to_list(BIF_P, + BIF_ARG_1, /* the binary */ + 0U, /* nothing processed yet */ + num_bytes_to_process, + num_resulting_chars, + UTF8_ANALYZE_MORE, /* always this state here */ + NIL); /* Nothing built -> no tail yet */ + +} + +/* + * This is called when analyzing is done and we are trapped during building, + * we only reach this if original input was a binary. + */ +static BIF_RETTYPE characters_to_list_trap_4(BIF_ALIST_1) +{ + Uint num_processed_bytes; + Uint num_bytes_to_process; + Uint num_resulting_chars; + Eterm orig_bin, tail; + int last_state; + Eterm *tplp = tuple_val(BIF_ARG_1); + + orig_bin = tplp[1]; + term_to_Uint(tplp[2], &num_processed_bytes); + term_to_Uint(tplp[3], &num_bytes_to_process); + term_to_Uint(tplp[4], &num_resulting_chars); + last_state = (int) signed_val(tplp[5]); + tail = tplp[6]; + + /*erts_printf("Trap: {%T, %lu, %lu, %lu, %d, %T}\n", + orig_bin, num_processed_bytes, num_bytes_to_process, + num_resulting_chars, last_state, tail);*/ + + return do_bif_utf8_to_list(BIF_P, + orig_bin, /* The whole binary */ + num_processed_bytes, /* Number of bytes + already processed */ + num_bytes_to_process, /* Bytes left to proc. */ + num_resulting_chars, /* Num chars left to + build */ + last_state, /* The current state + (never ANALYZE_MORE)*/ + tail); /* The already built + tail */ + +} +/* + * This is only used when characters are a plain unicode (utf8) binary. + * Instead of building an utf8 buffer, we analyze the binary given and use that. + */ + +static BIF_RETTYPE utf8_to_list(BIF_ALIST_1) +{ + if (!is_binary(BIF_ARG_1) || aligned_binary_size(BIF_ARG_1) < 0) { + BIF_ERROR(BIF_P,BADARG); + } + return do_bif_utf8_to_list(BIF_P, BIF_ARG_1, 0U, 0U, 0U, + UTF8_ANALYZE_MORE,NIL); +} + + +BIF_RETTYPE atom_to_binary_2(BIF_ALIST_2) +{ + Atom* ap; + + if (is_not_atom(BIF_ARG_1)) { + goto error; + } + + ap = atom_tab(atom_val(BIF_ARG_1)); + + if (BIF_ARG_2 == am_latin1) { + BIF_RET(new_binary(BIF_P, ap->name, ap->len)); + } else if (BIF_ARG_2 == am_utf8 || BIF_ARG_2 == am_unicode) { + int bin_size = 0; + int i; + Eterm bin_term; + byte* bin_p; + + for (i = 0; i < ap->len; i++) { + bin_size += (ap->name[i] >= 0x80) ? 2 : 1; + } + if (bin_size == ap->len) { + BIF_RET(new_binary(BIF_P, ap->name, ap->len)); + } + bin_term = new_binary(BIF_P, 0, bin_size); + bin_p = binary_bytes(bin_term); + for (i = 0; i < ap->len; i++) { + byte b = ap->name[i]; + if (b < 0x80) { + *bin_p++ = b; + } else { + *bin_p++ = 0xC0 | (b >> 6); + *bin_p++ = 0x80 | (b & 0x3F); + } + } + BIF_RET(bin_term); + } else { + error: + BIF_ERROR(BIF_P, BADARG); + } +} + +static BIF_RETTYPE +binary_to_atom(Process* p, Eterm bin, Eterm enc, int must_exist) +{ + byte* bytes; + byte *temp_alloc = NULL; + Uint bin_size; + + if ((bytes = erts_get_aligned_binary_bytes(bin, &temp_alloc)) == 0) { + BIF_ERROR(p, BADARG); + } + bin_size = binary_size(bin); + if (enc == am_latin1) { + Eterm a; + if (bin_size > MAX_ATOM_LENGTH) { + system_limit: + erts_free_aligned_binary_bytes(temp_alloc); + BIF_ERROR(p, SYSTEM_LIMIT); + } + if (!must_exist) { + a = am_atom_put((char *)bytes, bin_size); + erts_free_aligned_binary_bytes(temp_alloc); + BIF_RET(a); + } else if (erts_atom_get((char *)bytes, bin_size, &a)) { + erts_free_aligned_binary_bytes(temp_alloc); + BIF_RET(a); + } else { + goto badarg; + } + } else if (enc == am_utf8 || enc == am_unicode) { + char *buf; + char *dst; + int i; + int num_chars; + Eterm res; + + if (bin_size > 2*MAX_ATOM_LENGTH) { + byte* err_pos; + Uint n; + int reds_left = bin_size+1; /* Number of reductions left. */ + + if (analyze_utf8(bytes, bin_size, &err_pos, + &n, &reds_left) == UTF8_OK) { + /* + * Correct UTF-8 encoding, but too many characters to + * fit in an atom. + */ + goto system_limit; + } else { + /* + * Something wrong in the UTF-8 encoding or Unicode code + * points > 255. + */ + goto badarg; + } + } + + /* + * Allocate a temporary buffer the same size as the binary, + * so that we don't need an extra overflow test. + */ + buf = (char *) erts_alloc(ERTS_ALC_T_TMP, bin_size); + dst = buf; + for (i = 0; i < bin_size; i++) { + int c = bytes[i]; + if (c < 0x80) { + *dst++ = c; + } else if (i < bin_size-1) { + int c2; + if ((c & 0xE0) != 0xC0) { + goto free_badarg; + } + i++; + c = (c & 0x3F) << 6; + c2 = bytes[i]; + if ((c2 & 0xC0) != 0x80) { + goto free_badarg; + } + c = c | (c2 & 0x3F); + if (0x80 <= c && c < 256) { + *dst++ = c; + } else { + goto free_badarg; + } + } else { + free_badarg: + erts_free(ERTS_ALC_T_TMP, (void *) buf); + goto badarg; + } + } + num_chars = dst - buf; + if (num_chars > MAX_ATOM_LENGTH) { + erts_free(ERTS_ALC_T_TMP, (void *) buf); + goto system_limit; + } + if (!must_exist) { + res = am_atom_put(buf, num_chars); + erts_free(ERTS_ALC_T_TMP, (void *) buf); + erts_free_aligned_binary_bytes(temp_alloc); + BIF_RET(res); + } else { + int exists = erts_atom_get(buf, num_chars, &res); + erts_free(ERTS_ALC_T_TMP, (void *) buf); + if (exists) { + erts_free_aligned_binary_bytes(temp_alloc); + BIF_RET(res); + } else { + goto badarg; + } + } + } else { + badarg: + erts_free_aligned_binary_bytes(temp_alloc); + BIF_ERROR(p, BADARG); + } +} + +BIF_RETTYPE binary_to_atom_2(BIF_ALIST_2) +{ + return binary_to_atom(BIF_P, BIF_ARG_1, BIF_ARG_2, 0); +} + +BIF_RETTYPE binary_to_existing_atom_2(BIF_ALIST_2) +{ + return binary_to_atom(BIF_P, BIF_ARG_1, BIF_ARG_2, 1); +} diff --git a/erts/emulator/beam/erl_unicode.h b/erts/emulator/beam/erl_unicode.h new file mode 100644 index 0000000000..1b63b797c2 --- /dev/null +++ b/erts/emulator/beam/erl_unicode.h @@ -0,0 +1,23 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2008-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifndef _ERL_UNICODE_H +#define _ERL_UNICODE_H + +#endif /* _ERL_UNICODE_H */ diff --git a/erts/emulator/beam/erl_vm.h b/erts/emulator/beam/erl_vm.h new file mode 100644 index 0000000000..4d8315ab95 --- /dev/null +++ b/erts/emulator/beam/erl_vm.h @@ -0,0 +1,204 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifndef __ERL_VM_H__ +#define __ERL_VM_H__ + +/* #define ERTS_OPCODE_COUNTER_SUPPORT */ + +#if defined(HYBRID) +/* # define CHECK_FOR_HOLES */ +#endif + +#if defined(DEBUG) && !defined(CHECK_FOR_HOLES) && !defined(__WIN32__) +# define CHECK_FOR_HOLES +#endif + +#if defined(HYBRID) +/* # define INCREMENTAL 1 */ /* Incremental garbage collection */ +/* # define INC_TIME_BASED 1 */ /* Time-based incremental GC (vs Work-based) */ +#endif + +#define BEAM 1 +#define EMULATOR "BEAM" +#define SEQ_TRACE 1 + +#define CONTEXT_REDS 2000 /* Swap process out after this number */ +#define MAX_ARG 256 /* Max number of arguments allowed */ +#define MAX_REG 1024 /* Max number of x(N) registers used */ + +/* + * The new arithmetic operations need some extra X registers in the register array. + */ +#define ERTS_X_REGS_ALLOCATED (MAX_REG+2) + +#define INPUT_REDUCTIONS (2 * CONTEXT_REDS) + +#define H_DEFAULT_SIZE 233 /* default (heap + stack) min size */ + +#ifdef HYBRID +# define SH_DEFAULT_SIZE 2629425 /* default message area min size */ +#endif + +#ifdef INCREMENTAL +# define INC_NoPAGES 256 /* Number of pages in the old generation */ +# define INC_PAGESIZE 32768 /* The size of each page */ +# define INC_STORAGE_SIZE 1024 /* The size of gray stack and similar */ +#endif + +#define CP_SIZE 1 + +#define ErtsHAllocLockCheck(P) \ + ERTS_SMP_LC_ASSERT((ERTS_PROC_LOCK_MAIN & erts_proc_lc_my_proc_locks((P))) \ + || ((P)->scheduler_data \ + && (P) == (P)->scheduler_data->match_pseudo_process) \ + || erts_is_system_blocked(0)) + +#ifdef DEBUG +/* + * Debug HAlloc that initialize all memory to bad things. + * + * To get information about where memory is allocated, insert the two + * lines below directly after the memset line and use the flag +va. + * + VERBOSE(DEBUG_ALLOCATION,("HAlloc @ 0x%08lx (%d) %s:%d\n", \ + (unsigned long)HEAP_TOP(p),(sz),__FILE__,__LINE__)), \ + */ +#ifdef CHECK_FOR_HOLES +#define HAlloc(p, sz) \ + (ASSERT_EXPR((sz) >= 0), \ + ErtsHAllocLockCheck(p), \ + ((((HEAP_LIMIT(p) - HEAP_TOP(p)) < (sz))) \ + ? erts_heap_alloc((p),(sz)) \ + : (erts_set_hole_marker(HEAP_TOP(p), (sz)), \ + HEAP_TOP(p) = HEAP_TOP(p) + (sz), HEAP_TOP(p) - (sz)))) +#else +#define HAlloc(p, sz) \ + (ASSERT_EXPR((sz) >= 0), \ + ErtsHAllocLockCheck(p), \ + ((((HEAP_LIMIT(p) - HEAP_TOP(p)) < (sz))) \ + ? erts_heap_alloc((p),(sz)) \ + : (memset(HEAP_TOP(p),DEBUG_BAD_BYTE,(sz)*sizeof(Eterm*)), \ + HEAP_TOP(p) = HEAP_TOP(p) + (sz), HEAP_TOP(p) - (sz)))) +#endif +#else + +/* + * Allocate heap memory, first on the ordinary heap; + * failing that, in a heap fragment. + */ +#define HAlloc(p, sz) \ + (ASSERT_EXPR((sz) >= 0), \ + ErtsHAllocLockCheck(p), \ + ((((HEAP_LIMIT(p) - HEAP_TOP(p)) < (sz))) \ + ? erts_heap_alloc((p),(sz)) \ + : (HEAP_TOP(p) = HEAP_TOP(p) + (sz), HEAP_TOP(p) - (sz)))) + +#endif /* DEBUG */ + +#if defined(CHECK_FOR_HOLES) +# define HRelease(p, endp, ptr) \ + if ((ptr) == (endp)) { \ + ; \ + } else if (HEAP_START(p) <= (ptr) && (ptr) < HEAP_TOP(p)) { \ + HEAP_TOP(p) = (ptr); \ + } else { \ + erts_arith_shrink(p, ptr); \ + } +#else +# define HRelease(p, endp, ptr) \ + if ((ptr) == (endp)) { \ + ; \ + } else if (HEAP_START(p) <= (ptr) && (ptr) < HEAP_TOP(p)) { \ + HEAP_TOP(p) = (ptr); \ + } +#endif + +#define HeapWordsLeft(p) (HEAP_LIMIT(p) - HEAP_TOP(p)) + +#if defined(DEBUG) || defined(CHECK_FOR_HOLES) +# define ERTS_HOLE_MARKER (((0xaf5e78ccUL << 24) << 8) | 0xaf5e78ccUL) +#endif + +/* + * Allocate heap memory on the ordinary heap, NEVER in a heap + * segment. The caller must ensure that there is enough words + * left on the heap before calling HeapOnlyAlloc() (for instance, + * by testing HeapWordsLeft() and calling the garbage collector + * if not enough). + */ +#ifdef CHECK_FOR_HOLES +# define HeapOnlyAlloc(p, sz) \ + (ASSERT_EXPR((sz) >= 0), \ + (ASSERT_EXPR(((HEAP_LIMIT(p) - HEAP_TOP(p)) >= (sz))), \ + (erts_set_hole_marker(HEAP_TOP(p), (sz)), \ + (HEAP_TOP(p) = HEAP_TOP(p) + (sz), HEAP_TOP(p) - (sz))))) +#else +# define HeapOnlyAlloc(p, sz) \ + (ASSERT_EXPR((sz) >= 0), \ + (ASSERT_EXPR(((HEAP_LIMIT(p) - HEAP_TOP(p)) >= (sz))), \ + (HEAP_TOP(p) = HEAP_TOP(p) + (sz), HEAP_TOP(p) - (sz)))) +#endif + + +/* + * Description for each instruction (defined here because the name and + * count fields are interesting outside the emulator proper). + */ + +typedef struct op_entry { + char* name; /* Name of instruction. */ + Uint32 mask[3]; /* Signature mask. */ + int sz; /* Number of loaded words. */ + char* pack; /* Instructions for packing engine. */ + char* sign; /* Signature string. */ + unsigned count; /* Number of times executed. */ +} OpEntry; + +extern OpEntry opc[]; /* Description of all instructions. */ +extern int num_instructions; /* Number of instruction in opc[]. */ + +/* some constants for various table sizes etc */ + +#define ATOM_TEXT_SIZE 32768 /* Increment for allocating atom text space */ + +#define ITIME 100 /* Number of milliseconds per clock tick */ +#define MAX_PORT_LINK 8 /* Maximum number of links to a port */ + +extern int H_MIN_SIZE; /* minimum (heap + stack) */ + +#define ORIG_CREATION 0 + +/* macros for extracting bytes from uint16's */ + +#define hi_byte(a) ((a) >> 8) +#define lo_byte(a) ((a) & 255) + +/* macros for combining bytes */ + +#define make_16(x, y) (((x) << 8) | (y)) +#define make_24(x,y,z) (((x) << 16) | ((y) << 8) | (z)) +#define make_32(x3,x2,x1,x0) (((x3)<<24) | ((x2)<<16) | ((x1)<<8) | (x0)) + +#define make_signed_24(x,y,z) ((sint32) (((x) << 24) | ((y) << 16) | ((z) << 8)) >> 8) +#define make_signed_32(x3,x2,x1,x0) ((sint32) (((x3) << 24) | ((x2) << 16) | ((x1) << 8) | (x0))) + +#include "erl_term.h" + +#endif /* __ERL_VM_H__ */ diff --git a/erts/emulator/beam/erl_zlib.c b/erts/emulator/beam/erl_zlib.c new file mode 100644 index 0000000000..f73d48b6c2 --- /dev/null +++ b/erts/emulator/beam/erl_zlib.c @@ -0,0 +1,113 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* A sparse wrapper around zlib with erts memory allocation. + * + * erl_zlib_compress2 and erl_zlib_uncompress are erts-adapted versions + * of the original compress2 and uncompress from zlib-1.2.3. + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "erl_zlib.h" + +#include "sys.h" +#include "erl_alloc.h" + +voidpf erl_zlib_zalloc_callback (voidpf opaque, unsigned items, unsigned size) +{ + (void) opaque; /* make compiler happy */ + return erts_alloc_fnf(ERTS_ALC_T_ZLIB, items * size); +} + +void erl_zlib_zfree_callback (voidpf opaque, voidpf ptr) +{ + (void) opaque; /* make compiler happy */ + erts_free(ERTS_ALC_T_ZLIB, ptr); +} + + +int ZEXPORT erl_zlib_compress2 (Bytef* dest, uLongf* destLen, + const Bytef* source, uLong sourceLen, + int level) +{ + z_stream stream; + int err; + + stream.next_in = (Bytef*)source; + stream.avail_in = (uInt)sourceLen; +#ifdef MAXSEG_64K + /* Check for source > 64K on 16-bit machine: */ + if ((uLong)stream.avail_in != sourceLen) return Z_BUF_ERROR; +#endif + stream.next_out = dest; + stream.avail_out = (uInt)*destLen; + if ((uLong)stream.avail_out != *destLen) return Z_BUF_ERROR; + + erl_zlib_alloc_init(&stream); + + err = deflateInit(&stream, level); + if (err != Z_OK) return err; + + err = deflate(&stream, Z_FINISH); + if (err != Z_STREAM_END) { + deflateEnd(&stream); + return err == Z_OK ? Z_BUF_ERROR : err; + } + *destLen = stream.total_out; + + err = deflateEnd(&stream); + return err; +} + +int ZEXPORT erl_zlib_uncompress (Bytef* dest, uLongf* destLen, + const Bytef* source, uLong sourceLen) +{ + z_stream stream; + int err; + + stream.next_in = (Bytef*)source; + stream.avail_in = (uInt)sourceLen; + /* Check for source > 64K on 16-bit machine: */ + if ((uLong)stream.avail_in != sourceLen) return Z_BUF_ERROR; + + stream.next_out = dest; + stream.avail_out = (uInt)*destLen; + if ((uLong)stream.avail_out != *destLen) return Z_BUF_ERROR; + + erl_zlib_alloc_init(&stream); + + err = inflateInit(&stream); + if (err != Z_OK) return err; + + err = inflate(&stream, Z_FINISH); + if (err != Z_STREAM_END) { + inflateEnd(&stream); + if (err == Z_NEED_DICT || (err == Z_BUF_ERROR && stream.avail_in == 0)) + return Z_DATA_ERROR; + return err; + } + *destLen = stream.total_out; + + err = inflateEnd(&stream); + return err; +} + diff --git a/erts/emulator/beam/erl_zlib.h b/erts/emulator/beam/erl_zlib.h new file mode 100644 index 0000000000..9054a5e428 --- /dev/null +++ b/erts/emulator/beam/erl_zlib.h @@ -0,0 +1,52 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* A sparse wrapper interface around zlib with erts memory allocation. +*/ + +#include + + +/* Initialize zalloc, zfree and opaque of a z_stream +*/ +#define erl_zlib_alloc_init(s) \ + do { /* 'opaque' not used */ \ + (s)->zalloc = erl_zlib_zalloc_callback; \ + (s)->zfree = erl_zlib_zfree_callback; \ + } while (0) + +/* Use instead of compress +*/ +#define erl_zlib_compress(dest,destLen,source,sourceLen) \ + erl_zlib_compress2(dest,destLen,source,sourceLen,Z_DEFAULT_COMPRESSION) + +/* Use instead of compress2 +*/ +int ZEXPORT erl_zlib_compress2 (Bytef* dest, uLongf* destLen, + const Bytef* source, uLong sourceLen, + int level); +/* Use instead of uncompress +*/ +int ZEXPORT erl_zlib_uncompress (Bytef* dest, uLongf* destLen, + const Bytef* source, uLong sourceLen); + + +voidpf erl_zlib_zalloc_callback (voidpf,unsigned,unsigned); +void erl_zlib_zfree_callback (voidpf,voidpf); + diff --git a/erts/emulator/beam/error.h b/erts/emulator/beam/error.h new file mode 100644 index 0000000000..4930def4ed --- /dev/null +++ b/erts/emulator/beam/error.h @@ -0,0 +1,196 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifndef __ERROR_H__ +#define __ERROR_H__ + +/* + * There are three primary exception classes: + * + * - exit Process termination - not an error. + * - error Error (adds stacktrace; will be logged). + * - thrown Nonlocal return (turns into a 'nocatch' + * error if not caught by the process). + * + * In addition, we define a number of exit codes as a convenient + * short-hand: instead of building the error descriptor term at the time + * the exception is raised, it is built as necessary when the exception + * is handled. Examples are EXC_NORMAL, EXC_BADARG, EXC_BADARITH, etc. + * Some of these have convenient aliases, like BADARG and BADARITH. + */ + +/* + * Bits 0-1 index the 'exception class tag' table. + */ +#define EXC_CLASSBITS 3 +#define GET_EXC_CLASS(x) ((x) & EXC_CLASSBITS) + +/* + * Exception class tags (indices into the 'exception_tag' array) + */ +#define EXTAG_ERROR 0 +#define EXTAG_EXIT 1 +#define EXTAG_THROWN 2 + +#define NUMBER_EXC_TAGS 3 /* The number of exception class tags */ + +/* + * Exit code flags (bits 2-7) + * + * These flags make is easier and quicker to decide what to do with the + * exception in the early stages, before a handler is found, and also + * maintains some separation between the class tag and the actions. + */ +#define EXF_PANIC (1<<2) /* ignore catches */ +#define EXF_THROWN (1<<3) /* nonlocal return */ +#define EXF_LOG (1<<4) /* write to logger on termination */ +#define EXF_NATIVE (1<<5) /* occurred in native code */ +#define EXF_SAVETRACE (1<<6) /* save stack trace in internal form */ +#define EXF_ARGLIST (1<<7) /* has arglist for top of trace */ + +#define EXC_FLAGBITS 0x00fc + +/* + * The primary fields of an exception code + */ +#define EXF_PRIMARY (EXF_PANIC | EXF_THROWN | EXF_LOG | EXF_NATIVE) +#define PRIMARY_EXCEPTION(x) ((x) & (EXF_PRIMARY | EXC_CLASSBITS)) +#define NATIVE_EXCEPTION(x) ((x) | EXF_NATIVE) + +/* + * Bits 8-12 of the error code are used for indexing into + * the short-hand error descriptor table. + */ +#define EXC_INDEXBITS 0x1f00 +#define GET_EXC_INDEX(x) (((x) & EXC_INDEXBITS) >> 8) + +/* + * Exit codes used for raising a fresh exception. The primary exceptions + * share index 0 in the descriptor table. EXC_NULL signals that no + * exception has occurred. The primary exit codes EXC_EXIT, EXC_ERROR + * and EXC_THROWN are the basis for all other exit codes, and must + * always have the EXF_SAVETRACE flag set so that a trace is saved + * whenever a new exception occurs; the flag is then cleared. + */ +#define EXC_NULL 0 /* Initial value for p->freason */ +#define EXC_PRIMARY (0 | EXF_SAVETRACE) +#define EXC_ERROR (EXC_PRIMARY | EXTAG_ERROR | EXF_LOG) + /* Generic error (exit term + * in p->fvalue) */ +#define EXC_EXIT (EXC_PRIMARY | EXTAG_EXIT) + /* Generic exit (exit term + * in p->fvalue) */ +#define EXC_THROWN (EXC_PRIMARY | EXTAG_THROWN | EXF_THROWN) + /* Generic nonlocal return + * (thrown term in p->fvalue) */ + +#define EXC_ERROR_2 (EXC_ERROR | EXF_ARGLIST) + /* Error with given arglist term + * (exit reason in p->fvalue) */ + +#define EXC_NORMAL ((1 << 8) | EXC_EXIT) + /* Normal exit (reason 'normal') */ +#define EXC_INTERNAL_ERROR ((2 << 8) | EXC_ERROR | EXF_PANIC) + /* Things that shouldn't happen */ +#define EXC_BADARG ((3 << 8) | EXC_ERROR) + /* Bad argument to a BIF */ +#define EXC_BADARITH ((4 << 8) | EXC_ERROR) + /* Bad arithmetic */ +#define EXC_BADMATCH ((5 << 8) | EXC_ERROR) + /* Bad match in function body */ +#define EXC_FUNCTION_CLAUSE ((6 << 8) | EXC_ERROR) + /* No matching function head */ +#define EXC_CASE_CLAUSE ((7 << 8) | EXC_ERROR) + /* No matching case clause */ +#define EXC_IF_CLAUSE ((8 << 8) | EXC_ERROR) + /* No matching if clause */ +#define EXC_UNDEF ((9 << 8) | EXC_ERROR) + /* No farity that matches */ +#define EXC_BADFUN ((10 << 8) | EXC_ERROR) + /* Not an existing fun */ +#define EXC_BADARITY ((11 << 8) | EXC_ERROR) + /* Attempt to call fun with + * wrong number of arguments. */ +#define EXC_TIMEOUT_VALUE ((12 << 8) | EXC_ERROR) + /* Bad time out value */ +#define EXC_NOPROC ((13 << 8) | EXC_ERROR) + /* No process or port */ +#define EXC_NOTALIVE ((14 << 8) | EXC_ERROR) + /* Not distributed */ +#define EXC_SYSTEM_LIMIT ((15 << 8) | EXC_ERROR) + /* Ran out of something */ +#define EXC_TRY_CLAUSE ((16 << 8) | EXC_ERROR) + /* No matching try clause */ +#define EXC_NOTSUP ((17 << 8) | EXC_ERROR) + /* Not supported */ + +#define NUMBER_EXIT_CODES 18 /* The number of exit code indices */ + +/* + * Internal pseudo-error codes. + */ +#define TRAP (1 << 8) /* BIF Trap to erlang code */ + +/* + * Aliases for some common exit codes. + */ +#define BADARG EXC_BADARG +#define BADARITH EXC_BADARITH +#define BADMATCH EXC_BADMATCH +#define SYSTEM_LIMIT EXC_SYSTEM_LIMIT + + +/* + * Pseudo error codes (these are never seen by the user). + */ +#define TLOAD_OK 0 /* The threaded code linking was successful */ +#define TLOAD_MAGIC_NUMBER 1 /* Wrong kind of object file */ +#define TLOAD_FORMAT 2 /* Format error while reading object code */ +#define TLOAD_MODULE 3 /* Module name in object code does not match */ +#define TLOAD_SIZE 4 /* Given size in object code differs from actual size */ + +/* + * The exception stack trace parameters. + */ +#define MAX_BACKTRACE_SIZE 64 /* whatever - just not too huge */ +#define DEFAULT_BACKTRACE_SIZE 8 + +/* + * The table translating an exception code to an atom. + */ +extern Eterm error_atom[NUMBER_EXIT_CODES]; + +/* + * The exception tag table. + */ +extern Eterm exception_tag[NUMBER_EXC_TAGS]; + +/* + * The quick-saved stack trace structure + */ +struct StackTrace { + Eterm header; /* bignum header - must be first in struct */ + Eterm freason; /* original exception reason is saved in the struct */ + Eterm* pc; + Eterm* current; + int depth; /* number of saved pointers in trace[] */ + Eterm *trace[1]; /* varying size - must be last in struct */ +}; + +#endif /* __ERROR_H__ */ diff --git a/erts/emulator/beam/export.c b/erts/emulator/beam/export.c new file mode 100644 index 0000000000..271b40cf0f --- /dev/null +++ b/erts/emulator/beam/export.c @@ -0,0 +1,296 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "export.h" +#include "hash.h" + +#define EXPORT_INITIAL_SIZE 4000 +#define EXPORT_LIMIT (512*1024) + +#define EXPORT_HASH(m,f,a) ((m)*(f)+(a)) + +static IndexTable export_table; /* Not locked. */ +static Hash secondary_export_table; /* Locked. */ + +#include "erl_smp.h" + +static erts_smp_rwmtx_t export_table_lock; /* Locks the secondary export table. */ + +#define export_read_lock() erts_smp_rwmtx_rlock(&export_table_lock) +#define export_read_unlock() erts_smp_rwmtx_runlock(&export_table_lock) +#define export_write_lock() erts_smp_rwmtx_rwlock(&export_table_lock) +#define export_write_unlock() erts_smp_rwmtx_rwunlock(&export_table_lock) +#define export_init_lock() erts_smp_rwmtx_init(&export_table_lock, \ + "export_tab") + +extern Eterm* em_call_error_handler; +extern Uint* em_call_traced_function; + +void +export_info(int to, void *to_arg) +{ +#ifdef ERTS_SMP + int lock = !ERTS_IS_CRASH_DUMPING; + if (lock) + export_read_lock(); +#endif + index_info(to, to_arg, &export_table); + hash_info(to, to_arg, &secondary_export_table); +#ifdef ERTS_SMP + if (lock) + export_read_unlock(); +#endif +} + + +static HashValue +export_hash(Export* x) +{ + return EXPORT_HASH(x->code[0], x->code[1], x->code[2]); +} + +static int +export_cmp(Export* tmpl, Export* obj) +{ + return !(tmpl->code[0] == obj->code[0] && + tmpl->code[1] == obj->code[1] && + tmpl->code[2] == obj->code[2]); +} + + +static Export* +export_alloc(Export* tmpl) +{ + Export* obj = (Export*) erts_alloc(ERTS_ALC_T_EXPORT, sizeof(Export)); + + obj->fake_op_func_info_for_hipe[0] = 0; + obj->fake_op_func_info_for_hipe[1] = 0; + obj->code[0] = tmpl->code[0]; + obj->code[1] = tmpl->code[1]; + obj->code[2] = tmpl->code[2]; + obj->slot.index = -1; + obj->address = obj->code+3; + obj->code[3] = (Eterm) em_call_error_handler; + obj->code[4] = 0; + obj->match_prog_set = NULL; + return obj; +} + + +static void +export_free(Export* obj) +{ + erts_free(ERTS_ALC_T_EXPORT, (void*) obj); +} + + +void +init_export_table(void) +{ + HashFunctions f; + + export_init_lock(); + f.hash = (H_FUN) export_hash; + f.cmp = (HCMP_FUN) export_cmp; + f.alloc = (HALLOC_FUN) export_alloc; + f.free = (HFREE_FUN) export_free; + + erts_index_init(ERTS_ALC_T_EXPORT_TABLE, &export_table, "export_list", + EXPORT_INITIAL_SIZE, EXPORT_LIMIT, f); + hash_init(ERTS_ALC_T_EXPORT_TABLE, &secondary_export_table, + "secondary_export_table", 50, f); +} + +/* + * Return a pointer to the export entry for the given function, + * or NULL otherwise. Notes: + * + * 1) BIFs have export entries and can be called through + * a wrapper in the export entry. + * 2) Functions referenced by a loaded module, but not yet loaded + * also have export entries. The export entry contains + * a wrapper which invokes the error handler if a function is + * called through such an export entry. + * 3) This function is suitable for the implementation of erlang:apply/3. + */ + +Export* +erts_find_export_entry(Eterm m, Eterm f, unsigned int a) +{ + HashValue hval = EXPORT_HASH(m, f, a); + int ix; + HashBucket* b; + + ix = hval % export_table.htable.size; + b = export_table.htable.bucket[ix]; + + /* + * Note: We have inlined the code from hash.c for speed. + */ + + while (b != (HashBucket*) 0) { + Export* ep = (Export *) b; + if (ep->code[0] == m && ep->code[1] == f && ep->code[2] == a) { + break; + } + b = b->next; + } + return (Export*)b; +} + + +/* + * Find the export entry for a loaded function. + * Returns a NULL pointer if the given function is not loaded, or + * a pointer to the export entry. + * + * Note: This function never returns export entries for BIFs + * or functions which are not yet loaded. This makes it suitable + * for use by the erlang:function_exported/3 BIF or whenever you + * cannot depend on the error_handler. + */ + +Export* +erts_find_function(Eterm m, Eterm f, unsigned int a) +{ + Export e; + Export* ep; + + e.code[0] = m; + e.code[1] = f; + e.code[2] = a; + + ep = hash_get(&export_table.htable, (void*) &e); + if (ep != NULL && ep->address == ep->code+3 && + ep->code[3] != (Uint) em_call_traced_function) { + ep = NULL; + } + return ep; +} + +/* + * Returns a pointer to an existing export entry for a MFA, + * or creates a new one and returns the pointer. + * + * This function provides unlocked write access to the main export + * table. It should only be used during start up or when + * all other threads are blocked. + */ + +Export* +erts_export_put(Eterm mod, Eterm func, unsigned int arity) +{ + Export e; + int ix; + + ERTS_SMP_LC_ASSERT(erts_initialized == 0 || erts_smp_is_system_blocked(0)); + ASSERT(is_atom(mod)); + ASSERT(is_atom(func)); + e.code[0] = mod; + e.code[1] = func; + e.code[2] = arity; + ix = index_put(&export_table, (void*) &e); + return (Export*) erts_index_lookup(&export_table, ix); +} + +/* + * Find the existing export entry for M:F/A. Failing that, create a stub + * export entry (making a call through it will cause the error_handler to + * be called). + * + * Stub export entries will be placed in the secondary export table. + * erts_export_consolidate() will move all stub export entries into the + * main export table (will be done the next time code is loaded). + */ + +Export* +erts_export_get_or_make_stub(Eterm mod, Eterm func, unsigned int arity) +{ + Export e; + Export* ep; + + ASSERT(is_atom(mod)); + ASSERT(is_atom(func)); + + e.code[0] = mod; + e.code[1] = func; + e.code[2] = arity; + ep = erts_find_export_entry(mod, func, arity); + if (ep == 0) { + /* + * The code is not loaded (yet). Put the export in the secondary + * export table, to avoid having to lock the main export table. + */ + export_write_lock(); + ep = (Export *) hash_put(&secondary_export_table, (void*) &e); + export_write_unlock(); + } + return ep; +} + +/* + * To be called before loading code (with other threads blocked). + * This function will move all export entries from the secondary + * export table into the primary. + */ +void +erts_export_consolidate(void) +{ +#ifdef DEBUG + HashInfo hi; +#endif + + ERTS_SMP_LC_ASSERT(erts_initialized == 0 || erts_smp_is_system_blocked(0)); + + export_write_lock(); + erts_index_merge(&secondary_export_table, &export_table); + erts_hash_merge(&secondary_export_table, &export_table.htable); + export_write_unlock(); +#ifdef DEBUG + hash_get_info(&hi, &export_table.htable); + ASSERT(export_table.entries == hi.objs); +#endif +} + +Export *export_list(int i) +{ + return (Export*) erts_index_lookup(&export_table, i); +} + +int export_list_size(void) +{ + return export_table.entries; +} + +int export_table_sz(void) +{ + return index_table_sz(&export_table); +} + +Export *export_get(Export *e) +{ + return hash_get(&export_table.htable, e); +} diff --git a/erts/emulator/beam/export.h b/erts/emulator/beam/export.h new file mode 100644 index 0000000000..cd6af6dd85 --- /dev/null +++ b/erts/emulator/beam/export.h @@ -0,0 +1,79 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifndef __EXPORT_H__ +#define __EXPORT_H__ + +#ifndef __SYS_H__ +#include "sys.h" +#endif + +#ifndef __INDEX_H__ +#include "index.h" +#endif + +/* +** Export entry +*/ +typedef struct export +{ + IndexSlot slot; /* MUST BE LOCATED AT TOP OF STRUCT!!! */ + void* address; /* Pointer to code for function. */ + struct binary* match_prog_set; /* Match program for tracing. */ + + Eterm fake_op_func_info_for_hipe[2]; /* MUST be just before code[] */ + /* + * code[0]: Tagged atom for module. + * code[1]: Tagged atom for function. + * code[2]: Arity (untagged integer). + * code[3]: This entry is 0 unless the 'address' field points to it. + * Threaded code instruction to load function + * (em_call_error_handler), execute BIF (em_apply_bif, + * em_apply_apply), or call a traced function + * (em_call_traced_function). + * code[4]: Function pointer to BIF function (for BIFs only) + * or pointer to threaded code if the module has an + * on_load function that has not been run yet. + * Otherwise: 0. + */ + Eterm code[5]; +} Export; + + +void init_export_table(void); +void export_info(int, void *); + +Export* erts_find_export_entry(Eterm m, Eterm f, unsigned int a); +Export* erts_export_put(Eterm mod, Eterm func, unsigned int arity); + + +Export* erts_export_get_or_make_stub(Eterm, Eterm, unsigned); +void erts_export_consolidate(void); + +Export *export_list(int); +int export_list_size(void); +int export_table_sz(void); +Export *export_get(Export*); + +#include "beam_load.h" /* For em_* extern declarations */ +#define ExportIsBuiltIn(EntryPtr) \ +(((EntryPtr)->address == (EntryPtr)->code + 3) && \ + ((EntryPtr)->code[3] == (Uint) em_apply_bif)) + +#endif diff --git a/erts/emulator/beam/external.c b/erts/emulator/beam/external.c new file mode 100644 index 0000000000..f856cce18f --- /dev/null +++ b/erts/emulator/beam/external.c @@ -0,0 +1,2839 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* Implementation of the erlang external format + * + * And a nice cache mechanism which is used just to send a + * index indicating a specific atom to a remote node instead of the + * entire atom. + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#define ERTS_WANT_EXTERNAL_TAGS + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "erl_process.h" +#include "error.h" +#include "external.h" +#include "bif.h" +#include "big.h" +#include "dist.h" +#include "erl_binary.h" +#include "erl_bits.h" +#include "erl_zlib.h" + +#ifdef HIPE +#include "hipe_mode_switch.h" +#endif +#define in_area(ptr,start,nbytes) ((Uint)((char*)(ptr) - (char*)(start)) < (nbytes)) + +#define MAX_STRING_LEN 0xffff +#define dec_set_creation(nodename,creat) \ + (((nodename) == erts_this_node->sysname && (creat) == ORIG_CREATION) \ + ? erts_this_node->creation \ + : (creat)) + +#undef ERTS_DEBUG_USE_DIST_SEP +#ifdef DEBUG +# if 0 +/* + * Enabling ERTS_DEBUG_USE_DIST_SEP can be useful when debugging, but the + * result refuses to talk to nodes without it! + */ +# define ERTS_DEBUG_USE_DIST_SEP +# endif +#endif + +/* + * For backward compatibility reasons, only encode integers that + * fit in 28 bits (signed) using INTEGER_EXT. + */ +#define IS_SSMALL28(x) (((Uint) (((x) >> (28-1)) + 1)) < 2) + +/* + * Valid creations for nodes are 1, 2, or 3. 0 can also be sent + * as creation, though. When 0 is used as creation, the real creation + * is unknown. Creation 0 on data will be changed to current + * creation of the node which it belongs to when it enters + * that node. + * This typically happens when a remote pid is created with + * list_to_pid/1 and then sent to the remote node. This behavior + * has the undesirable effect that a pid can be passed between nodes, + * and as a result of that not being equal to itself (the pid that + * comes back isn't equal to the original pid). + * + */ + +static byte* enc_term(ErtsAtomCacheMap *, Eterm, byte*, Uint32); +static Uint is_external_string(Eterm obj, int* p_is_string); +static byte* enc_atom(ErtsAtomCacheMap *, Eterm, byte*, Uint32); +static byte* enc_pid(ErtsAtomCacheMap *, Eterm, byte*, Uint32); +static byte* dec_term(ErtsDistExternal *, Eterm**, byte*, ErlOffHeap*, Eterm*); +static byte* dec_atom(ErtsDistExternal *, byte*, Eterm*); +static byte* dec_pid(ErtsDistExternal *, Eterm**, byte*, ErlOffHeap*, Eterm*); +static Sint decoded_size(byte *ep, byte* endp, int only_heap_bins); + + +static Uint encode_size_struct2(ErtsAtomCacheMap *, Eterm, unsigned); + +#define ERTS_MAX_INTERNAL_ATOM_CACHE_ENTRIES 255 + +#define ERTS_DIST_HDR_ATOM_CACHE_FLAG_BYTE_IX(IIX) \ + (((((Uint32) (IIX)) >> 1) & 0x7fffffff)) +#define ERTS_DIST_HDR_ATOM_CACHE_FLAG_BIT_IX(IIX) \ + (((IIX) << 2) & 7) +#define ERTS_DIST_HDR_ATOM_CACHE_FLAG_BYTES(NO_ATOMS) \ + (((((Uint32) (NO_ATOMS)) >> 1) & 0x7fffffff)+1) + +#define ERTS_DIST_HDR_LONG_ATOMS_FLG (1 << 0) + +/* #define ERTS_ATOM_CACHE_HASH */ +#define ERTS_USE_ATOM_CACHE_SIZE 2039 +#if ERTS_ATOM_CACHE_SIZE < ERTS_USE_ATOM_CACHE_SIZE +#error "ERTS_USE_ATOM_CACHE_SIZE too large" +#endif + +static ERTS_INLINE int +atom2cix(Eterm atom) +{ + Uint val; + ASSERT(is_atom(atom)); + val = atom_val(atom); +#ifdef ERTS_ATOM_CACHE_HASH + val = atom_tab(val)->slot.bucket.hvalue; +#endif +#if ERTS_USE_ATOM_CACHE_SIZE == 256 + return (int) (val & ((Uint) 0xff)); +#else + return (int) (val % ERTS_USE_ATOM_CACHE_SIZE); +#endif +} + +int erts_debug_max_atom_out_cache_index(void) +{ + return ERTS_USE_ATOM_CACHE_SIZE-1; +} + +int +erts_debug_atom_to_out_cache_index(Eterm atom) +{ + return atom2cix(atom); +} + +void +erts_init_atom_cache_map(ErtsAtomCacheMap *acmp) +{ + if (acmp) { + int ix; + for (ix = 0; ix < ERTS_ATOM_CACHE_SIZE; ix++) + acmp->cache[ix].iix = -1; + acmp->sz = 0; + acmp->hdr_sz = -1; + } +} + +void +erts_reset_atom_cache_map(ErtsAtomCacheMap *acmp) +{ + if (acmp) { + int i; + for (i = 0; i < acmp->sz; i++) { + ASSERT(0 <= acmp->cix[i] && acmp->cix[i] < ERTS_ATOM_CACHE_SIZE); + acmp->cache[acmp->cix[i]].iix = -1; + } + acmp->sz = 0; + acmp->hdr_sz = -1; +#ifdef DEBUG + for (i = 0; i < ERTS_ATOM_CACHE_SIZE; i++) { + ASSERT(acmp->cache[i].iix < 0); + } +#endif + } +} + +void +erts_destroy_atom_cache_map(ErtsAtomCacheMap *acmp) +{ + +} + +static ERTS_INLINE void +insert_acache_map(ErtsAtomCacheMap *acmp, Eterm atom) +{ + if (acmp && acmp->sz < ERTS_MAX_INTERNAL_ATOM_CACHE_ENTRIES) { + int ix; + ASSERT(acmp->hdr_sz < 0); + ix = atom2cix(atom); + if (acmp->cache[ix].iix < 0) { + acmp->cache[ix].iix = acmp->sz; + acmp->cix[acmp->sz++] = ix; + acmp->cache[ix].atom = atom; + } + } +} + +static ERTS_INLINE int +get_iix_acache_map(ErtsAtomCacheMap *acmp, Eterm atom) +{ + if (!acmp) + return -1; + else { + int ix; + ASSERT(is_atom(atom)); + ix = atom2cix(atom); + if (acmp->cache[ix].iix < 0) { + ASSERT(acmp->sz == ERTS_MAX_INTERNAL_ATOM_CACHE_ENTRIES); + return -1; + } + else { + ASSERT(acmp->cache[ix].iix < ERTS_ATOM_CACHE_SIZE); + return acmp->cache[ix].atom == atom ? acmp->cache[ix].iix : -1; + } + } +} + +void +erts_finalize_atom_cache_map(ErtsAtomCacheMap *acmp) +{ + if (acmp) { +#if MAX_ATOM_LENGTH > 255 +#error "This code is not complete; long_atoms info need to be passed to the following stages." + int long_atoms = 0; /* !0 if one or more atoms are long than 255. */ +#endif + int i; + int sz; + int fix_sz + = 1 /* VERSION_MAGIC */ + + 1 /* DIST_HEADER */ + + 1 /* number of internal cache entries */ + ; + int min_sz; + ASSERT(acmp->hdr_sz < 0); + /* Make sure cache update instructions fit */ + min_sz = fix_sz+(2+4)*acmp->sz; + sz = fix_sz; + for (i = 0; i < acmp->sz; i++) { + Eterm atom; + int len; + atom = acmp->cache[acmp->cix[i]].atom; + ASSERT(is_atom(atom)); + len = atom_tab(atom_val(atom))->len; +#if MAX_ATOM_LENGTH > 255 + if (!long_atoms && len > 255) + long_atoms = 1; +#endif + /* Enough for a new atom cache value */ + sz += 1 /* cix */ + 1 /* length */ + len /* text */; + } +#if MAX_ATOM_LENGTH > 255 + if (long_atoms) + sz += acmp->sz; /* we need 2 bytes per atom for length */ +#endif + /* Dynamically sized flag field */ + sz += ERTS_DIST_HDR_ATOM_CACHE_FLAG_BYTES(acmp->sz); + if (sz < min_sz) + sz = min_sz; + acmp->hdr_sz = sz; + } +} + +Uint +erts_encode_ext_dist_header_size(ErtsAtomCacheMap *acmp) +{ + if (!acmp) + return 0; + else { + ASSERT(acmp->hdr_sz >= 0); + return acmp->hdr_sz; + } +} + +byte *erts_encode_ext_dist_header_setup(byte *ctl_ext, ErtsAtomCacheMap *acmp) +{ +#ifndef ARCH_32 +#if ATOM_LIMIT >= (1UL << 32) +#error "ATOM_LIMIT too large for interal atom cache update instructions. New instructions needed." +#endif +#endif + if (!acmp) + return ctl_ext; + else { + int i; + byte *ep = ctl_ext; + ASSERT(acmp->hdr_sz >= 0); + /* + * Write cache update instructions. Note that this is a purely + * internal format, never seen on the wire. This section is later + * rewritten by erts_encode_ext_dist_header_finalize() while updating + * the cache. We write the header backwards just before the + * actual term(s). + */ + for (i = acmp->sz-1; i >= 0; i--) { + Uint32 aval; + ASSERT(0 <= acmp->cix[i] && acmp->cix[i] < ERTS_ATOM_CACHE_SIZE); + ASSERT(i == acmp->cache[acmp->cix[i]].iix); + ASSERT(is_atom(acmp->cache[acmp->cix[i]].atom)); + + aval = (Uint32) atom_val(acmp->cache[acmp->cix[i]].atom); + ep -= 4; + put_int32(aval, ep); + ep -= 2; + put_int16(acmp->cix[i], ep); + } + --ep; + put_int8(acmp->sz, ep); + *--ep = DIST_HEADER; + *--ep = VERSION_MAGIC; + return ep; + } +} + +byte *erts_encode_ext_dist_header_finalize(byte *ext, ErtsAtomCache *cache) +{ + byte *ip; + byte instr_buf[(2+4)*ERTS_ATOM_CACHE_SIZE]; + int ci, sz; + register byte *ep = ext; + ASSERT(ep[0] == VERSION_MAGIC); + if (ep[1] != DIST_HEADER) + return ext; + + /* + * Update output atom cache and write the external version of + * the dist header. We write the header backwards just + * before the actual term(s). + */ + ep += 2; + ci = (int) get_int8(ep); + ASSERT(0 <= ci && ci < ERTS_ATOM_CACHE_SIZE); + ep += 1; + sz = (2+4)*ci; + ip = &instr_buf[0]; + sys_memcpy((void *) ip, (void *) ep, sz); + ep += sz; + /* ep now points to the beginning of the control message term */ +#ifdef ERTS_DEBUG_USE_DIST_SEP + ASSERT(*ep == VERSION_MAGIC); +#endif + if (ci > 0) { + Uint32 flgs_buf[((ERTS_DIST_HDR_ATOM_CACHE_FLAG_BYTES( + ERTS_MAX_INTERNAL_ATOM_CACHE_ENTRIES)-1) + / sizeof(Uint32))+1]; + register Uint32 flgs; + int iix, flgs_bytes, flgs_buf_ix, used_half_bytes; +#ifdef DEBUG + int tot_used_half_bytes; +#endif + + flgs_bytes = ERTS_DIST_HDR_ATOM_CACHE_FLAG_BYTES(ci); + + ASSERT(flgs_bytes <= sizeof(flgs_buf)); +#if MAX_ATOM_LENGTH > 255 + /* long_atoms info needs to be passed from previous stages */ + if (long_atoms) + flgs |= ERTS_DIST_HDR_LONG_ATOMS_FLG; +#endif + flgs = 0; + flgs_buf_ix = 0; + if ((ci & 1) == 0) + used_half_bytes = 2; + else + used_half_bytes = 1; +#ifdef DEBUG + tot_used_half_bytes = used_half_bytes; +#endif + iix = ci-1; + while (iix >= 0) { + int cix; + Eterm atom; + + if (used_half_bytes != 8) + flgs <<= 4; + else { + flgs_buf[flgs_buf_ix++] = flgs; + flgs = 0; + used_half_bytes = 0; + } + + ip = &instr_buf[0] + (2+4)*iix; + cix = (int) get_int16(&ip[0]); + ASSERT(0 <= cix && cix < ERTS_ATOM_CACHE_SIZE); + atom = make_atom((Uint) get_int32(&ip[2])); + if (cache->out_arr[cix] == atom) { + --ep; + put_int8(cix, ep); + flgs |= ((cix >> 8) & 7); + } + else { + Atom *a; + cache->out_arr[cix] = atom; + a = atom_tab(atom_val(atom)); + sz = a->len; + ep -= sz; + sys_memcpy((void *) ep, (void *) a->name, sz); +#if MAX_ATOM_LENGTH > 255 + if (long_atoms) { + ep -= 2; + put_int16(sz, ep); + } + else +#endif + { + ASSERT(0 <= sz && sz <= 255); + --ep; + put_int8(sz, ep); + } + --ep; + put_int8(cix, ep); + flgs |= (8 | ((cix >> 8) & 7)); + } + iix--; + used_half_bytes++; +#ifdef DEBUG + tot_used_half_bytes++; +#endif + } + ASSERT(tot_used_half_bytes == 2*flgs_bytes); + flgs_buf[flgs_buf_ix] = flgs; + flgs_buf_ix = 0; + while (1) { + flgs = flgs_buf[flgs_buf_ix]; + if (flgs_bytes > 4) { + *--ep = (byte) ((flgs >> 24) & 0xff); + *--ep = (byte) ((flgs >> 16) & 0xff); + *--ep = (byte) ((flgs >> 8) & 0xff); + *--ep = (byte) (flgs & 0xff); + flgs_buf_ix++; + flgs_bytes -= 4; + } + else { + switch (flgs_bytes) { + case 4: + *--ep = (byte) ((flgs >> 24) & 0xff); + case 3: + *--ep = (byte) ((flgs >> 16) & 0xff); + case 2: + *--ep = (byte) ((flgs >> 8) & 0xff); + case 1: + *--ep = (byte) (flgs & 0xff); + } + break; + } + } + } + --ep; + put_int8(ci, ep); + *--ep = DIST_HEADER; + *--ep = VERSION_MAGIC; + return ep; +} + +Uint erts_encode_dist_ext_size(Eterm term, Uint32 flags, ErtsAtomCacheMap *acmp) +{ + Uint sz = 0; +#ifndef ERTS_DEBUG_USE_DIST_SEP + if (!(flags & DFLAG_DIST_HDR_ATOM_CACHE)) +#endif + sz++ /* VERSION_MAGIC */; + sz += encode_size_struct2(acmp, term, flags); + return sz; +} + +Uint erts_encode_ext_size(Eterm term) +{ + return encode_size_struct2(NULL, term, TERM_TO_BINARY_DFLAGS) + + 1 /* VERSION_MAGIC */; +} + +void erts_encode_dist_ext(Eterm term, byte **ext, Uint32 flags, ErtsAtomCacheMap *acmp) +{ + byte *ep = *ext; +#ifndef ERTS_DEBUG_USE_DIST_SEP + if (!(flags & DFLAG_DIST_HDR_ATOM_CACHE)) +#endif + *ep++ = VERSION_MAGIC; + ep = enc_term(acmp, term, ep, flags); + if (!ep) + erl_exit(ERTS_ABORT_EXIT, + "%s:%d:erts_encode_dist_ext(): Internal data structure error\n", + __FILE__, __LINE__); + *ext = ep; +} + +void erts_encode_ext(Eterm term, byte **ext) +{ + byte *ep = *ext; + *ep++ = VERSION_MAGIC; + ep = enc_term(NULL, term, ep, TERM_TO_BINARY_DFLAGS); + if (!ep) + erl_exit(ERTS_ABORT_EXIT, + "%s:%d:erts_encode_ext(): Internal data structure error\n", + __FILE__, __LINE__); + *ext = ep; +} + +ErtsDistExternal * +erts_make_dist_ext_copy(ErtsDistExternal *edep, Uint xsize) +{ + size_t align_sz; + size_t dist_ext_sz; + size_t ext_sz; + byte *ep; + ErtsDistExternal *new_edep; + + dist_ext_sz = ERTS_DIST_EXT_SIZE(edep); + ASSERT(edep->ext_endp && edep->extp); + ASSERT(edep->ext_endp >= edep->extp); + ext_sz = edep->ext_endp - edep->extp; + + align_sz = ERTS_WORD_ALIGN_PAD_SZ(dist_ext_sz + ext_sz); + + new_edep = erts_alloc(ERTS_ALC_T_EXT_TERM_DATA, + dist_ext_sz + ext_sz + align_sz + xsize); + + ep = (byte *) new_edep; + sys_memcpy((void *) ep, (void *) edep, dist_ext_sz); + ep += dist_ext_sz; + if (new_edep->dep) + erts_refc_inc(&new_edep->dep->refc, 1); + new_edep->extp = ep; + new_edep->ext_endp = ep + ext_sz; + new_edep->heap_size = -1; + sys_memcpy((void *) ep, (void *) edep->extp, ext_sz); + return new_edep; +} + +int +erts_prepare_dist_ext(ErtsDistExternal *edep, + byte *ext, + Uint size, + DistEntry *dep, + ErtsAtomCache *cache) +{ +#undef ERTS_EXT_FAIL +#undef ERTS_EXT_HDR_FAIL +#if 1 +#define ERTS_EXT_FAIL goto fail +#define ERTS_EXT_HDR_FAIL goto bad_hdr +#else +#define ERTS_EXT_FAIL abort() +#define ERTS_EXT_HDR_FAIL abort() +#endif + + register byte *ep = ext; + + edep->heap_size = -1; + edep->ext_endp = ext+size; + + if (size < 2) + ERTS_EXT_FAIL; + + if (ep[0] != VERSION_MAGIC) { + erts_dsprintf_buf_t *dsbufp = erts_create_logger_dsbuf(); + if (dep) + erts_dsprintf(dsbufp, + "** Got message from incompatible erlang on " + "channel %d\n", + dist_entry_channel_no(dep)); + else + erts_dsprintf(dsbufp, + "** Attempt to convert old incompatible " + "binary %d\n", + *ep); + erts_send_error_to_logger_nogl(dsbufp); + ERTS_EXT_FAIL; + } + + edep->flags = 0; + edep->dep = dep; + if (dep) { + erts_smp_de_rlock(dep); + if (dep->flags & DFLAG_DIST_HDR_ATOM_CACHE) + edep->flags |= ERTS_DIST_EXT_DFLAG_HDR; + + edep->flags |= (dep->connection_id & ERTS_DIST_EXT_CON_ID_MASK); + erts_smp_de_runlock(dep); + } + + if (ep[1] != DIST_HEADER) { + if (edep->flags & ERTS_DIST_EXT_DFLAG_HDR) + ERTS_EXT_HDR_FAIL; + edep->attab.size = 0; + edep->extp = ext; + } + else { + int tix; + int no_atoms; + + if (!(edep->flags & ERTS_DIST_EXT_DFLAG_HDR)) + ERTS_EXT_HDR_FAIL; + +#undef CHKSIZE +#define CHKSIZE(SZ) \ + do { if ((SZ) > edep->ext_endp - ep) ERTS_EXT_HDR_FAIL; } while(0) + + CHKSIZE(1+1+1); + ep += 2; + no_atoms = (int) get_int8(ep); + if (no_atoms < 0 || ERTS_ATOM_CACHE_SIZE < no_atoms) + ERTS_EXT_HDR_FAIL; + ep++; + if (no_atoms) { +#if MAX_ATOM_LENGTH > 255 + int long_atoms = 0; +#endif +#ifdef DEBUG + byte *flgs_buf = ep; +#endif + byte *flgsp = ep; + int flgs_size = ERTS_DIST_HDR_ATOM_CACHE_FLAG_BYTES(no_atoms); + int byte_ix; + int bit_ix; + int got_flgs; + register Uint32 flgs = 0; + + CHKSIZE(flgs_size); + ep += flgs_size; + + /* + * Check long atoms flag + */ + byte_ix = ERTS_DIST_HDR_ATOM_CACHE_FLAG_BYTE_IX(no_atoms); + bit_ix = ERTS_DIST_HDR_ATOM_CACHE_FLAG_BIT_IX(no_atoms); + if (flgsp[byte_ix] & (((byte) ERTS_DIST_HDR_LONG_ATOMS_FLG) + << bit_ix)) { +#if MAX_ATOM_LENGTH > 255 + long_atoms = 1; +#else + ERTS_EXT_HDR_FAIL; /* Long atoms not supported yet */ +#endif + } + +#ifdef DEBUG + byte_ix = 0; + bit_ix = 0; +#endif + got_flgs = 0; + /* + * Setup the atom translation table. + */ + edep->flags |= ERTS_DIST_EXT_ATOM_TRANS_TAB; + edep->attab.size = no_atoms; + for (tix = 0; tix < no_atoms; tix++) { + Eterm atom; + int cix; + int len; + + if (!got_flgs) { + int left = no_atoms - tix; + if (left > 6) { + flgs = ((((Uint32) flgsp[3]) << 24) + | (((Uint32) flgsp[2]) << 16) + | (((Uint32) flgsp[1]) << 8) + | ((Uint32) flgsp[0])); + flgsp += 4; + } + else { + flgs = 0; + switch (left) { + case 6: + case 5: + flgs |= (((Uint32) flgsp[2]) << 16); + case 4: + case 3: + flgs |= (((Uint32) flgsp[1]) << 8); + case 2: + case 1: + flgs |= ((Uint32) flgsp[0]); + } + } + got_flgs = 8; + } + + ASSERT(byte_ix == ERTS_DIST_HDR_ATOM_CACHE_FLAG_BYTE_IX(tix)); + ASSERT(bit_ix == ERTS_DIST_HDR_ATOM_CACHE_FLAG_BIT_IX(tix)); + ASSERT((flgs & 3) + == (((flgs_buf[byte_ix] + & (((byte) 3) << bit_ix)) >> bit_ix) & 3)); + + CHKSIZE(1); + cix = (int) ((flgs & 7) << 8); + if ((flgs & 8) == 0) { + /* atom already cached */ + cix += (int) get_int8(ep); + if (cix >= ERTS_ATOM_CACHE_SIZE) + ERTS_EXT_HDR_FAIL; + ep++; + atom = cache->in_arr[cix]; + if (!is_atom(atom)) + ERTS_EXT_HDR_FAIL; + edep->attab.atom[tix] = atom; + } + else { + /* new cached atom */ + cix += (int) get_int8(ep); + if (cix >= ERTS_ATOM_CACHE_SIZE) + ERTS_EXT_HDR_FAIL; + ep++; +#if MAX_ATOM_LENGTH > 255 + if (long_atoms) { + CHKSIZE(2); + len = get_int16(ep); + ep += 2; + } + else +#endif + { + CHKSIZE(1); + len = get_int8(ep); + ep++; + } + if (len > MAX_ATOM_LENGTH) + ERTS_EXT_HDR_FAIL; /* Too long atom */ + CHKSIZE(len); + atom = am_atom_put((char *) ep, len); + ep += len; + cache->in_arr[cix] = atom; + edep->attab.atom[tix] = atom; + } + flgs >>= 4; + got_flgs--; +#ifdef DEBUG + bit_ix += 4; + if (bit_ix >= 8) { + bit_ix = 0; + flgs = (int) flgs_buf[++byte_ix]; + ASSERT(byte_ix < flgs_size); + } +#endif + } + } + edep->extp = ep; +#ifdef ERTS_DEBUG_USE_DIST_SEP + if (*ep != VERSION_MAGIC) + ERTS_EXT_HDR_FAIL; +#endif + } +#ifdef ERTS_DEBUG_USE_DIST_SEP + if (*ep != VERSION_MAGIC) + ERTS_EXT_FAIL; +#endif + + return 0; + +#undef CHKSIZE +#undef ERTS_EXT_FAIL +#undef ERTS_EXT_HDR_FAIL + + bad_hdr: + if (dep) { + erts_dsprintf_buf_t *dsbufp = erts_create_logger_dsbuf(); + erts_dsprintf(dsbufp, + "%T got a corrupted distribution header from %T " + "on distribution channel %d\n", + erts_this_node->sysname, + edep->dep->sysname, + dist_entry_channel_no(edep->dep)); + for (ep = ext; ep < edep->ext_endp; ep++) + erts_dsprintf(dsbufp, ep != ext ? ",%b8u" : "<<%b8u", *ep); + erts_dsprintf(dsbufp, ">>"); + erts_send_warning_to_logger_nogl(dsbufp); + } + fail: + if (dep) + erts_kill_dist_connection(dep, dep->connection_id); + return -1; +} + +static void +bad_dist_ext(ErtsDistExternal *edep) +{ + if (edep->dep) { + DistEntry *dep = edep->dep; + erts_dsprintf_buf_t *dsbufp = erts_create_logger_dsbuf(); + byte *ep; + erts_dsprintf(dsbufp, + "%T got a corrupted external term from %T " + "on distribution channel %d\n", + erts_this_node->sysname, + dep->sysname, + dist_entry_channel_no(dep)); + for (ep = edep->extp; ep < edep->ext_endp; ep++) + erts_dsprintf(dsbufp, + ep != edep->extp ? ",%b8u" : "<<...,%b8u", + *ep); + erts_dsprintf(dsbufp, ">>\n"); + erts_dsprintf(dsbufp, "ATOM_CACHE_REF translations: "); + if (!(edep->flags & ERTS_DIST_EXT_ATOM_TRANS_TAB) || !edep->attab.size) + erts_dsprintf(dsbufp, "none"); + else { + int i; + erts_dsprintf(dsbufp, "0=%T", edep->attab.atom[0]); + for (i = 1; i < edep->attab.size; i++) + erts_dsprintf(dsbufp, ", %d=%T", i, edep->attab.atom[i]); + } + erts_send_warning_to_logger_nogl(dsbufp); + erts_kill_dist_connection(dep, ERTS_DIST_EXT_CON_ID(edep)); + } +} + +Sint +erts_decode_dist_ext_size(ErtsDistExternal *edep, int no_refc_bins) +{ + Sint res; + byte *ep; + if (edep->extp >= edep->ext_endp) + goto fail; +#ifndef ERTS_DEBUG_USE_DIST_SEP + if (edep->flags & ERTS_DIST_EXT_DFLAG_HDR) { + if (*edep->extp == VERSION_MAGIC) + goto fail; + ep = edep->extp; + } + else +#endif + { + if (*edep->extp != VERSION_MAGIC) + goto fail; + ep = edep->extp+1; + } + res = decoded_size(ep, edep->ext_endp, no_refc_bins); + if (res >= 0) + return res; + fail: + bad_dist_ext(edep); + return -1; +} + +Sint erts_decode_ext_size(byte *ext, Uint size, int no_refc_bins) +{ + if (size == 0 || *ext != VERSION_MAGIC) + return -1; + return decoded_size(ext+1, ext+size, no_refc_bins); +} + +/* +** hpp is set to either a &p->htop or +** a pointer to a memory pointer (form message buffers) +** on return hpp is updated to point after allocated data +*/ +Eterm +erts_decode_dist_ext(Eterm** hpp, + ErlOffHeap* off_heap, + ErtsDistExternal *edep) +{ + Eterm obj; + byte* ep = edep->extp; + + if (ep >= edep->ext_endp) + goto error; +#ifndef ERTS_DEBUG_USE_DIST_SEP + if (edep->flags & ERTS_DIST_EXT_DFLAG_HDR) { + if (*ep == VERSION_MAGIC) + goto error; + } + else +#endif + { + if (*ep != VERSION_MAGIC) + goto error; + ep++; + } + ep = dec_term(edep, hpp, ep, off_heap, &obj); + if (!ep) + goto error; + + edep->extp = ep; + + return obj; + + error: + + bad_dist_ext(edep); + + return THE_NON_VALUE; +} + +Eterm erts_decode_ext(Eterm **hpp, ErlOffHeap *off_heap, byte **ext) +{ + Eterm obj; + byte *ep = *ext; + if (*ep++ != VERSION_MAGIC) + return THE_NON_VALUE; + ep = dec_term(NULL, hpp, ep, off_heap, &obj); + if (!ep) { +#ifdef DEBUG + bin_write(ERTS_PRINT_STDERR,NULL,*ext,500); +#endif + return THE_NON_VALUE; + } + *ext = ep; + return obj; +} + + + +/**********************************************************************/ + +BIF_RETTYPE erts_debug_dist_ext_to_term_2(BIF_ALIST_2) +{ + Eterm res; + Eterm *hp; + Eterm *hendp; + Uint hsz; + ErtsDistExternal ede; + Eterm *tp; + Eterm real_bin; + Uint offset; + Uint size; + Uint bitsize; + Uint bitoffs; + Uint arity; + int i; + + ede.flags = ERTS_DIST_EXT_ATOM_TRANS_TAB; + ede.dep = NULL; + ede.heap_size = -1; + + if (is_not_tuple(BIF_ARG_1)) + goto badarg; + tp = tuple_val(BIF_ARG_1); + arity = arityval(tp[0]); + if (arity > ERTS_MAX_INTERNAL_ATOM_CACHE_ENTRIES) + goto badarg; + + ede.attab.size = arity; + for (i = 1; i <= arity; i++) { + if (is_not_atom(tp[i])) + goto badarg; + ede.attab.atom[i-1] = tp[i]; + } + + if (is_not_binary(BIF_ARG_2)) + goto badarg; + + size = binary_size(BIF_ARG_2); + if (size == 0) + goto badarg; + ERTS_GET_REAL_BIN(BIF_ARG_2, real_bin, offset, bitoffs, bitsize); + if (bitsize != 0) + goto badarg; + + ede.extp = binary_bytes(real_bin)+offset; + ede.ext_endp = ede.extp + size; + + hsz = erts_decode_dist_ext_size(&ede, 0); + if (hsz < 0) + goto badarg; + + hp = HAlloc(BIF_P, hsz); + hendp = hp + hsz; + + res = erts_decode_dist_ext(&hp, &MSO(BIF_P), &ede); + + HRelease(BIF_P, hendp, hp); + + if (is_value(res)) + BIF_RET(res); + + badarg: + + BIF_ERROR(BIF_P, BADARG); +} + + +Eterm +term_to_binary_1(Process* p, Eterm Term) +{ + return erts_term_to_binary(p, Term, 0, TERM_TO_BINARY_DFLAGS); +} + +Eterm +term_to_binary_2(Process* p, Eterm Term, Eterm Flags) +{ + int level = 0; + Uint flags = TERM_TO_BINARY_DFLAGS; + + while (is_list(Flags)) { + Eterm arg = CAR(list_val(Flags)); + Eterm* tp; + if (arg == am_compressed) { + level = Z_DEFAULT_COMPRESSION; + } else if (is_tuple(arg) && *(tp = tuple_val(arg)) == make_arityval(2)) { + if (tp[1] == am_minor_version && is_small(tp[2])) { + switch (signed_val(tp[2])) { + case 0: + flags = TERM_TO_BINARY_DFLAGS; + break; + case 1: + flags = TERM_TO_BINARY_DFLAGS|DFLAG_NEW_FLOATS; + break; + default: + goto error; + } + } else if (tp[1] == am_compressed && is_small(tp[2])) { + level = signed_val(tp[2]); + if (!(0 <= level && level < 10)) { + goto error; + } + } else { + goto error; + } + } else { + error: + BIF_ERROR(p, BADARG); + } + Flags = CDR(list_val(Flags)); + } + if (is_not_nil(Flags)) { + goto error; + } + + return erts_term_to_binary(p, Term, level, flags); +} + +static ERTS_INLINE Sint +binary2term_prepare(ErtsBinary2TermState *state, byte *data, Sint data_size) +{ + Sint res; + byte *bytes = data; + Sint size = data_size; + + state->exttmp = 0; + + if (size < 1 || *bytes != VERSION_MAGIC) { + error: + if (state->exttmp) + erts_free(ERTS_ALC_T_TMP, state->extp); + state->extp = NULL; + state->exttmp = 0; + return -1; + } + bytes++; + size--; + if (size < 5 || *bytes != COMPRESSED) { + state->extp = bytes; + } + else { + uLongf dest_len = get_int32(bytes+1); + state->extp = erts_alloc(ERTS_ALC_T_TMP, dest_len); + state->exttmp = 1; + if (erl_zlib_uncompress(state->extp, &dest_len, bytes+5, size-5) != Z_OK) + goto error; + size = (Sint) dest_len; + } + res = decoded_size(state->extp, state->extp + size, 0); + if (res < 0) + goto error; + return res; +} + +static ERTS_INLINE void +binary2term_abort(ErtsBinary2TermState *state) +{ + if (state->exttmp) { + state->exttmp = 0; + erts_free(ERTS_ALC_T_TMP, state->extp); + } +} + +static ERTS_INLINE Eterm +binary2term_create(ErtsBinary2TermState *state, Eterm **hpp, ErlOffHeap *ohp) +{ + Eterm res; + if (!dec_term(NULL, hpp, state->extp, ohp, &res)) + res = THE_NON_VALUE; + if (state->exttmp) { + state->exttmp = 0; + erts_free(ERTS_ALC_T_TMP, state->extp); + } + return res; +} + +Sint +erts_binary2term_prepare(ErtsBinary2TermState *state, byte *data, Sint data_size) +{ + return binary2term_prepare(state, data, data_size); +} + +void +erts_binary2term_abort(ErtsBinary2TermState *state) +{ + binary2term_abort(state); +} + +Eterm +erts_binary2term_create(ErtsBinary2TermState *state, Eterm **hpp, ErlOffHeap *ohp) +{ + return binary2term_create(state, hpp, ohp); +} + +BIF_RETTYPE binary_to_term_1(BIF_ALIST_1) +{ + Sint heap_size; + Eterm res; + Eterm* hp; + Eterm* endp; + Sint size; + byte* bytes; + byte* temp_alloc = NULL; + ErtsBinary2TermState b2ts; + + if ((bytes = erts_get_aligned_binary_bytes(BIF_ARG_1, &temp_alloc)) == NULL) { + error: + erts_free_aligned_binary_bytes(temp_alloc); + BIF_ERROR(BIF_P, BADARG); + } + size = binary_size(BIF_ARG_1); + + heap_size = binary2term_prepare(&b2ts, bytes, size); + if (heap_size < 0) + goto error; + + hp = HAlloc(BIF_P, heap_size); + endp = hp + heap_size; + + res = binary2term_create(&b2ts, &hp, &MSO(BIF_P)); + + erts_free_aligned_binary_bytes(temp_alloc); + + if (hp > endp) { + erl_exit(1, ":%s, line %d: heap overrun by %d words(s)\n", + __FILE__, __LINE__, hp-endp); + } + + HRelease(BIF_P, endp, hp); + + if (res == THE_NON_VALUE) + goto error; + + return res; +} + +Eterm +external_size_1(Process* p, Eterm Term) +{ + Uint size = erts_encode_ext_size(Term); + if (IS_USMALL(0, size)) { + BIF_RET(make_small(size)); + } else { + Eterm* hp = HAlloc(p, BIG_UINT_HEAP_SIZE); + BIF_RET(uint_to_big(size, hp)); + } +} + +Eterm +erts_term_to_binary(Process* p, Eterm Term, int level, Uint flags) +{ + int size; + Eterm bin; + size_t real_size; + byte* endp; + + size = encode_size_struct2(NULL, Term, flags) + 1 /* VERSION_MAGIC */; + + if (level != 0) { + byte buf[256]; + byte* bytes = buf; + byte* out_bytes; + uLongf dest_len; + + if (sizeof(buf) < size) { + bytes = erts_alloc(ERTS_ALC_T_TMP, size); + } + + if ((endp = enc_term(NULL, Term, bytes, flags)) + == NULL) { + erl_exit(1, "%s, line %d: bad term: %x\n", + __FILE__, __LINE__, Term); + } + real_size = endp - bytes; + if (real_size > size) { + erl_exit(1, "%s, line %d: buffer overflow: %d word(s)\n", + __FILE__, __LINE__, real_size - size); + } + + /* + * We don't want to compress if compression actually increases the size. + * Therefore, don't give zlib more out buffer than the size of the + * uncompressed external format (minus the 5 bytes needed for the + * COMPRESSED tag). If zlib returns any error, we'll revert to using + * the original uncompressed external term format. + */ + + if (real_size < 5) { + dest_len = 0; + } else { + dest_len = real_size - 5; + } + bin = new_binary(p, NULL, real_size+1); + out_bytes = binary_bytes(bin); + out_bytes[0] = VERSION_MAGIC; + if (erl_zlib_compress2(out_bytes+6, &dest_len, bytes, real_size, level) != Z_OK) { + sys_memcpy(out_bytes+1, bytes, real_size); + bin = erts_realloc_binary(bin, real_size+1); + } else { + out_bytes[1] = COMPRESSED; + put_int32(real_size, out_bytes+2); + bin = erts_realloc_binary(bin, dest_len+6); + } + if (bytes != buf) { + erts_free(ERTS_ALC_T_TMP, bytes); + } + return bin; + } else { + byte* bytes; + + bin = new_binary(p, (byte *)NULL, size); + bytes = binary_bytes(bin); + bytes[0] = VERSION_MAGIC; + if ((endp = enc_term(NULL, Term, bytes+1, flags)) + == NULL) { + erl_exit(1, "%s, line %d: bad term: %x\n", + __FILE__, __LINE__, Term); + } + real_size = endp - bytes; + if (real_size > size) { + erl_exit(1, "%s, line %d: buffer overflow: %d word(s)\n", + __FILE__, __LINE__, endp - (bytes + size)); + } + return erts_realloc_binary(bin, real_size); + } +} + +/* + * This function fills ext with the external format of atom. + * If it's an old atom we just supply an index, otherwise + * we insert the index _and_ the entire atom. This way the receiving side + * does not have to perform an hash on the etom to locate it, and + * we save a lot of space on the wire. + */ + +static byte* +enc_atom(ErtsAtomCacheMap *acmp, Eterm atom, byte *ep, Uint32 dflags) +{ + int iix; + int i, j; + + ASSERT(is_atom(atom)); + + /* + * term_to_binary/1,2 and the initial distribution message + * don't use the cache. + */ + iix = get_iix_acache_map(acmp, atom); + if (iix < 0) { + i = atom_val(atom); + j = atom_tab(i)->len; + if ((MAX_ATOM_LENGTH <= 255 || j <= 255) + && (dflags & DFLAG_SMALL_ATOM_TAGS)) { + *ep++ = SMALL_ATOM_EXT; + put_int8(j, ep); + ep++; + } + else { + *ep++ = ATOM_EXT; + put_int16(j, ep); + ep += 2; + } + sys_memcpy((char *) ep, (char*)atom_tab(i)->name, (int) j); + ep += j; + return ep; + } + + /* The atom is referenced in the cache. */ + *ep++ = ATOM_CACHE_REF; + put_int8(iix, ep); + ep++; + return ep; +} + +static byte* +enc_pid(ErtsAtomCacheMap *acmp, Eterm pid, byte* ep, Uint32 dflags) +{ + Uint on, os; + + *ep++ = PID_EXT; + /* insert atom here containing host and sysname */ + ep = enc_atom(acmp, pid_node_name(pid), ep, dflags); + + /* two bytes for each number and serial */ + + on = pid_number(pid); + os = pid_serial(pid); + + put_int32(on, ep); + ep += 4; + put_int32(os, ep); + ep += 4; + *ep++ = pid_creation(pid); + return ep; +} + +/* Expect an atom in plain text or cached */ +static byte* +dec_atom(ErtsDistExternal *edep, byte* ep, Eterm* objp) +{ + Uint len; + int n; + + switch (*ep++) { + case ATOM_CACHE_REF: + if (!(edep->flags & ERTS_DIST_EXT_ATOM_TRANS_TAB)) + goto error; + n = get_int8(ep); + ep++; + if (n >= edep->attab.size) + goto error; + ASSERT(is_atom(edep->attab.atom[n])); + *objp = edep->attab.atom[n]; + break; + case ATOM_EXT: + len = get_int16(ep), + ep += 2; + *objp = am_atom_put((char*)ep, len); + ep += len; + break; + case SMALL_ATOM_EXT: + len = get_int8(ep); + ep++; + *objp = am_atom_put((char*)ep, len); + ep += len; + break; + default: + error: + *objp = NIL; /* Don't leave a hole in the heap */ + return NULL; + } + return ep; +} + +static byte* +dec_pid(ErtsDistExternal *edep, Eterm** hpp, byte* ep, ErlOffHeap* off_heap, Eterm* objp) +{ + Eterm sysname; + Uint data; + Uint num; + Uint ser; + Uint cre; + ErlNode *node; + + *objp = NIL; /* In case we fail, don't leave a hole in the heap */ + + /* eat first atom */ + if ((ep = dec_atom(edep, ep, &sysname)) == NULL) + return NULL; + num = get_int32(ep); + ep += 4; + if (num > ERTS_MAX_PID_NUMBER) + return NULL; + ser = get_int32(ep); + ep += 4; + if (ser > ERTS_MAX_PID_SERIAL) + return NULL; + if ((cre = get_int8(ep)) >= MAX_CREATION) + return NULL; + ep += 1; + + /* + * We are careful to create the node entry only after all + * validity tests are done. + */ + cre = dec_set_creation(sysname,cre); + node = erts_find_or_insert_node(sysname,cre); + + data = make_pid_data(ser, num); + if(node == erts_this_node) { + *objp = make_internal_pid(data); + } else { + ExternalThing *etp = (ExternalThing *) *hpp; + *hpp += EXTERNAL_THING_HEAD_SIZE + 1; + + etp->header = make_external_pid_header(1); + etp->next = off_heap->externals; + etp->node = node; + etp->data.ui[0] = data; + + off_heap->externals = etp; + *objp = make_external_pid(etp); + } + return ep; +} + + +#define ENC_TERM ((Eterm) 0) +#define ENC_ONE_CONS ((Eterm) 1) +#define ENC_PATCH_FUN_SIZE ((Eterm) 2) +#define ENC_LAST_ARRAY_ELEMENT ((Eterm) 3) + +static byte* +enc_term(ErtsAtomCacheMap *acmp, Eterm obj, byte* ep, Uint32 dflags) +{ + DECLARE_ESTACK(s); + Uint n; + Uint i; + Uint j; + Uint* ptr; + Eterm val; + FloatDef f; + + goto L_jump_start; + + outer_loop: + while (!ESTACK_ISEMPTY(s)) { + obj = ESTACK_POP(s); + switch (val = ESTACK_POP(s)) { + case ENC_TERM: + break; + case ENC_ONE_CONS: + encode_one_cons: + { + Eterm* cons = list_val(obj); + Eterm tl; + + obj = CAR(cons); + tl = CDR(cons); + ESTACK_PUSH(s, is_list(tl) ? ENC_ONE_CONS : ENC_TERM); + ESTACK_PUSH(s, tl); + } + break; + case ENC_PATCH_FUN_SIZE: + { + byte* size_p = (byte *) obj; + + put_int32(ep - size_p, size_p); + } + goto outer_loop; + case ENC_LAST_ARRAY_ELEMENT: + { + Eterm* ptr = (Eterm *) obj; + obj = *ptr; + } + break; + default: /* ENC_LAST_ARRAY_ELEMENT+1 and upwards */ + { + Eterm* ptr = (Eterm *) obj; + obj = *ptr++; + ESTACK_PUSH(s, val-1); + ESTACK_PUSH(s, (Eterm) ptr); + } + break; + } + + L_jump_start: + switch(tag_val_def(obj)) { + case NIL_DEF: + *ep++ = NIL_EXT; + break; + + case ATOM_DEF: + ep = enc_atom(acmp,obj,ep,dflags); + break; + + case SMALL_DEF: + { + Sint val = signed_val(obj); + + if ((Uint)val < 256) { + *ep++ = SMALL_INTEGER_EXT; + put_int8(val, ep); + ep++; + } else if (sizeof(Sint) == 4 || IS_SSMALL28(val)) { + *ep++ = INTEGER_EXT; + put_int32(val, ep); + ep += 4; + } else { + Eterm tmp_big[2]; + Eterm big = small_to_big(val, tmp_big); + *ep++ = SMALL_BIG_EXT; + n = big_bytes(big); + ASSERT(n < 256); + put_int8(n, ep); + ep += 1; + *ep++ = big_sign(big); + ep = big_to_bytes(big, ep); + } + } + break; + + case BIG_DEF: + if ((n = big_bytes(obj)) < 256) { + *ep++ = SMALL_BIG_EXT; + put_int8(n, ep); + ep += 1; + } + else { + *ep++ = LARGE_BIG_EXT; + put_int32(n, ep); + ep += 4; + } + *ep++ = big_sign(obj); + ep = big_to_bytes(obj, ep); + break; + + case PID_DEF: + case EXTERNAL_PID_DEF: + ep = enc_pid(acmp, obj, ep, dflags); + break; + + case REF_DEF: + case EXTERNAL_REF_DEF: { + Uint32 *ref_num; + + ASSERT(dflags & DFLAG_EXTENDED_REFERENCES); + *ep++ = NEW_REFERENCE_EXT; + i = ref_no_of_numbers(obj); + put_int16(i, ep); + ep += 2; + ep = enc_atom(acmp,ref_node_name(obj),ep,dflags); + *ep++ = ref_creation(obj); + ref_num = ref_numbers(obj); + for (j = 0; j < i; j++) { + put_int32(ref_num[j], ep); + ep += 4; + } + break; + } + case PORT_DEF: + case EXTERNAL_PORT_DEF: + + *ep++ = PORT_EXT; + ep = enc_atom(acmp,port_node_name(obj),ep,dflags); + j = port_number(obj); + put_int32(j, ep); + ep += 4; + *ep++ = port_creation(obj); + break; + + case LIST_DEF: + { + int is_str; + + i = is_external_string(obj, &is_str); + if (is_str) { + *ep++ = STRING_EXT; + put_int16(i, ep); + ep += 2; + while (is_list(obj)) { + Eterm* cons = list_val(obj); + *ep++ = unsigned_val(CAR(cons)); + obj = CDR(cons); + } + } else { + *ep++ = LIST_EXT; + put_int32(i, ep); + ep += 4; + goto encode_one_cons; + } + } + break; + + case TUPLE_DEF: + ptr = tuple_val(obj); + i = arityval(*ptr); + ptr++; + if (i <= 0xff) { + *ep++ = SMALL_TUPLE_EXT; + put_int8(i, ep); + ep += 1; + } else { + *ep++ = LARGE_TUPLE_EXT; + put_int32(i, ep); + ep += 4; + } + if (i > 0) { + ESTACK_PUSH(s, ENC_LAST_ARRAY_ELEMENT+i-1); + ESTACK_PUSH(s, (Eterm) ptr); + } + break; + + case FLOAT_DEF: + GET_DOUBLE(obj, f); + if (dflags & DFLAG_NEW_FLOATS) { + *ep++ = NEW_FLOAT_EXT; +#ifdef WORDS_BIGENDIAN + put_int32(f.fw[0], ep); + ep += 4; + put_int32(f.fw[1], ep); +#else + put_int32(f.fw[1], ep); + ep += 4; + put_int32(f.fw[0], ep); +#endif + ep += 4; + } else { + *ep++ = FLOAT_EXT; + + /* now the sprintf which does the work */ + i = sys_double_to_chars(f.fd, (char*) ep); + + /* Don't leave garbage after the float! (Bad practice in general, + * and Purify complains.) + */ + sys_memset(ep+i, 0, 31-i); + ep += 31; + } + break; + + case BINARY_DEF: + { + Uint bitoffs; + Uint bitsize; + byte* bytes; + + ERTS_GET_BINARY_BYTES(obj, bytes, bitoffs, bitsize); + if (bitsize == 0) { + /* Plain old byte-sized binary. */ + *ep++ = BINARY_EXT; + j = binary_size(obj); + put_int32(j, ep); + ep += 4; + copy_binary_to_buffer(ep, 0, bytes, bitoffs, 8*j); + ep += j; + } else if (dflags & DFLAG_BIT_BINARIES) { + /* Bit-level binary. */ + *ep++ = BIT_BINARY_EXT; + j = binary_size(obj); + put_int32((j+1), ep); + ep += 4; + *ep++ = bitsize; + ep[j] = 0; /* Zero unused bits at end of binary */ + copy_binary_to_buffer(ep, 0, bytes, bitoffs, 8*j+bitsize); + ep += j + 1; + } else { + /* + * Bit-level binary, but the receiver doesn't support it. + * Build a tuple instead. + */ + *ep++ = SMALL_TUPLE_EXT; + *ep++ = 2; + *ep++ = BINARY_EXT; + j = binary_size(obj); + put_int32((j+1), ep); + ep += 4; + ep[j] = 0; /* Zero unused bits at end of binary */ + copy_binary_to_buffer(ep, 0, bytes, bitoffs, 8*j+bitsize); + ep += j+1; + *ep++ = SMALL_INTEGER_EXT; + *ep++ = bitsize; + } + break; + } + case EXPORT_DEF: + { + Export* exp = (Export *) (export_val(obj))[1]; + if ((dflags & DFLAG_EXPORT_PTR_TAG) != 0) { + *ep++ = EXPORT_EXT; + ep = enc_atom(acmp, exp->code[0], ep, dflags); + ep = enc_atom(acmp, exp->code[1], ep, dflags); + ep = enc_term(acmp, make_small(exp->code[2]), ep, dflags); + } else { + /* Tag, arity */ + *ep++ = SMALL_TUPLE_EXT; + put_int8(2, ep); + ep += 1; + + /* Module name */ + ep = enc_atom(acmp, exp->code[0], ep, dflags); + + /* Function name */ + ep = enc_atom(acmp, exp->code[1], ep, dflags); + } + break; + } + break; + case FUN_DEF: + { + ErlFunThing* funp = (ErlFunThing *) fun_val(obj); + + if ((dflags & DFLAG_NEW_FUN_TAGS) != 0) { + int ei; + + *ep++ = NEW_FUN_EXT; + ESTACK_PUSH(s, ENC_PATCH_FUN_SIZE); + ESTACK_PUSH(s, (Eterm) ep); /* Position for patching in size */ + ep += 4; + *ep = funp->arity; + ep += 1; + sys_memcpy(ep, funp->fe->uniq, 16); + ep += 16; + put_int32(funp->fe->index, ep); + ep += 4; + put_int32(funp->num_free, ep); + ep += 4; + ep = enc_atom(acmp, funp->fe->module, ep, dflags); + ep = enc_term(acmp, make_small(funp->fe->old_index), ep, dflags); + ep = enc_term(acmp, make_small(funp->fe->old_uniq), ep, dflags); + ep = enc_pid(acmp, funp->creator, ep, dflags); + + fun_env: + for (ei = funp->num_free-1; ei > 0; ei--) { + ESTACK_PUSH(s, ENC_TERM); + ESTACK_PUSH(s, funp->env[ei]); + } + if (funp->num_free != 0) { + obj = funp->env[0]; + goto L_jump_start; + } + } else { + /* + * Communicating with an obsolete erl_interface or + * jinterface node. Convert the fun to a tuple to + * avoid crasching. + */ + + /* Tag, arity */ + *ep++ = SMALL_TUPLE_EXT; + put_int8(5, ep); + ep += 1; + + /* 'fun' */ + ep = enc_atom(acmp, am_fun, ep, dflags); + + /* Module name */ + ep = enc_atom(acmp, funp->fe->module, ep, dflags); + + /* Index, Uniq */ + *ep++ = INTEGER_EXT; + put_int32(funp->fe->old_index, ep); + ep += 4; + *ep++ = INTEGER_EXT; + put_int32(funp->fe->old_uniq, ep); + ep += 4; + + /* Environment sub-tuple arity */ + ASSERT(funp->num_free < MAX_ARG); + *ep++ = SMALL_TUPLE_EXT; + put_int8(funp->num_free, ep); + ep += 1; + goto fun_env; + } + } + break; + } + } + DESTROY_ESTACK(s); + return ep; +} + +static Uint +is_external_string(Eterm list, int* p_is_string) +{ + Uint len = 0; + + /* + * Calculate the length of the list as long as all characters + * are integers from 0 through 255. + */ + while (is_list(list)) { + Eterm* consp = list_val(list); + Eterm hd = CAR(consp); + + if (!is_byte(hd)) { + break; + } + len++; + list = CDR(consp); + } + + /* + * If we have reached the end of the list, and we have + * not exceeded the maximum length of a string, this + * is a string. + */ + *p_is_string = is_nil(list) && len < MAX_STRING_LEN; + + /* + * Continue to calculate the length. + */ + while (is_list(list)) { + Eterm* consp = list_val(list); + len++; + list = CDR(consp); + } + return len; +} + +static byte* +dec_term(ErtsDistExternal *edep, Eterm** hpp, byte* ep, ErlOffHeap* off_heap, Eterm* objp) +{ + int n; + register Eterm* hp = *hpp; /* Please don't take the address of hp */ + Eterm* next = objp; + + *next = (Eterm) NULL; + + while (next != NULL) { + objp = next; + next = (Eterm *) (*objp); + + switch (*ep++) { + case INTEGER_EXT: + { + Sint sn = get_int32(ep); + + ep += 4; +#if defined(ARCH_64) + *objp = make_small(sn); +#else + if (MY_IS_SSMALL(sn)) { + *objp = make_small(sn); + } else { + *objp = small_to_big(sn, hp); + hp += BIG_UINT_HEAP_SIZE; + } +#endif + break; + } + case SMALL_INTEGER_EXT: + n = get_int8(ep); + ep++; + *objp = make_small(n); + break; + case SMALL_BIG_EXT: + n = get_int8(ep); + ep++; + goto big_loop; + case LARGE_BIG_EXT: + n = get_int32(ep); + ep += 4; + big_loop: + { + Eterm big; + byte* first; + byte* last; + Uint neg; + + neg = get_int8(ep); /* Sign bit */ + ep++; + + /* + * Strip away leading zeroes to avoid creating illegal bignums. + */ + first = ep; + last = ep + n; + ep += n; + do { + --last; + } while (first <= last && *last == 0); + + if ((n = last - first + 1) == 0) { + /* Zero width bignum defaults to zero */ + big = make_small(0); + } else { + big = bytes_to_big(first, n, neg, hp); + if (is_big(big)) { + hp += big_arity(big) + 1; + } + } + *objp = big; + break; + } + case ATOM_CACHE_REF: + if (edep == 0 || (edep->flags & ERTS_DIST_EXT_ATOM_TRANS_TAB) == 0) { + goto error; + } + n = get_int8(ep); + ep++; + if (n >= edep->attab.size) + goto error; + ASSERT(is_atom(edep->attab.atom[n])); + *objp = edep->attab.atom[n]; + break; + case ATOM_EXT: + n = get_int16(ep); + ep += 2; + *objp = am_atom_put((char*)ep, n); + ep += n; + break; + case SMALL_ATOM_EXT: + n = get_int8(ep); + ep++; + *objp = am_atom_put((char*)ep, n); + ep += n; + break; + case LARGE_TUPLE_EXT: + n = get_int32(ep); + ep += 4; + goto tuple_loop; + case SMALL_TUPLE_EXT: + n = get_int8(ep); + ep++; + tuple_loop: + *objp = make_tuple(hp); + *hp++ = make_arityval(n); + hp += n; + objp = hp - 1; + while (n-- > 0) { + objp[0] = (Eterm) next; + next = objp; + objp--; + } + break; + case NIL_EXT: + *objp = NIL; + break; + case LIST_EXT: + n = get_int32(ep); + ep += 4; + if (n == 0) { + next = objp; + break; + } + *objp = make_list(hp); + hp += 2*n; + objp = hp - 2; + objp[0] = (Eterm) (objp+1); + objp[1] = (Eterm) next; + next = objp; + objp -= 2; + while (--n > 0) { + objp[0] = (Eterm) next; + objp[1] = make_list(objp + 2); + next = objp; + objp -= 2; + } + break; + case STRING_EXT: + n = get_int16(ep); + ep += 2; + if (n == 0) { + *objp = NIL; + break; + } + *objp = make_list(hp); + while (n-- > 0) { + hp[0] = make_small(*ep++); + hp[1] = make_list(hp+2); + hp += 2; + } + hp[-1] = NIL; + break; + case FLOAT_EXT: + { + FloatDef ff; + + if (sys_chars_to_double((char*)ep, &ff.fd) != 0) { + goto error; + } + ep += 31; + *objp = make_float(hp); + PUT_DOUBLE(ff, hp); + hp += FLOAT_SIZE_OBJECT; + break; + } + case NEW_FLOAT_EXT: + { + FloatDef ff; +#ifndef NO_FPE_SIGNALS + volatile unsigned long *fpexnp = erts_get_current_fp_exception(); +#endif + +#ifdef WORDS_BIGENDIAN + ff.fw[0] = get_int32(ep); + ep += 4; + ff.fw[1] = get_int32(ep); + ep += 4; +#else + ff.fw[1] = get_int32(ep); + ep += 4; + ff.fw[0] = get_int32(ep); + ep += 4; +#endif + __ERTS_FP_CHECK_INIT(fpexnp); + __ERTS_FP_ERROR_THOROUGH(fpexnp, ff.fd, goto error); + *objp = make_float(hp); + PUT_DOUBLE(ff, hp); + hp += FLOAT_SIZE_OBJECT; + break; + } + case PID_EXT: + *hpp = hp; + ep = dec_pid(edep, hpp, ep, off_heap, objp); + hp = *hpp; + if (ep == NULL) { + return NULL; + } + break; + case PORT_EXT: + { + Eterm sysname; + ErlNode *node; + Uint num; + Uint cre; + + if ((ep = dec_atom(edep, ep, &sysname)) == NULL) { + goto error; + } + if ((num = get_int32(ep)) > ERTS_MAX_PORT_NUMBER) { + goto error; + } + ep += 4; + if ((cre = get_int8(ep)) >= MAX_CREATION) { + goto error; + } + ep++; + cre = dec_set_creation(sysname,cre); + node = erts_find_or_insert_node(sysname, cre); + + if(node == erts_this_node) { + *objp = make_internal_port(num); + } + else { + ExternalThing *etp = (ExternalThing *) hp; + hp += EXTERNAL_THING_HEAD_SIZE + 1; + + etp->header = make_external_port_header(1); + etp->next = off_heap->externals; + etp->node = node; + etp->data.ui[0] = num; + + off_heap->externals = etp; + *objp = make_external_port(etp); + } + + break; + } + case REFERENCE_EXT: + { + Eterm sysname; + ErlNode *node; + int i; + Uint cre; + Uint32 *ref_num; + Uint32 r0; + Uint ref_words; + + ref_words = 1; + + if ((ep = dec_atom(edep, ep, &sysname)) == NULL) + goto error; + if ((r0 = get_int32(ep)) >= MAX_REFERENCE ) + goto error; + ep += 4; + + if ((cre = get_int8(ep)) >= MAX_CREATION) + goto error; + ep += 1; + goto ref_ext_common; + + case NEW_REFERENCE_EXT: + + ref_words = get_int16(ep); + ep += 2; + + if (ref_words > ERTS_MAX_REF_NUMBERS) + goto error; + + if ((ep = dec_atom(edep, ep, &sysname)) == NULL) + goto error; + + if ((cre = get_int8(ep)) >= MAX_CREATION) + goto error; + ep += 1; + + r0 = get_int32(ep); + ep += 4; + if (r0 >= MAX_REFERENCE) + goto error; + + ref_ext_common: + + cre = dec_set_creation(sysname, cre); + node = erts_find_or_insert_node(sysname, cre); + if(node == erts_this_node) { + RefThing *rtp = (RefThing *) hp; + hp += REF_THING_HEAD_SIZE; +#ifdef ARCH_64 + rtp->header = make_ref_thing_header(ref_words/2 + 1); +#else + rtp->header = make_ref_thing_header(ref_words); +#endif + *objp = make_internal_ref(rtp); + } + else { + ExternalThing *etp = (ExternalThing *) hp; + hp += EXTERNAL_THING_HEAD_SIZE; + +#ifdef ARCH_64 + etp->header = make_external_ref_header(ref_words/2 + 1); +#else + etp->header = make_external_ref_header(ref_words); +#endif + etp->next = off_heap->externals; + etp->node = node; + + off_heap->externals = etp; + *objp = make_external_ref(etp); + } + + ref_num = (Uint32 *) hp; +#ifdef ARCH_64 + *(ref_num++) = ref_words /* 32-bit arity */; +#endif + ref_num[0] = r0; + for(i = 1; i < ref_words; i++) { + ref_num[i] = get_int32(ep); + ep += 4; + } +#ifdef ARCH_64 + if ((1 + ref_words) % 2) + ref_num[ref_words] = 0; + hp += ref_words/2 + 1; +#else + hp += ref_words; +#endif + break; + } + case BINARY_EXT: + { + n = get_int32(ep); + ep += 4; + + if (n <= ERL_ONHEAP_BIN_LIMIT || off_heap == NULL) { + ErlHeapBin* hb = (ErlHeapBin *) hp; + + hb->thing_word = header_heap_bin(n); + hb->size = n; + hp += heap_bin_size(n); + sys_memcpy(hb->data, ep, n); + *objp = make_binary(hb); + } else { + Binary* dbin = erts_bin_nrml_alloc(n); + ProcBin* pb; + dbin->flags = 0; + dbin->orig_size = n; + erts_refc_init(&dbin->refc, 1); + sys_memcpy(dbin->orig_bytes, ep, n); + pb = (ProcBin *) hp; + hp += PROC_BIN_SIZE; + pb->thing_word = HEADER_PROC_BIN; + pb->size = n; + pb->next = off_heap->mso; + off_heap->mso = pb; + pb->val = dbin; + pb->bytes = (byte*) dbin->orig_bytes; + pb->flags = 0; + *objp = make_binary(pb); + } + ep += n; + break; + } + case BIT_BINARY_EXT: + { + Eterm bin; + ErlSubBin* sb; + Uint bitsize; + + n = get_int32(ep); + bitsize = ep[4]; + ep += 5; + if (n <= ERL_ONHEAP_BIN_LIMIT || off_heap == NULL) { + ErlHeapBin* hb = (ErlHeapBin *) hp; + + hb->thing_word = header_heap_bin(n); + hb->size = n; + sys_memcpy(hb->data, ep, n); + bin = make_binary(hb); + hp += heap_bin_size(n); + } else { + Binary* dbin = erts_bin_nrml_alloc(n); + ProcBin* pb; + dbin->flags = 0; + dbin->orig_size = n; + erts_refc_init(&dbin->refc, 1); + sys_memcpy(dbin->orig_bytes, ep, n); + pb = (ProcBin *) hp; + pb->thing_word = HEADER_PROC_BIN; + pb->size = n; + pb->next = off_heap->mso; + off_heap->mso = pb; + pb->val = dbin; + pb->bytes = (byte*) dbin->orig_bytes; + pb->flags = 0; + bin = make_binary(pb); + hp += PROC_BIN_SIZE; + } + ep += n; + if (bitsize == 0) { + *objp = bin; + } else { + sb = (ErlSubBin *) hp; + sb->thing_word = HEADER_SUB_BIN; + sb->orig = bin; + sb->size = n - 1; + sb->bitsize = bitsize; + sb->bitoffs = 0; + sb->offs = 0; + sb->is_writable = 0; + *objp = make_binary(sb); + hp += ERL_SUB_BIN_SIZE; + } + break; + } + case EXPORT_EXT: + { + Eterm mod; + Eterm name; + Eterm temp; + Sint arity; + + if ((ep = dec_atom(edep, ep, &mod)) == NULL) { + goto error; + } + if ((ep = dec_atom(edep, ep, &name)) == NULL) { + goto error; + } + *hpp = hp; + ep = dec_term(edep, hpp, ep, off_heap, &temp); + hp = *hpp; + if (ep == NULL) { + return NULL; + } + if (!is_small(temp)) { + goto error; + } + arity = signed_val(temp); + if (arity < 0) { + goto error; + } + *objp = make_export(hp); + *hp++ = HEADER_EXPORT; + *hp++ = (Eterm) erts_export_get_or_make_stub(mod, name, arity); + break; + } + break; + case NEW_FUN_EXT: + { + ErlFunThing* funp = (ErlFunThing *) hp; + Uint arity; + Eterm module; + byte* uniq; + int index; + Sint old_uniq; + Sint old_index; + unsigned num_free; + int i; + Eterm* temp_hp; + Eterm** hpp = &temp_hp; + Eterm temp; + + ep += 4; /* Skip total size in bytes */ + arity = *ep++; + uniq = ep; + ep += 16; + index = get_int32(ep); + ep += 4; + num_free = get_int32(ep); + ep += 4; + hp += ERL_FUN_SIZE; + if (num_free > 0) { + /* Don't leave a hole in case we fail */ + *hp = make_pos_bignum_header(num_free-1); + } + hp += num_free; + *hpp = hp; + funp->thing_word = HEADER_FUN; + funp->num_free = num_free; + funp->creator = NIL; /* Don't leave a hole in case we fail */ + *objp = make_fun(funp); + + /* Module */ + if ((ep = dec_atom(edep, ep, &temp)) == NULL) { + goto error; + } + module = temp; + + /* Index */ + if ((ep = dec_term(edep, hpp, ep, off_heap, &temp)) == NULL) { + goto error; + } + if (!is_small(temp)) { + goto error; + } + old_index = unsigned_val(temp); + + /* Uniq */ + if ((ep = dec_term(edep, hpp, ep, off_heap, &temp)) == NULL) { + goto error; + } + if (!is_small(temp)) { + goto error; + } + old_uniq = unsigned_val(temp); + +#ifndef HYBRID /* FIND ME! */ + /* + * It is safe to link the fun into the fun list only when + * no more validity tests can fail. + */ + funp->next = off_heap->funs; + off_heap->funs = funp; +#endif + + funp->fe = erts_put_fun_entry2(module, old_uniq, old_index, + uniq, index, arity); + funp->arity = arity; +#ifdef HIPE + if (funp->fe->native_address == NULL) { + hipe_set_closure_stub(funp->fe, num_free); + } + funp->native_address = funp->fe->native_address; +#endif + hp = *hpp; + + /* Environment */ + for (i = num_free-1; i >= 0; i--) { + funp->env[i] = (Eterm) next; + next = funp->env + i; + } + /* Creator */ + funp->creator = (Eterm) next; + next = &(funp->creator); + break; + } + case FUN_EXT: + { + ErlFunThing* funp = (ErlFunThing *) hp; + Eterm module; + Sint old_uniq; + Sint old_index; + unsigned num_free; + int i; + Eterm* temp_hp; + Eterm** hpp = &temp_hp; + Eterm temp; + + num_free = get_int32(ep); + ep += 4; + hp += ERL_FUN_SIZE; + if (num_free > 0) { + /* Don't leave a hole in the heap in case we fail. */ + *hp = make_pos_bignum_header(num_free-1); + } + hp += num_free; + *hpp = hp; + funp->thing_word = HEADER_FUN; + funp->num_free = num_free; + *objp = make_fun(funp); + + /* Creator pid */ + switch(*ep) { + case PID_EXT: + ep = dec_pid(edep, hpp, ++ep, off_heap, &funp->creator); + if (ep == NULL) { + funp->creator = NIL; /* Don't leave a hole in the heap */ + goto error; + } + break; + default: + goto error; + } + + /* Module */ + if ((ep = dec_atom(edep, ep, &temp)) == NULL) { + goto error; + } + module = temp; + + /* Index */ + if ((ep = dec_term(edep, hpp, ep, off_heap, &temp)) == NULL) { + goto error; + } + if (!is_small(temp)) { + goto error; + } + old_index = unsigned_val(temp); + + /* Uniq */ + if ((ep = dec_term(edep, hpp, ep, off_heap, &temp)) == NULL) { + goto error; + } + if (!is_small(temp)) { + goto error; + } + +#ifndef HYBRID /* FIND ME! */ + /* + * It is safe to link the fun into the fun list only when + * no more validity tests can fail. + */ + funp->next = off_heap->funs; + off_heap->funs = funp; +#endif + + old_uniq = unsigned_val(temp); + + funp->fe = erts_put_fun_entry(module, old_uniq, old_index); + funp->arity = funp->fe->address[-1] - num_free; +#ifdef HIPE + funp->native_address = funp->fe->native_address; +#endif + hp = *hpp; + + /* Environment */ + for (i = num_free-1; i >= 0; i--) { + funp->env[i] = (Eterm) next; + next = funp->env + i; + } + break; + } + default: + error: + /* + * Be careful to return the updated heap pointer, to avoid + * that the caller wipes out binaries or other off-heap objects + * that may have been linked into the process. + */ + *hpp = hp; + return NULL; + } + } + *hpp = hp; + return ep; +} + +/* returns the number of bytes needed to encode an object + to a sequence of bytes + N.B. That this must agree with to_external2() above!!! + (except for cached atoms) */ + +static Uint +encode_size_struct2(ErtsAtomCacheMap *acmp, Eterm obj, unsigned dflags) +{ + DECLARE_ESTACK(s); + Uint m, i, arity; + Uint result = 0; + + goto L_jump_start; + + outer_loop: + while (!ESTACK_ISEMPTY(s)) { + obj = ESTACK_POP(s); + + handle_popped_obj: + if (is_CP(obj)) { + Eterm* ptr = (Eterm *) obj; + + /* + * Pointer into a tuple. + */ + obj = *ptr--; + if (!is_header(obj)) { + ESTACK_PUSH(s, (Eterm)ptr); + } else { + /* Reached tuple header */ + ASSERT(header_is_arityval(obj)); + goto outer_loop; + } + } else if (is_list(obj)) { + Eterm* cons = list_val(obj); + Eterm tl; + + tl = CDR(cons); + obj = CAR(cons); + ESTACK_PUSH(s, tl); + } else if (is_nil(obj)) { + result++; + goto outer_loop; + } else { + /* + * Other term (in the tail of a non-proper list or + * in a fun's environment). + */ + } + + L_jump_start: + switch (tag_val_def(obj)) { + case NIL_DEF: + result++; + break; + case ATOM_DEF: { + int alen = atom_tab(atom_val(obj))->len; + if ((MAX_ATOM_LENGTH <= 255 || alen <= 255) + && (dflags & DFLAG_SMALL_ATOM_TAGS)) { + /* Make sure a SMALL_ATOM_EXT fits: SMALL_ATOM_EXT l t1 t2... */ + result += 1 + 1 + alen; + } + else { + /* Make sure an ATOM_EXT fits: ATOM_EXT l1 l0 t1 t2... */ + result += 1 + 2 + alen; + } + insert_acache_map(acmp, obj); + break; + } + case SMALL_DEF: + { + Sint val = signed_val(obj); + + if ((Uint)val < 256) + result += 1 + 1; /* SMALL_INTEGER_EXT */ + else if (sizeof(Sint) == 4 || IS_SSMALL28(val)) + result += 1 + 4; /* INTEGER_EXT */ + else { + Eterm tmp_big[2]; + i = big_bytes(small_to_big(val, tmp_big)); + result += 1 + 1 + 1 + i; /* SMALL_BIG_EXT */ + } + } + break; + case BIG_DEF: + if ((i = big_bytes(obj)) < 256) + result += 1 + 1 + 1 + i; /* tag,size,sign,digits */ + else + result += 1 + 4 + 1 + i; /* tag,size,sign,digits */ + break; + case PID_DEF: + case EXTERNAL_PID_DEF: + result += (1 + encode_size_struct2(acmp, pid_node_name(obj), dflags) + + 4 + 4 + 1); + break; + case REF_DEF: + case EXTERNAL_REF_DEF: + ASSERT(dflags & DFLAG_EXTENDED_REFERENCES); + i = ref_no_of_numbers(obj); + result += (1 + 2 + encode_size_struct2(acmp, ref_node_name(obj), dflags) + + 1 + 4*i); + break; + case PORT_DEF: + case EXTERNAL_PORT_DEF: + result += (1 + encode_size_struct2(acmp, port_node_name(obj), dflags) + + 4 + 1); + break; + case LIST_DEF: + if ((m = is_string(obj)) && (m < MAX_STRING_LEN)) { + result += m + 2 + 1; + } else { + result += 5; + goto handle_popped_obj; + } + break; + case TUPLE_DEF: + { + Eterm* ptr = tuple_val(obj); + + arity = arityval(*ptr); + if (arity <= 0xff) { + result += 1 + 1; + } else { + result += 1 + 4; + } + ptr += arity; + obj = (Eterm) ptr; + goto handle_popped_obj; + } + break; + case FLOAT_DEF: + if (dflags & DFLAG_NEW_FLOATS) { + result += 9; + } else { + result += 32; /* Yes, including the tag */ + } + break; + case BINARY_DEF: + result += 1 + 4 + binary_size(obj) + + 5; /* For unaligned binary */ + break; + case FUN_DEF: + { + ErlFunThing* funp = (ErlFunThing *) fun_val(obj); + + if ((dflags & DFLAG_NEW_FUN_TAGS) != 0) { + result += 20+1+1+4; /* New ID + Tag */ + result += 4; /* Length field (number of free variables */ + result += encode_size_struct2(acmp, funp->creator, dflags); + result += encode_size_struct2(acmp, funp->fe->module, dflags); + result += 2 * (1+4); /* Index, Uniq */ + } else { + /* + * Size when fun is mapped to a tuple. + */ + result += 1 + 1; /* Tuple tag, arity */ + result += 1 + 1 + 2 + + atom_tab(atom_val(am_fun))->len; /* 'fun' */ + result += 1 + 1 + 2 + + atom_tab(atom_val(funp->fe->module))->len; /* Module name */ + result += 2 * (1 + 4); /* Index + Uniq */ + result += 1 + (funp->num_free < 0x100 ? 1 : 4); + } + for (i = 1; i < funp->num_free; i++) { + obj = funp->env[i]; + + if (is_not_list(obj)) { + /* Push any non-list terms on the stack */ + ESTACK_PUSH(s, obj); + } else { + /* Lists must be handled specially. */ + if ((m = is_string(obj)) && (m < MAX_STRING_LEN)) { + result += m + 2 + 1; + } else { + result += 5; + ESTACK_PUSH(s, obj); + } + } + } + if (funp->num_free != 0) { + obj = funp->env[0]; + goto L_jump_start; + } + break; + } + + case EXPORT_DEF: + { + Export* ep = (Export *) (export_val(obj))[1]; + result += 1; + result += encode_size_struct2(acmp, ep->code[0], dflags); + result += encode_size_struct2(acmp, ep->code[1], dflags); + result += encode_size_struct2(acmp, make_small(ep->code[2]), dflags); + } + break; + + default: + erl_exit(1,"Internal data structure error (in encode_size_struct2)%x\n", + obj); + } + } + + DESTROY_ESTACK(s); + return result; +} + +static Sint +decoded_size(byte *ep, byte* endp, int no_refc_bins) +{ + int heap_size = 0; + int terms; + int atom_extra_skip = 0; + Uint n; + +#define SKIP(sz) \ + do { \ + if ((sz) <= endp-ep) { \ + ep += (sz); \ + } else { return -1; }; \ + } while (0) + +#define SKIP2(sz1, sz2) \ + do { \ + Uint sz = (sz1) + (sz2); \ + if (sz1 < sz && (sz) <= endp-ep) { \ + ep += (sz); \ + } else { return -1; } \ + } while (0) + +#define CHKSIZE(sz) \ + do { \ + if ((sz) > endp-ep) { return -1; } \ + } while (0) + +#define ADDTERMS(n) \ + do { \ + int before = terms; \ + terms += (n); \ + if (terms < before) return -1; \ + } while (0) + + + for (terms=1; terms > 0; terms--) { + int tag; + + CHKSIZE(1); + tag = ep++[0]; + switch (tag) { + case INTEGER_EXT: + SKIP(4); + heap_size += BIG_UINT_HEAP_SIZE; + break; + case SMALL_INTEGER_EXT: + SKIP(1); + break; + case SMALL_BIG_EXT: + CHKSIZE(1); + n = ep[0]; /* number of bytes */ + SKIP2(n, 1+1); /* skip size,sign,digits */ + heap_size += 1+(n+sizeof(Eterm)-1)/sizeof(Eterm); /* XXX: 1 too much? */ + break; + case LARGE_BIG_EXT: + CHKSIZE(4); + n = get_int32(ep); + SKIP2(n,4+1); /* skip, size,sign,digits */ + heap_size += 1+1+(n+sizeof(Eterm)-1)/sizeof(Eterm); /* XXX: 1 too much? */ + break; + case ATOM_EXT: + CHKSIZE(2); + n = get_int16(ep); + if (n > MAX_ATOM_LENGTH) { + return -1; + } + SKIP(n+2+atom_extra_skip); + atom_extra_skip = 0; + break; + case SMALL_ATOM_EXT: + CHKSIZE(1); + n = get_int8(ep); + if (n > MAX_ATOM_LENGTH) { + return -1; + } + SKIP(n+1+atom_extra_skip); + atom_extra_skip = 0; + break; + case ATOM_CACHE_REF: + SKIP(1+atom_extra_skip); + atom_extra_skip = 0; + break; + case PID_EXT: + atom_extra_skip = 9; + /* In case it is an external pid */ + heap_size += EXTERNAL_THING_HEAD_SIZE + 1; + terms++; + break; + case PORT_EXT: + atom_extra_skip = 5; + /* In case it is an external port */ + heap_size += EXTERNAL_THING_HEAD_SIZE + 1; + terms++; + break; + case NEW_REFERENCE_EXT: + { + int id_words; + + CHKSIZE(2); + id_words = get_int16(ep); + + if (id_words > ERTS_MAX_REF_NUMBERS) + return -1; + + ep += 2; + atom_extra_skip = 1 + 4*id_words; + /* In case it is an external ref */ +#ifdef ARCH_64 + heap_size += EXTERNAL_THING_HEAD_SIZE + id_words/2 + 1; +#else + heap_size += EXTERNAL_THING_HEAD_SIZE + id_words; +#endif + terms++; + break; + } + case REFERENCE_EXT: + /* In case it is an external ref */ + heap_size += EXTERNAL_THING_HEAD_SIZE + 1; + atom_extra_skip = 5; + terms++; + break; + case NIL_EXT: + break; + case LIST_EXT: + CHKSIZE(4); + n = get_int32(ep); + ep += 4; + ADDTERMS(n); + terms++; + heap_size += 2 * n; + break; + case SMALL_TUPLE_EXT: + CHKSIZE(1); + n = *ep++; + terms += n; + heap_size += n + 1; + break; + case LARGE_TUPLE_EXT: + CHKSIZE(4); + n = get_int32(ep); + ep += 4; + ADDTERMS(n); + heap_size += n + 1; + break; + case STRING_EXT: + CHKSIZE(2); + n = get_int16(ep); + SKIP(n+2); + heap_size += 2 * n; + break; + case FLOAT_EXT: + SKIP(31); + heap_size += FLOAT_SIZE_OBJECT; + break; + case NEW_FLOAT_EXT: + SKIP(8); + heap_size += FLOAT_SIZE_OBJECT; + break; + case BINARY_EXT: + CHKSIZE(4); + n = get_int32(ep); + SKIP2(n, 4); + if (n <= ERL_ONHEAP_BIN_LIMIT || no_refc_bins) { + heap_size += heap_bin_size(n); + } else { + heap_size += PROC_BIN_SIZE; + } + break; + case BIT_BINARY_EXT: + { + CHKSIZE(5); + n = get_int32(ep); + SKIP2(n, 5); + if (n <= ERL_ONHEAP_BIN_LIMIT || no_refc_bins) { + heap_size += heap_bin_size(n) + ERL_SUB_BIN_SIZE; + } else { + heap_size += PROC_BIN_SIZE + ERL_SUB_BIN_SIZE; + } + } + break; + case EXPORT_EXT: + terms += 3; + heap_size += 2; + break; + case NEW_FUN_EXT: + { + unsigned num_free; + Uint total_size; + + CHKSIZE(1+16+4+4); + total_size = get_int32(ep); + CHKSIZE(total_size); + ep += 1+16+4+4; + /*FALLTHROUGH*/ + + case FUN_EXT: + CHKSIZE(4); + num_free = get_int32(ep); + ep += 4; + if (num_free > MAX_ARG) { + return -1; + } + terms += 4 + num_free; + heap_size += ERL_FUN_SIZE + num_free; + break; + } + default: + return -1; + } + } + /* 'terms' may be non-zero if it has wrapped around */ + return terms==0 ? heap_size : -1; +#undef SKIP +#undef SKIP2 +#undef CHKSIZE +} diff --git a/erts/emulator/beam/external.h b/erts/emulator/beam/external.h new file mode 100644 index 0000000000..f308680f89 --- /dev/null +++ b/erts/emulator/beam/external.h @@ -0,0 +1,211 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* Same order as the ordering of terms in erlang */ + +/* Since there are 255 different External tag values to choose from + There is no reason to not be extravagant. + Hence, the different tags for large/small tuple e.t.c +*/ + + +#ifdef ERTS_WANT_EXTERNAL_TAGS +#ifndef ERTS_EXTERNAL_TAGS +#define ERTS_EXTERNAL_TAGS + +#define SMALL_INTEGER_EXT 'a' +#define INTEGER_EXT 'b' +#define FLOAT_EXT 'c' +#define ATOM_EXT 'd' +#define SMALL_ATOM_EXT 's' +#define REFERENCE_EXT 'e' +#define NEW_REFERENCE_EXT 'r' +#define PORT_EXT 'f' +#define NEW_FLOAT_EXT 'F' +#define PID_EXT 'g' +#define SMALL_TUPLE_EXT 'h' +#define LARGE_TUPLE_EXT 'i' +#define NIL_EXT 'j' +#define STRING_EXT 'k' +#define LIST_EXT 'l' +#define BINARY_EXT 'm' +#define BIT_BINARY_EXT 'M' +#define SMALL_BIG_EXT 'n' +#define LARGE_BIG_EXT 'o' +#define NEW_FUN_EXT 'p' +#define EXPORT_EXT 'q' +#define FUN_EXT 'u' + +#define DIST_HEADER 'D' +#define ATOM_CACHE_REF 'R' +#define COMPRESSED 'P' + +#if 0 +/* Not used anymore */ +#define CACHED_ATOM 'C' +#define NEW_CACHE 'N' +#endif + + +#define VERSION_MAGIC 131 /* 130 in erlang 4.2 */ + /* Increment this when changing the external format. */ + /* ON the other hand, don't change the external format */ + /* since that breaks other people's code! */ + +#endif /* ERTS_EXTERNAL_TAGS */ +#endif /* ERTS_WANT_EXTERNAL_TAGS */ + +#ifndef ERL_EXTERNAL_H__ +#define ERL_EXTERNAL_H__ + +#include "erl_node_tables.h" + +#define ERTS_ATOM_CACHE_SIZE 2048 + +typedef struct cache { + Eterm in_arr[ERTS_ATOM_CACHE_SIZE]; + Eterm out_arr[ERTS_ATOM_CACHE_SIZE]; +} ErtsAtomCache; + +typedef struct { + int hdr_sz; + int sz; + int cix[ERTS_ATOM_CACHE_SIZE]; + struct { + Eterm atom; + int iix; + } cache[ERTS_ATOM_CACHE_SIZE]; +} ErtsAtomCacheMap; + +typedef struct { + Uint32 size; + Eterm atom[ERTS_ATOM_CACHE_SIZE]; +} ErtsAtomTranslationTable; + +#define ERTS_DIST_EXT_DFLAG_HDR (((Uint32) 1) << 31) +#define ERTS_DIST_EXT_ATOM_TRANS_TAB (((Uint32) 1) << 30) +#define ERTS_DIST_EXT_CON_ID_MASK ((Uint32) 0x3fffffff) + +#define ERTS_DIST_EXT_CON_ID(DIST_EXTP) \ + ((DIST_EXTP)->flags & ERTS_DIST_EXT_CON_ID_MASK) +typedef struct { + DistEntry *dep; + byte *extp; + byte *ext_endp; + Sint heap_size; + Uint32 flags; + ErtsAtomTranslationTable attab; +} ErtsDistExternal; + +typedef struct { + int have_header; + int cache_entries; +} ErtsDistHeaderPeek; + +#define ERTS_DIST_EXT_SIZE(EDEP) \ + (sizeof(ErtsDistExternal) \ + - (((EDEP)->flags & ERTS_DIST_EXT_ATOM_TRANS_TAB) \ + ? (ASSERT_EXPR(0 <= (EDEP)->attab.size \ + && (EDEP)->attab.size <= ERTS_ATOM_CACHE_SIZE), \ + sizeof(Eterm)*(ERTS_ATOM_CACHE_SIZE - (EDEP)->attab.size)) \ + : sizeof(ErtsAtomTranslationTable))) + +typedef struct { + byte *extp; + int exttmp; +} ErtsBinary2TermState; + +/* -------------------------------------------------------------------------- */ + +void erts_init_atom_cache_map(ErtsAtomCacheMap *); +void erts_reset_atom_cache_map(ErtsAtomCacheMap *); +void erts_destroy_atom_cache_map(ErtsAtomCacheMap *); +void erts_finalize_atom_cache_map(ErtsAtomCacheMap *); +Uint erts_encode_ext_dist_header_size(ErtsAtomCacheMap *); + +Uint erts_encode_ext_dist_header_size(ErtsAtomCacheMap *); +byte *erts_encode_ext_dist_header_setup(byte *, ErtsAtomCacheMap *); +byte *erts_encode_ext_dist_header_finalize(byte *, ErtsAtomCache *); +Uint erts_encode_dist_ext_size(Eterm, Uint32, ErtsAtomCacheMap *); +void erts_encode_dist_ext(Eterm, byte **, Uint32, ErtsAtomCacheMap *); + +Uint erts_encode_ext_size(Eterm); +void erts_encode_ext(Eterm, byte **); + +#ifdef ERTS_WANT_EXTERNAL_TAGS +ERTS_GLB_INLINE void erts_peek_dist_header(ErtsDistHeaderPeek *, byte *, Uint); +#endif +ERTS_GLB_INLINE void erts_free_dist_ext_copy(ErtsDistExternal *); +ERTS_GLB_INLINE void *erts_dist_ext_trailer(ErtsDistExternal *); +ErtsDistExternal *erts_make_dist_ext_copy(ErtsDistExternal *, Uint); +void *erts_dist_ext_trailer(ErtsDistExternal *); +void erts_destroy_dist_ext_copy(ErtsDistExternal *); +int erts_prepare_dist_ext(ErtsDistExternal *, byte *, Uint, + DistEntry *, ErtsAtomCache *); +Sint erts_decode_dist_ext_size(ErtsDistExternal *, int); +Eterm erts_decode_dist_ext(Eterm **, ErlOffHeap *, ErtsDistExternal *); + +Sint erts_decode_ext_size(byte*, Uint, int); +Eterm erts_decode_ext(Eterm **, ErlOffHeap *, byte**); + +Eterm erts_term_to_binary(Process* p, Eterm Term, int level, Uint flags); + +Sint erts_binary2term_prepare(ErtsBinary2TermState *, byte *, Sint); +void erts_binary2term_abort(ErtsBinary2TermState *); +Eterm erts_binary2term_create(ErtsBinary2TermState *, Eterm **hpp, ErlOffHeap *); +int erts_debug_max_atom_out_cache_index(void); +int erts_debug_atom_to_out_cache_index(Eterm); + + +#if ERTS_GLB_INLINE_INCL_FUNC_DEF +#ifdef ERTS_WANT_EXTERNAL_TAGS +ERTS_GLB_INLINE void +erts_peek_dist_header(ErtsDistHeaderPeek *dhpp, byte *ext, Uint sz) +{ + if (ext[0] == VERSION_MAGIC + || ext[1] != DIST_HEADER + || sz < (1+1+1)) + dhpp->have_header = 0; + else { + dhpp->have_header = 1; + dhpp->cache_entries = (int) get_int8(&ext[2]); + } +} +#endif + +ERTS_GLB_INLINE void +erts_free_dist_ext_copy(ErtsDistExternal *edep) +{ + if (edep->dep) + erts_deref_dist_entry(edep->dep); + erts_free(ERTS_ALC_T_EXT_TERM_DATA, edep); +} + +ERTS_GLB_INLINE void * +erts_dist_ext_trailer(ErtsDistExternal *edep) +{ + void *res = (void *) (edep->ext_endp + + ERTS_WORD_ALIGN_PAD_SZ(edep->ext_endp)); + ASSERT((((Uint) res) % sizeof(Uint)) == 0); + return res; +} + +#endif + +#endif /* ERL_EXTERNAL_H__ */ diff --git a/erts/emulator/beam/fix_alloc.c b/erts/emulator/beam/fix_alloc.c new file mode 100644 index 0000000000..5637281597 --- /dev/null +++ b/erts/emulator/beam/fix_alloc.c @@ -0,0 +1,287 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ +/* General purpose Memory allocator for fixed block size objects */ +/* This allocater is at least an order of magnitude faster than malloc() */ + + +#define NOPERBLOCK 20 +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "erl_db.h" + +#ifdef ERTS_ALC_N_MIN_A_FIXED_SIZE + +#if ERTS_ALC_MTA_FIXED_SIZE +#include "erl_threads.h" +#include "erl_smp.h" +# ifdef ERTS_SMP +# define FA_LOCK(FA) erts_smp_spin_lock(&(FA)->slck) +# define FA_UNLOCK(FA) erts_smp_spin_unlock(&(FA)->slck) +# else +# define FA_LOCK(FA) erts_mtx_lock(&(FA)->mtx) +# define FA_UNLOCK(FA) erts_mtx_unlock(&(FA)->mtx) +# endif +#else +# define FA_LOCK(FA) +# define FA_UNLOCK(FA) +#endif + +typedef union {double d; long l;} align_t; + +typedef struct fix_alloc_block { + struct fix_alloc_block *next; + align_t mem[1]; +} FixAllocBlock; + +typedef struct fix_alloc { + Uint item_size; + void *freelist; + Uint no_free; + Uint no_blocks; + FixAllocBlock *blocks; +#if ERTS_ALC_MTA_FIXED_SIZE +# ifdef ERTS_SMP + erts_smp_spinlock_t slck; +# else + erts_mtx_t mtx; +# endif +#endif +} FixAlloc; + +static void *(*core_alloc)(Uint); +static Uint xblk_sz; + +static FixAlloc **fa; +#define FA_SZ (1 + ERTS_ALC_N_MAX_A_FIXED_SIZE - ERTS_ALC_N_MIN_A_FIXED_SIZE) + +#define FIX_IX(N) ((N) - ERTS_ALC_N_MIN_A_FIXED_SIZE) + +#define FIX_POOL_SZ(I_SZ) \ + ((I_SZ)*NOPERBLOCK + sizeof(FixAllocBlock) - sizeof(align_t)) + +#if defined(DEBUG) && !ERTS_ALC_MTA_FIXED_SIZE +static int first_time; +#endif + +void erts_init_fix_alloc(Uint extra_block_size, + void *(*alloc)(Uint)) +{ + int i; + + xblk_sz = extra_block_size; + core_alloc = alloc; + + fa = (FixAlloc **) (*core_alloc)(FA_SZ * sizeof(FixAlloc *)); + if (!fa) + erts_alloc_enomem(ERTS_ALC_T_UNDEF, FA_SZ * sizeof(FixAlloc *)); + + for (i = 0; i < FA_SZ; i++) + fa[i] = NULL; +#if defined(DEBUG) && !ERTS_ALC_MTA_FIXED_SIZE + first_time = 1; +#endif +} + +Uint +erts_get_fix_size(ErtsAlcType_t type) +{ + Uint i = FIX_IX(ERTS_ALC_T2N(type)); + return i < FA_SZ && fa[i] ? fa[i]->item_size : 0; +} + +void +erts_set_fix_size(ErtsAlcType_t type, Uint size) +{ + Uint sz; + Uint i; + FixAlloc *fs; + ErtsAlcType_t t_no = ERTS_ALC_T2N(type); + sz = xblk_sz + size; + +#ifdef DEBUG + ASSERT(ERTS_ALC_N_MIN_A_FIXED_SIZE <= t_no); + ASSERT(t_no <= ERTS_ALC_N_MAX_A_FIXED_SIZE); +#endif + + while (sz % sizeof(align_t) != 0) /* Alignment */ + sz++; + + i = FIX_IX(t_no); + fs = (FixAlloc *) (*core_alloc)(sizeof(FixAlloc)); + if (!fs) + erts_alloc_n_enomem(t_no, sizeof(FixAlloc)); + + fs->item_size = sz; + fs->no_blocks = 0; + fs->no_free = 0; + fs->blocks = NULL; + fs->freelist = NULL; + if (fa[i]) + erl_exit(-1, "Attempt to overwrite existing fix size (%d)", i); + fa[i] = fs; + +#if ERTS_ALC_MTA_FIXED_SIZE +#ifdef ERTS_SMP + erts_smp_spinlock_init_x(&fs->slck, "fix_alloc", make_small(i)); +#else + erts_mtx_init_x(&fs->mtx, "fix_alloc", make_small(i)); +#endif +#endif + +} + +void +erts_fix_info(ErtsAlcType_t type, ErtsFixInfo *efip) +{ + Uint i; + FixAlloc *f; +#ifdef DEBUG + FixAllocBlock *b; + void *fp; +#endif + Uint real_item_size; + ErtsAlcType_t t_no = ERTS_ALC_T2N(type); + + ASSERT(ERTS_ALC_N_MIN_A_FIXED_SIZE <= t_no); + ASSERT(t_no <= ERTS_ALC_N_MAX_A_FIXED_SIZE); + + i = FIX_IX(t_no); + f = fa[i]; + + efip->total = sizeof(FixAlloc *); + efip->used = 0; + if (!f) + return; + + real_item_size = f->item_size - xblk_sz; + + FA_LOCK(f); + + efip->total += sizeof(FixAlloc); + efip->total += f->no_blocks*FIX_POOL_SZ(real_item_size); + efip->used = efip->total - f->no_free*real_item_size; + +#ifdef DEBUG + ASSERT(efip->total >= efip->used); + for(i = 0, b = f->blocks; b; i++, b = b->next); + ASSERT(f->no_blocks == i); + for (i = 0, fp = f->freelist; fp; i++, fp = *((void **) fp)); + ASSERT(f->no_free == i); +#endif + + FA_UNLOCK(f); + +} + +void +erts_fix_free(ErtsAlcType_t t_no, void *extra, void* ptr) +{ + Uint i; + FixAlloc *f; + + ASSERT(ERTS_ALC_N_MIN_A_FIXED_SIZE <= t_no); + ASSERT(t_no <= ERTS_ALC_N_MAX_A_FIXED_SIZE); + + i = FIX_IX(t_no); + f = fa[i]; + + FA_LOCK(f); + *((void **) ptr) = f->freelist; + f->freelist = ptr; + f->no_free++; + FA_UNLOCK(f); +} + + +void *erts_fix_realloc(ErtsAlcType_t t_no, void *extra, void* ptr, Uint size) +{ + erts_alc_fatal_error(ERTS_ALC_E_NOTSUP, ERTS_ALC_O_REALLOC, t_no); + return NULL; +} + +void *erts_fix_alloc(ErtsAlcType_t t_no, void *extra, Uint size) +{ + void *ret; + int i; + FixAlloc *f; + +#if defined(DEBUG) && !ERTS_ALC_MTA_FIXED_SIZE + ASSERT(ERTS_ALC_N_MIN_A_FIXED_SIZE <= t_no); + ASSERT(t_no <= ERTS_ALC_N_MAX_A_FIXED_SIZE); + if (first_time) { /* Check that all sizes have been initialized */ + int i; + for (i = 0; i < FA_SZ; i++) + ASSERT(fa[i]); + first_time = 0; + } +#endif + + + i = FIX_IX(t_no); + f = fa[i]; + + ASSERT(f); + ASSERT(f->item_size >= size); + + FA_LOCK(f); + if (f->freelist == NULL) { /* Gotta alloc some more mem */ + char *ptr; + FixAllocBlock *bl; + Uint n; + + + FA_UNLOCK(f); + bl = (*core_alloc)(FIX_POOL_SZ(f->item_size)); + if (!bl) + return NULL; + + FA_LOCK(f); + bl->next = f->blocks; /* link in first */ + f->blocks = bl; + + n = NOPERBLOCK; + ptr = (char *) &f->blocks->mem[0]; + while(n--) { + *((void **) ptr) = f->freelist; + f->freelist = (void *) ptr; + ptr += f->item_size; + } +#if !ERTS_ALC_MTA_FIXED_SIZE + ASSERT(f->no_free == 0); +#endif + f->no_free += NOPERBLOCK; + f->no_blocks++; + } + + ret = f->freelist; + f->freelist = *((void **) f->freelist); + ASSERT(f->no_free > 0); + f->no_free--; + + FA_UNLOCK(f); + + return ret; +} + +#endif /* #ifdef ERTS_ALC_N_MIN_A_FIXED_SIZE */ diff --git a/erts/emulator/beam/global.h b/erts/emulator/beam/global.h new file mode 100644 index 0000000000..1b64e23174 --- /dev/null +++ b/erts/emulator/beam/global.h @@ -0,0 +1,1800 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifndef __GLOBAL_H__ +#define __GLOBAL_H__ + +#include "sys.h" +#include "erl_alloc.h" +#include "erl_vm.h" +#include "erl_node_container_utils.h" +#include "hash.h" +#include "index.h" +#include "atom.h" +#include "export.h" +#include "module.h" +#include "register.h" +#include "erl_fun.h" +#include "erl_node_tables.h" +#include "benchmark.h" +#include "erl_process.h" +#include "erl_sys_driver.h" +#include "erl_debug.h" + +typedef struct port Port; +#include "erl_port_task.h" + +#define ERTS_MAX_NO_OF_ASYNC_THREADS 1024 +extern int erts_async_max_threads; +#define ERTS_ASYNC_THREAD_MIN_STACK_SIZE 16 /* Kilo words */ +#define ERTS_ASYNC_THREAD_MAX_STACK_SIZE 8192 /* Kilo words */ +extern int erts_async_thread_suggested_stack_size; + +typedef struct erts_driver_t_ erts_driver_t; + +#define SMALL_IO_QUEUE 5 /* Number of fixed elements */ + +typedef struct { + int size; /* total size in bytes */ + + SysIOVec* v_start; + SysIOVec* v_end; + SysIOVec* v_head; + SysIOVec* v_tail; + SysIOVec v_small[SMALL_IO_QUEUE]; + + ErlDrvBinary** b_start; + ErlDrvBinary** b_end; + ErlDrvBinary** b_head; + ErlDrvBinary** b_tail; + ErlDrvBinary* b_small[SMALL_IO_QUEUE]; +} ErlIOQueue; + +typedef struct line_buf { /* Buffer used in line oriented I/O */ + int bufsiz; /* Size of character buffer */ + int ovlen; /* Length of overflow data */ + int ovsiz; /* Actual size of overflow buffer */ + char data[1]; /* Starting point of buffer data, + data[0] is a flag indicating an unprocess CR, + The rest is the overflow buffer. */ +} LineBuf; + +struct enif_environment_t /* ErlNifEnv */ +{ + void* nif_data; + Process* proc; + Eterm* hp; + Eterm* hp_end; + unsigned heap_frag_sz; + int fpe_was_unmasked; +}; +extern void erts_pre_nif(struct enif_environment_t*, Process*, void* nif_data); +extern void erts_post_nif(struct enif_environment_t* env); +extern Eterm erts_nif_taints(Process* p); + +/* + * Port Specific Data. + * + * Only use PrtSD for very rarely used data. + */ + +#define ERTS_PRTSD_SCHED_ID 0 + +#define ERTS_PRTSD_SIZE 1 + +typedef struct { + void *data[ERTS_PRTSD_SIZE]; +} ErtsPrtSD; + +#ifdef ERTS_SMP +typedef struct ErtsXPortsList_ ErtsXPortsList; +#endif + +/* + * Port locking: + * + * Locking is done either driver specific or port specific. When + * driver specific locking is used, all instances of the driver, + * i.e. ports running the driver, share the same lock. When port + * specific locking is used each instance have its own lock. + * + * Most fields in the Port structure are protected by the lock + * referred to by the lock field. I'v called it the port lock. + * This lock is shared between all ports running the same driver + * when driver specific locking is used. + * + * The 'sched' field is protected by the port tasks lock + * (see erl_port_tasks.c) + * + * The 'status' field is protected by a combination of the port lock, + * the port tasks lock, and the state_lck. It may be read if + * the state_lck, or the port lock is held. It may only be + * modified if both the port lock and the state_lck is held + * (with one exception; see below). When changeing status from alive + * to dead or vice versa, also the port task lock has to be held. + * This in order to guarantee that tasks are scheduled only for + * ports that are alive. + * + * The status field may be modified with only the state_lck + * held when status is changed from dead to alive. This since no + * threads can have any references to the port other than via the + * port table. + * + * /rickard + */ + +struct port { + ErtsPortTaskSched sched; + ErtsPortTaskHandle timeout_task; +#ifdef ERTS_SMP + erts_smp_atomic_t refc; + erts_smp_mtx_t *lock; + ErtsXPortsList *xports; + erts_smp_atomic_t run_queue; + erts_smp_spinlock_t state_lck; /* protects: id, status, snapshot */ +#endif + Eterm id; /* The Port id of this port */ + Eterm connected; /* A connected process */ + Eterm caller; /* Current caller. */ + Eterm data; /* Data associated with port. */ + ErlHeapFragment* bp; /* Heap fragment holding data (NULL if imm data). */ + ErtsLink *nlinks; + ErtsMonitor *monitors; /* Only MON_ORIGIN monitors of pid's */ + Uint bytes_in; /* Number of bytes read */ + Uint bytes_out; /* Number of bytes written */ +#ifdef ERTS_SMP + ErtsSmpPTimer *ptimer; +#else + ErlTimer tm; /* Timer entry */ +#endif + + Eterm tracer_proc; /* If the port is traced, this is the tracer */ + Uint trace_flags; /* Trace flags */ + + ErlIOQueue ioq; /* driver accessible i/o queue */ + DistEntry *dist_entry; /* Dist entry used in DISTRIBUTION */ + char *name; /* String used in the open */ + erts_driver_t* drv_ptr; + long drv_data; + ErtsProcList *suspended; /* List of suspended processes. */ + LineBuf *linebuf; /* Buffer to hold data not ready for + process to get (line oriented I/O)*/ + Uint32 status; /* Status and type flags */ + int control_flags; /* Flags for port_control() */ + Uint32 snapshot; /* Next snapshot that port should be part of */ + struct reg_proc *reg; + ErlDrvPDL port_data_lock; + + ErtsPrtSD *psd; /* Port specific data */ +}; + + +ERTS_GLB_INLINE ErtsRunQueue *erts_port_runq(Port *prt); + +#if ERTS_GLB_INLINE_INCL_FUNC_DEF + +ERTS_GLB_INLINE ErtsRunQueue * +erts_port_runq(Port *prt) +{ +#ifdef ERTS_SMP + ErtsRunQueue *rq1, *rq2; + rq1 = (ErtsRunQueue *) erts_smp_atomic_read(&prt->run_queue); + while (1) { + erts_smp_runq_lock(rq1); + rq2 = (ErtsRunQueue *) erts_smp_atomic_read(&prt->run_queue); + if (rq1 == rq2) + return rq1; + erts_smp_runq_unlock(rq1); + rq1 = rq2; + } +#else + return erts_common_run_queue; +#endif +} + +#endif + + +ERTS_GLB_INLINE void *erts_prtsd_get(Port *p, int ix); +ERTS_GLB_INLINE void *erts_prtsd_set(Port *p, int ix, void *new); + +#if ERTS_GLB_INLINE_INCL_FUNC_DEF + +ERTS_GLB_INLINE void * +erts_prtsd_get(Port *prt, int ix) +{ + return prt->psd ? prt->psd->data[ix] : NULL; +} + +ERTS_GLB_INLINE void * +erts_prtsd_set(Port *prt, int ix, void *data) +{ + if (prt->psd) { + void *old = prt->psd->data[ix]; + prt->psd->data[ix] = data; + return old; + } + else { + prt->psd = erts_alloc(ERTS_ALC_T_PRTSD, sizeof(ErtsPrtSD)); + prt->psd->data[ix] = data; + return NULL; + } +} + +#endif + +/* Driver handle (wrapper for old plain handle) */ +#define ERL_DE_OK 0 +#define ERL_DE_UNLOAD 1 +#define ERL_DE_FORCE_UNLOAD 2 +#define ERL_DE_RELOAD 3 +#define ERL_DE_FORCE_RELOAD 4 +#define ERL_DE_PERMANENT 5 + +#define ERL_DE_PROC_LOADED 0 +#define ERL_DE_PROC_AWAIT_UNLOAD 1 +#define ERL_DE_PROC_AWAIT_UNLOAD_ONLY 2 +#define ERL_DE_PROC_AWAIT_LOAD 3 + +/* Flags for process entries */ +#define ERL_DE_FL_DEREFERENCED 1 + +/* Flags for drivers, put locking policy here /PaN */ +#define ERL_DE_FL_KILL_PORTS 1 + +#define ERL_FL_CONSISTENT_MASK ( ERL_DE_FL_KILL_PORTS ) + +/* System specific load errors are returned as positive values */ +#define ERL_DE_NO_ERROR 0 +#define ERL_DE_LOAD_ERROR_NO_INIT -1 +#define ERL_DE_LOAD_ERROR_FAILED_INIT -2 +#define ERL_DE_LOAD_ERROR_BAD_NAME -3 +#define ERL_DE_LOAD_ERROR_NAME_TO_LONG -4 +#define ERL_DE_LOAD_ERROR_INCORRECT_VERSION -5 +#define ERL_DE_ERROR_NO_DDLL_FUNCTIONALITY -6 +#define ERL_DE_ERROR_UNSPECIFIED -7 +#define ERL_DE_LOOKUP_ERROR_NOT_FOUND -8 +#define ERL_DE_DYNAMIC_ERROR_OFFSET -10 + +typedef struct de_proc_entry { + Process *proc; /* The process... */ + Uint awaiting_status; /* PROC_LOADED == Have loaded the driver + PROC_AWAIT_UNLOAD == Wants to be notified + when we have unloaded the driver (was locked) + PROC_AWAIT_LOAD == Wants to be notified when we + reloaded the driver (old was locked) */ + Uint flags; /* ERL_FL_DE_DEREFERENCED when reload in progress */ + Eterm heap[REF_THING_SIZE]; /* "ref heap" */ + struct de_proc_entry *next; +} DE_ProcEntry; + +typedef struct { + void *handle; /* Handle for DLL or SO (for dyn. drivers). */ + DE_ProcEntry *procs; /* List of pids that have loaded this driver, + or that wait for it to change state */ + erts_refc_t refc; /* Number of ports/processes having + references to the driver */ + Uint port_count; /* Number of ports using the driver */ + Uint flags; /* ERL_DE_FL_KILL_PORTS */ + int status; /* ERL_DE_xxx */ + char *full_path; /* Full path of the driver */ + char *reload_full_path; /* If status == ERL_DE_RELOAD, this contains + full name of driver (path) */ + char *reload_driver_name; /* ... and this contains the driver name */ + Uint reload_flags; /* flags for reloaded driver */ +} DE_Handle; + +/* + * This structure represents a link to the next driver. + */ + +struct erts_driver_t_ { + erts_driver_t *next; + erts_driver_t *prev; + char *name; + struct { + int major; + int minor; + } version; + int flags; + DE_Handle *handle; +#ifdef ERTS_SMP + erts_smp_mtx_t *lock; +#endif + ErlDrvEntry *entry; + ErlDrvData (*start)(ErlDrvPort port, char *command, SysDriverOpts* opts); + void (*stop)(ErlDrvData drv_data); + void (*finish)(void); + void (*flush)(ErlDrvData drv_data); + void (*output)(ErlDrvData drv_data, char *buf, int len); + void (*outputv)(ErlDrvData drv_data, ErlIOVec *ev); /* Might be NULL */ + int (*control)(ErlDrvData drv_data, unsigned int command, char *buf, + int len, char **rbuf, int rlen); /* Might be NULL */ + int (*call)(ErlDrvData drv_data, unsigned int command, char *buf, + int len, char **rbuf, int rlen, unsigned int *flags); /* Might be NULL */ + void (*event)(ErlDrvData drv_data, ErlDrvEvent event, + ErlDrvEventData event_data); + void (*ready_input)(ErlDrvData drv_data, ErlDrvEvent event); + void (*ready_output)(ErlDrvData drv_data, ErlDrvEvent event); + void (*timeout)(ErlDrvData drv_data); + void (*ready_async)(ErlDrvData drv_data, ErlDrvThreadData thread_data); /* Might be NULL */ + void (*process_exit)(ErlDrvData drv_data, ErlDrvMonitor *monitor); + void (*stop_select)(ErlDrvEvent event, void*); /* Might be NULL */ +}; + +extern erts_driver_t *driver_list; +extern erts_smp_mtx_t erts_driver_list_lock; + +extern void erts_ddll_init(void); +extern void erts_ddll_lock_driver(DE_Handle *dh, char *name); + +/* These are for bookkeeping */ +extern void erts_ddll_increment_port_count(DE_Handle *dh); +extern void erts_ddll_decrement_port_count(DE_Handle *dh); + +/* These makes things happen, drivers may be scheduled for unload etc */ +extern void erts_ddll_reference_driver(DE_Handle *dh); +extern void erts_ddll_reference_referenced_driver(DE_Handle *dh); +extern void erts_ddll_dereference_driver(DE_Handle *dh); + +extern char *erts_ddll_error(int code); +extern void erts_ddll_proc_dead(Process *p, ErtsProcLocks plocks); +extern int erts_ddll_driver_ok(DE_Handle *dh); +extern void erts_ddll_remove_monitor(Process *p, + Eterm ref, + ErtsProcLocks plocks); +extern Eterm erts_ddll_monitor_driver(Process *p, + Eterm description, + ErtsProcLocks plocks); +/* + * Max no. of drivers (linked in and dynamically loaded). Each table + * entry uses 4 bytes. + */ +#define DRIVER_TAB_SIZE 32 + +/* +** Just like the driver binary but with initial flags +** Note that the two structures Binary and ErlDrvBinary HAVE to +** be equal except for extra fields in the beginning of the struct. +** ErlDrvBinary is defined in erl_driver.h. +** When driver_alloc_binary is called, a Binary is allocated, but +** the pointer returned is to the address of the first element that +** also occurs in the ErlDrvBinary struct (driver.*binary takes care if this). +** The driver need never know about additions to the internal Binary of the +** emulator. One should however NEVER be sloppy when mixing ErlDrvBinary +** and Binary, the macros below can convert one type to the other, as they both +** in reality are equal. +*/ +typedef struct binary { + Uint flags; + erts_refc_t refc; +#ifdef ARCH_32 + Uint32 align__; /* *DO NOT USE* only for alignment. */ +#endif + /* Add fields BEFORE this, otherwise the drivers crash */ + long orig_size; + char orig_bytes[1]; /* to be continued */ +} Binary; + +/* + * 'Binary' alignment: + * Address of orig_bytes[0] of a Binary should always be 8-byte aligned. + * It is assumed that the flags, refc, and orig_size fields are 4 bytes on + * 32-bits architectures and 8 bytes on 64-bits architectures. + */ + +/* + * "magic" binary. + */ +typedef struct { + void (*destructor)(Binary *); + char magic_bin_data[1]; +} ErtsBinaryMagicPart; + +#define ERTS_MAGIC_BIN_DESTRUCTOR(BP) \ + (((ErtsBinaryMagicPart *) (BP)->orig_bytes)->destructor) +#define ERTS_MAGIC_BIN_DATA(BP) \ + ((void *) (((ErtsBinaryMagicPart *) (BP)->orig_bytes)->magic_bin_data)) +#define ERTS_MAGIC_BIN_DATA_SIZE(BP) \ + ((BP)->orig_size - (sizeof(ErtsBinaryMagicPart) - 1)) + +#define Binary2ErlDrvBinary(B) ((ErlDrvBinary *) (&((B)->orig_size))) +#define ErlDrvBinary2Binary(D) ((Binary *) \ + (((char *) (D)) - \ + ((char *) &(((Binary *) 0)->orig_size)))) + +/* A "magic" binary flag */ +#define BIN_FLAG_MAGIC 1 +#define BIN_FLAG_USR1 2 /* Reserved for use by different modules too mark */ +#define BIN_FLAG_USR2 4 /* certain binaries as special (used by ets) */ +#define BIN_FLAG_DRV 8 + +/* + * This structure represents one type of a binary in a process. + */ + +typedef struct proc_bin { + Eterm thing_word; /* Subtag REFC_BINARY_SUBTAG. */ + Uint size; /* Binary size in bytes. */ + struct proc_bin *next; /* Pointer to next ProcBin. */ + Binary *val; /* Pointer to Binary structure. */ + byte *bytes; /* Pointer to the actual data bytes. */ + Uint flags; /* Flag word. */ +} ProcBin; + +#define PB_IS_WRITABLE 1 /* Writable (only one reference to ProcBin) */ +#define PB_ACTIVE_WRITER 2 /* There is an active writer */ + +/* + * ProcBin size in Eterm words. + */ +#define PROC_BIN_SIZE (sizeof(ProcBin)/sizeof(Eterm)) + +ERTS_GLB_INLINE Eterm erts_mk_magic_binary_term(Eterm **hpp, + ErlOffHeap *ohp, + Binary *mbp); + +#if ERTS_GLB_INLINE_INCL_FUNC_DEF + +ERTS_GLB_INLINE Eterm +erts_mk_magic_binary_term(Eterm **hpp, ErlOffHeap *ohp, Binary *mbp) +{ + ProcBin *pb = (ProcBin *) *hpp; + *hpp += PROC_BIN_SIZE; + + ASSERT(mbp->flags & BIN_FLAG_MAGIC); + + pb->thing_word = HEADER_PROC_BIN; + pb->size = 0; + pb->next = ohp->mso; + ohp->mso = pb; + pb->val = mbp; + pb->bytes = (byte *) mbp->orig_bytes; + pb->flags = 0; + + erts_refc_inc(&mbp->refc, 1); + + return make_binary(pb); +} + +#endif + +#define ERTS_TERM_IS_MAGIC_BINARY(T) \ + (is_binary((T)) \ + && (thing_subtag(*binary_val((T))) == REFC_BINARY_SUBTAG) \ + && (((ProcBin *) binary_val((T)))->val->flags & BIN_FLAG_MAGIC)) + +/* arrays that get malloced at startup */ +extern Port* erts_port; +extern erts_smp_atomic_t erts_ports_alive; + +extern Uint erts_max_ports; +extern Uint erts_port_tab_index_mask; +extern erts_smp_atomic_t erts_ports_snapshot; +extern erts_smp_atomic_t erts_dead_ports_ptr; + +ERTS_GLB_INLINE void erts_may_save_closed_port(Port *prt); + +#if ERTS_GLB_INLINE_INCL_FUNC_DEF + +ERTS_GLB_INLINE void erts_may_save_closed_port(Port *prt) +{ + ERTS_SMP_LC_ASSERT(erts_smp_lc_spinlock_is_locked(&prt->state_lck)); + if (prt->snapshot != erts_smp_atomic_read(&erts_ports_snapshot)) { + /* Dead ports are added from the end of the snapshot buffer */ + Eterm* tombstone = (Eterm*) erts_smp_atomic_addtest(&erts_dead_ports_ptr, + -(long)sizeof(Eterm)); + ASSERT(tombstone+1 != NULL); + ASSERT(prt->snapshot == (Uint32) erts_smp_atomic_read(&erts_ports_snapshot) - 1); + *tombstone = prt->id; + } + /*else no ongoing snapshot or port was already included or created after snapshot */ +} + +#endif + +/* controls warning mapping in error_logger */ + +extern Eterm node_cookie; +extern erts_smp_atomic_t erts_bytes_out; /* no bytes written out */ +extern erts_smp_atomic_t erts_bytes_in; /* no bytes sent into the system */ +extern Uint display_items; /* no of items to display in traces etc */ +extern Uint display_loads; /* print info about loaded modules */ + +extern int erts_backtrace_depth; +extern erts_smp_atomic_t erts_max_gen_gcs; + +extern int erts_disable_tolerant_timeofday; + +#ifdef HYBRID + +/* Message Area heap pointers */ +extern Eterm *global_heap; /* Heap start */ +extern Eterm *global_hend; /* Heap end */ +extern Eterm *global_htop; /* Heap top (heap pointer) */ +extern Eterm *global_saved_htop; /* Saved heap top (heap pointer) */ +extern Uint global_heap_sz; /* Heap size, in words */ +extern Eterm *global_old_heap; /* Old generation */ +extern Eterm *global_old_hend; +extern ErlOffHeap erts_global_offheap; /* Global MSO (OffHeap) list */ + +extern Uint16 global_gen_gcs; +extern Uint16 global_max_gen_gcs; +extern Uint global_gc_flags; + +#ifdef INCREMENTAL +#define ACTIVATE(p) +#define DEACTIVATE(p) +#define IS_ACTIVE(p) 1 + +#define INC_ACTIVATE(p) do { \ + if ((p)->active) { \ + if ((p)->active_next != NULL) { \ + (p)->active_next->active_prev = (p)->active_prev; \ + if ((p)->active_prev) { \ + (p)->active_prev->active_next = (p)->active_next; \ + } else { \ + inc_active_proc = (p)->active_next; \ + } \ + inc_active_last->active_next = (p); \ + (p)->active_next = NULL; \ + (p)->active_prev = inc_active_last; \ + inc_active_last = (p); \ + } \ + } else { \ + (p)->active_next = NULL; \ + (p)->active_prev = inc_active_last; \ + if (inc_active_last) { \ + inc_active_last->active_next = (p); \ + } else { \ + inc_active_proc = (p); \ + } \ + inc_active_last = (p); \ + (p)->active = 1; \ + } \ +} while(0); + +#define INC_DEACTIVATE(p) do { \ + ASSERT((p)->active == 1); \ + if ((p)->active_next == NULL) { \ + inc_active_last = (p)->active_prev; \ + } else { \ + (p)->active_next->active_prev = (p)->active_prev; \ + } \ + if ((p)->active_prev == NULL) { \ + inc_active_proc = (p)->active_next; \ + } else { \ + (p)->active_prev->active_next = (p)->active_next; \ + } \ + (p)->active = 0; \ +} while(0); + +#define INC_IS_ACTIVE(p) ((p)->active != 0) + +#else +extern Eterm *global_old_htop; +extern Eterm *global_high_water; +#define ACTIVATE(p) (p)->active = 1; +#define DEACTIVATE(p) (p)->active = 0; +#define IS_ACTIVE(p) ((p)->active != 0) +#define INC_ACTIVATE(p) +#define INC_IS_ACTIVE(p) 1 +#endif /* INCREMENTAL */ + +#else +# define ACTIVATE(p) +# define DEACTIVATE(p) +# define IS_ACTIVE(p) 1 +# define INC_ACTIVATE(p) +#endif /* HYBRID */ + +#ifdef HYBRID +extern Uint global_heap_min_sz; +#endif + +extern int bif_reductions; /* reductions + fcalls (when doing call_bif) */ +extern int stackdump_on_exit; + +/* + * Here is an implementation of a lightweiht stack. + * + * Use it like this: + * + * DECLARE_ESTACK(Stack) (At the start of a block) + * ... + * ESTACK_PUSH(Stack, Term) + * ... + * if (ESTACK_ISEMPTY(Stack)) { + * Stack is empty + * } else { + * Term = ESTACK_POP(Stack); + * Process popped Term here + * } + * ... + * DESTROY_ESTACK(Stack) + */ + + +void erl_grow_stack(Eterm** start, Eterm** sp, Eterm** end); +#define ESTK_CONCAT(a,b) a##b +#define ESTK_SUBSCRIPT(s,i) *((Eterm *)((byte *)ESTK_CONCAT(s,_start) + (i))) +#define DEF_ESTACK_SIZE (16) + +#define DECLARE_ESTACK(s) \ + Eterm ESTK_CONCAT(s,_default_stack)[DEF_ESTACK_SIZE]; \ + Eterm* ESTK_CONCAT(s,_start) = ESTK_CONCAT(s,_default_stack); \ + Eterm* ESTK_CONCAT(s,_sp) = ESTK_CONCAT(s,_start); \ + Eterm* ESTK_CONCAT(s,_end) = ESTK_CONCAT(s,_start) + DEF_ESTACK_SIZE + +#define DESTROY_ESTACK(s) \ +do { \ + if (ESTK_CONCAT(s,_start) != ESTK_CONCAT(s,_default_stack)) { \ + erts_free(ERTS_ALC_T_ESTACK, ESTK_CONCAT(s,_start)); \ + } \ +} while(0) + +#define ESTACK_PUSH(s, x) \ +do { \ + if (ESTK_CONCAT(s,_sp) == ESTK_CONCAT(s,_end)) { \ + erl_grow_stack(&ESTK_CONCAT(s,_start), &ESTK_CONCAT(s,_sp), \ + &ESTK_CONCAT(s,_end)); \ + } \ + *ESTK_CONCAT(s,_sp)++ = (x); \ +} while(0) + +#define ESTACK_PUSH2(s, x, y) \ +do { \ + if (ESTK_CONCAT(s,_sp) > ESTK_CONCAT(s,_end) - 2) { \ + erl_grow_stack(&ESTK_CONCAT(s,_start), &ESTK_CONCAT(s,_sp), \ + &ESTK_CONCAT(s,_end)); \ + } \ + *ESTK_CONCAT(s,_sp)++ = (x); \ + *ESTK_CONCAT(s,_sp)++ = (y); \ +} while(0) + +#define ESTACK_PUSH3(s, x, y, z) \ +do { \ + if (ESTK_CONCAT(s,_sp) > ESTK_CONCAT(s,_end) - 3) { \ + erl_grow_stack(&ESTK_CONCAT(s,_start), &ESTK_CONCAT(s,_sp), \ + &ESTK_CONCAT(s,_end)); \ + } \ + *ESTK_CONCAT(s,_sp)++ = (x); \ + *ESTK_CONCAT(s,_sp)++ = (y); \ + *ESTK_CONCAT(s,_sp)++ = (z); \ +} while(0) + +#define ESTACK_COUNT(s) (ESTK_CONCAT(s,_sp) - ESTK_CONCAT(s,_start)) + +#define ESTACK_ISEMPTY(s) (ESTK_CONCAT(s,_sp) == ESTK_CONCAT(s,_start)) +#define ESTACK_POP(s) (*(--ESTK_CONCAT(s,_sp))) + + +/* port status flags */ + +#define ERTS_PORT_SFLG_CONNECTED ((Uint32) (1 << 0)) +/* Port have begun exiting */ +#define ERTS_PORT_SFLG_EXITING ((Uint32) (1 << 1)) +/* Distribution port */ +#define ERTS_PORT_SFLG_DISTRIBUTION ((Uint32) (1 << 2)) +#define ERTS_PORT_SFLG_BINARY_IO ((Uint32) (1 << 3)) +#define ERTS_PORT_SFLG_SOFT_EOF ((Uint32) (1 << 4)) +/* Flow control */ +#define ERTS_PORT_SFLG_PORT_BUSY ((Uint32) (1 << 5)) +/* Port is closing (no i/o accepted) */ +#define ERTS_PORT_SFLG_CLOSING ((Uint32) (1 << 6)) +/* Send a closed message when terminating */ +#define ERTS_PORT_SFLG_SEND_CLOSED ((Uint32) (1 << 7)) +/* Line orinted io on port */ +#define ERTS_PORT_SFLG_LINEBUF_IO ((Uint32) (1 << 8)) +/* Immortal port (only certain system ports) */ +#define ERTS_PORT_SFLG_IMMORTAL ((Uint32) (1 << 9)) +#define ERTS_PORT_SFLG_FREE ((Uint32) (1 << 10)) +#define ERTS_PORT_SFLG_FREE_SCHEDULED ((Uint32) (1 << 11)) +#define ERTS_PORT_SFLG_INITIALIZING ((Uint32) (1 << 12)) +/* Port uses port specific locking (opposed to driver specific locking) */ +#define ERTS_PORT_SFLG_PORT_SPECIFIC_LOCK ((Uint32) (1 << 13)) +#define ERTS_PORT_SFLG_INVALID ((Uint32) (1 << 14)) +#ifdef DEBUG +/* Only debug: make sure all flags aren't cleared unintentionally */ +#define ERTS_PORT_SFLG_PORT_DEBUG ((Uint32) (1 << 31)) +#endif + +/* Combinations of port status flags */ +#define ERTS_PORT_SFLGS_DEAD \ + (ERTS_PORT_SFLG_FREE \ + | ERTS_PORT_SFLG_FREE_SCHEDULED \ + | ERTS_PORT_SFLG_INITIALIZING) +#define ERTS_PORT_SFLGS_INVALID_DRIVER_LOOKUP \ + (ERTS_PORT_SFLGS_DEAD | ERTS_PORT_SFLG_INVALID) +#define ERTS_PORT_SFLGS_INVALID_LOOKUP \ + (ERTS_PORT_SFLGS_INVALID_DRIVER_LOOKUP \ + | ERTS_PORT_SFLG_CLOSING) +#define ERTS_PORT_SFLGS_INVALID_TRACER_LOOKUP \ + (ERTS_PORT_SFLGS_INVALID_LOOKUP \ + | ERTS_PORT_SFLG_PORT_BUSY \ + | ERTS_PORT_SFLG_DISTRIBUTION) + +/* binary.c */ + +void erts_emasculate_writable_binary(ProcBin* pb); +Eterm erts_new_heap_binary(Process *p, byte *buf, int len, byte** datap); +Eterm erts_new_mso_binary(Process*, byte*, int); +Eterm new_binary(Process*, byte*, int); +Eterm erts_realloc_binary(Eterm bin, size_t size); +void erts_cleanup_mso(ProcBin* pb); + +/* erl_bif_info.c */ + +void erts_bif_info_init(void); + +/* bif.c */ +Eterm erts_make_ref(Process *); +Eterm erts_make_ref_in_buffer(Eterm buffer[REF_THING_SIZE]); +void erts_queue_monitor_message(Process *, + ErtsProcLocks*, + Eterm, + Eterm, + Eterm, + Eterm); +void erts_init_bif(void); + +/* erl_bif_port.c */ + +/* erl_bif_trace.c */ +void erts_system_monitor_clear(Process *c_p); +void erts_system_profile_clear(Process *c_p); + +/* beam_load.c */ +int erts_load_module(Process *c_p, ErtsProcLocks c_p_locks, + Eterm group_leader, Eterm* mod, byte* code, int size); +void init_load(void); +Eterm* find_function_from_pc(Eterm* pc); +Eterm erts_module_info_0(Process* p, Eterm module); +Eterm erts_module_info_1(Process* p, Eterm module, Eterm what); +Eterm erts_make_stub_module(Process* p, Eterm Mod, Eterm Beam, Eterm Info); + +/* break.c */ +void init_break_handler(void); +void erts_set_ignore_break(void); +void erts_replace_intr(void); +void process_info(int, void *); +void print_process_info(int, void *, Process*); +void info(int, void *); +void loaded(int, void *); + +/* config.c */ + +__decl_noreturn void __noreturn erl_exit(int n, char*, ...); +__decl_noreturn void __noreturn erl_exit0(char *, int, int n, char*, ...); +void erl_error(char*, va_list); + +#define ERL_EXIT0(n,f) erl_exit0(__FILE__, __LINE__, n, f) +#define ERL_EXIT1(n,f,a) erl_exit0(__FILE__, __LINE__, n, f, a) +#define ERL_EXIT2(n,f,a,b) erl_exit0(__FILE__, __LINE__, n, f, a, b) +#define ERL_EXIT3(n,f,a,b,c) erl_exit0(__FILE__, __LINE__, n, f, a, b, c) + +/* copy.c */ +void init_copy(void); +Eterm copy_object(Eterm, Process*); +Uint size_object(Eterm); +Eterm copy_struct(Eterm, Uint, Eterm**, ErlOffHeap*); +Eterm copy_shallow(Eterm*, Uint, Eterm**, ErlOffHeap*); + +#ifdef HYBRID +#define RRMA_DEFAULT_SIZE 256 +#define RRMA_STORE(p,ptr,src) do { \ + ASSERT((p)->rrma != NULL); \ + ASSERT((p)->rrsrc != NULL); \ + (p)->rrma[(p)->nrr] = (ptr); \ + (p)->rrsrc[(p)->nrr++] = (src); \ + if ((p)->nrr == (p)->rrsz) \ + { \ + (p)->rrsz *= 2; \ + (p)->rrma = (Eterm *) erts_realloc(ERTS_ALC_T_ROOTSET, \ + (void*)(p)->rrma, \ + sizeof(Eterm) * (p)->rrsz); \ + (p)->rrsrc = (Eterm **) erts_realloc(ERTS_ALC_T_ROOTSET, \ + (void*)(p)->rrsrc, \ + sizeof(Eterm) * (p)->rrsz); \ + } \ +} while(0) + +/* Note that RRMA_REMOVE decreases the given index after deletion. + * This is done so that a loop with an increasing index can call + * remove without having to decrease the index to see the element + * placed in the hole after the deleted element. + */ +#define RRMA_REMOVE(p,index) do { \ + p->rrsrc[index] = p->rrsrc[--p->nrr]; \ + p->rrma[index--] = p->rrma[p->nrr]; \ + } while(0); + + +/* The MessageArea STACKs are used while copying messages to the + * message area. + */ +#define MA_STACK_EXTERNAL_DECLARE(type,_s_) \ + typedef type ma_##_s_##_type; \ + extern ma_##_s_##_type *ma_##_s_##_stack; \ + extern Uint ma_##_s_##_top; \ + extern Uint ma_##_s_##_size; + +#define MA_STACK_DECLARE(_s_) \ + ma_##_s_##_type *ma_##_s_##_stack; Uint ma_##_s_##_top; Uint ma_##_s_##_size; + +#define MA_STACK_ALLOC(_s_) do { \ + ma_##_s_##_top = 0; \ + ma_##_s_##_size = 512; \ + ma_##_s_##_stack = (ma_##_s_##_type*)erts_alloc(ERTS_ALC_T_OBJECT_STACK, \ + sizeof(ma_##_s_##_type) * ma_##_s_##_size); \ +} while(0) + + +#define MA_STACK_PUSH(_s_,val) do { \ + ma_##_s_##_stack[ma_##_s_##_top++] = (val); \ + if (ma_##_s_##_top == ma_##_s_##_size) \ + { \ + ma_##_s_##_size *= 2; \ + ma_##_s_##_stack = \ + (ma_##_s_##_type*) erts_realloc(ERTS_ALC_T_OBJECT_STACK, \ + (void*)ma_##_s_##_stack, \ + sizeof(ma_##_s_##_type) * ma_##_s_##_size); \ + } \ +} while(0) + +#define MA_STACK_POP(_s_) (ma_##_s_##_top != 0 ? ma_##_s_##_stack[--ma_##_s_##_top] : 0) +#define MA_STACK_TOP(_s_) (ma_##_s_##_stack[ma_##_s_##_top - 1]) +#define MA_STACK_UPDATE(_s_,offset,value) \ + *(ma_##_s_##_stack[ma_##_s_##_top - 1] + (offset)) = (value) +#define MA_STACK_SIZE(_s_) (ma_##_s_##_top) +#define MA_STACK_ELM(_s_,i) ma_##_s_##_stack[i] + +MA_STACK_EXTERNAL_DECLARE(Eterm,src); +MA_STACK_EXTERNAL_DECLARE(Eterm*,dst); +MA_STACK_EXTERNAL_DECLARE(Uint,offset); + + +#ifdef INCREMENTAL +extern Eterm *ma_pending_stack; +extern Uint ma_pending_top; +extern Uint ma_pending_size; + +#define NO_COPY(obj) (IS_CONST(obj) || \ + (((ptr_val(obj) >= global_heap) && \ + (ptr_val(obj) < global_htop)) || \ + ((ptr_val(obj) >= inc_fromspc) && \ + (ptr_val(obj) < inc_fromend)) || \ + ((ptr_val(obj) >= global_old_heap) && \ + (ptr_val(obj) < global_old_hend)))) + +#else + +#define NO_COPY(obj) (IS_CONST(obj) || \ + (((ptr_val(obj) >= global_heap) && \ + (ptr_val(obj) < global_htop)) || \ + ((ptr_val(obj) >= global_old_heap) && \ + (ptr_val(obj) < global_old_hend)))) + +#endif /* INCREMENTAL */ + +#define LAZY_COPY(from,obj) do { \ + if (!NO_COPY(obj)) { \ + BM_LAZY_COPY_START; \ + BM_COUNT(messages_copied); \ + obj = copy_struct_lazy(from,obj,0); \ + BM_LAZY_COPY_STOP; \ + } \ +} while(0) + +Eterm copy_struct_lazy(Process*, Eterm, Uint); + +#endif /* HYBRID */ + +/* Utilities */ +extern void erts_delete_nodes_monitors(Process *, ErtsProcLocks); +extern Eterm erts_monitor_nodes(Process *, Eterm, Eterm); +extern Eterm erts_processes_monitoring_nodes(Process *); +extern int erts_do_net_exits(DistEntry*, Eterm); +extern int distribution_info(int, void *); +extern int is_node_name_atom(Eterm a); + +extern int erts_net_message(Port *, DistEntry *, byte *, int, byte *, int); + +extern void init_dist(void); +extern int stop_dist(void); + +void erl_progressf(char* format, ...); + +#ifdef MESS_DEBUG +void print_pass_through(int, byte*, int); +#endif + +/* beam_emu.c */ +int catchlevel(Process*); +void init_emulator(_VOID_); +void process_main(void); +Eterm build_stacktrace(Process* c_p, Eterm exc); +Eterm expand_error_value(Process* c_p, Uint freason, Eterm Value); + +/* erl_init.c */ + +typedef struct { + Eterm delay_time; + int context_reds; + int input_reds; +} ErtsModifiedTimings; + +extern Export *erts_delay_trap; +extern int erts_modified_timing_level; +extern ErtsModifiedTimings erts_modified_timings[]; +#define ERTS_USE_MODIFIED_TIMING() \ + (erts_modified_timing_level >= 0) +#define ERTS_MODIFIED_TIMING_DELAY \ + (erts_modified_timings[erts_modified_timing_level].delay_time) +#define ERTS_MODIFIED_TIMING_CONTEXT_REDS \ + (erts_modified_timings[erts_modified_timing_level].context_reds) +#define ERTS_MODIFIED_TIMING_INPUT_REDS \ + (erts_modified_timings[erts_modified_timing_level].input_reds) + +extern Eterm erts_error_logger_warnings; +extern int erts_initialized; +extern int erts_compat_rel; +extern int erts_use_sender_punish; +void erts_short_init(void); +void erl_start(int, char**); +void erts_usage(void); +Eterm erts_preloaded(Process* p); +/* erl_md5.c */ + +typedef struct { + Uint32 state[4]; /* state (ABCD) */ + Uint32 count[2]; /* number of bits, modulo 2^64 (lsb first) */ + unsigned char buffer[64]; /* input buffer */ +} MD5_CTX; + +void MD5Init(MD5_CTX *); +void MD5Update(MD5_CTX *, unsigned char *, unsigned int); +void MD5Final(unsigned char [16], MD5_CTX *); + +/* ggc.c */ + + +typedef struct { + Uint garbage_collections; + Uint reclaimed; +} ErtsGCInfo; + +void erts_gc_info(ErtsGCInfo *gcip); +void erts_init_gc(void); +int erts_garbage_collect(Process*, int, Eterm*, int); +void erts_garbage_collect_hibernate(Process* p); +Eterm erts_gc_after_bif_call(Process* p, Eterm result, Eterm* regs, Uint arity); +void erts_garbage_collect_literals(Process* p, Eterm* literals, Uint lit_size); +Uint erts_next_heap_size(Uint, Uint); +Eterm erts_heap_sizes(Process* p); + +void erts_offset_off_heap(ErlOffHeap *, Sint, Eterm*, Eterm*); +void erts_offset_heap_ptr(Eterm*, Uint, Sint, Eterm*, Eterm*); +void erts_offset_heap(Eterm*, Uint, Sint, Eterm*, Eterm*); + +#ifdef HYBRID +int erts_global_garbage_collect(Process*, int, Eterm*, int); +#endif + +/* io.c */ + +struct erl_drv_port_data_lock { + erts_mtx_t mtx; + erts_atomic_t refc; +}; + +typedef struct { + char *name; + char *driver_name; +} ErtsPortNames; + +#define ERTS_SPAWN_DRIVER 1 +#define ERTS_SPAWN_EXECUTABLE 2 +#define ERTS_SPAWN_ANY (ERTS_SPAWN_DRIVER | ERTS_SPAWN_EXECUTABLE) + +int erts_add_driver_entry(ErlDrvEntry *drv, DE_Handle *handle, int driver_list_locked); +void erts_destroy_driver(erts_driver_t *drv); +void erts_wake_process_later(Port*, Process*); +int erts_open_driver(erts_driver_t*, Eterm, char*, SysDriverOpts*, int *); +int erts_is_port_ioq_empty(Port *); +void erts_terminate_port(Port *); +void close_port(Eterm); +void init_io(void); +void cleanup_io(void); +void erts_do_exit_port(Port *, Eterm, Eterm); +void erts_port_command(Process *, Eterm, Port *, Eterm); +Eterm erts_port_control(Process*, Port*, Uint, Eterm); +int erts_write_to_port(Eterm caller_id, Port *p, Eterm list); +void print_port_info(int, void *, int); +void erts_raw_port_command(Port*, byte*, Uint); +void driver_report_exit(int, int); +LineBuf* allocate_linebuf(int); +int async_ready(Port *, void*); +Sint erts_test_next_port(int, Uint); +ErtsPortNames *erts_get_port_names(Eterm); +void erts_free_port_names(ErtsPortNames *); +Uint erts_port_ioq_size(Port *pp); +void erts_stale_drv_select(Eterm, ErlDrvEvent, int, int); +void erts_port_cleanup(Port *); +void erts_fire_port_monitor(Port *prt, Eterm ref); +#ifdef ERTS_SMP +void erts_smp_xports_unlock(Port *); +#endif + +#if defined(ERTS_SMP) && defined(ERTS_ENABLE_LOCK_CHECK) +int erts_lc_is_port_locked(Port *); +#endif + +ERTS_GLB_INLINE void erts_smp_port_state_lock(Port*); +ERTS_GLB_INLINE void erts_smp_port_state_unlock(Port*); + +ERTS_GLB_INLINE int erts_smp_port_trylock(Port *prt); +ERTS_GLB_INLINE void erts_smp_port_lock(Port *prt); +ERTS_GLB_INLINE void erts_smp_port_unlock(Port *prt); + +#if ERTS_GLB_INLINE_INCL_FUNC_DEF + +ERTS_GLB_INLINE void +erts_smp_port_state_lock(Port* prt) +{ +#ifdef ERTS_SMP + erts_smp_spin_lock(&prt->state_lck); +#endif +} + +ERTS_GLB_INLINE void +erts_smp_port_state_unlock(Port *prt) +{ +#ifdef ERTS_SMP + erts_smp_spin_unlock(&prt->state_lck); +#endif +} + + +ERTS_GLB_INLINE int +erts_smp_port_trylock(Port *prt) +{ +#ifdef ERTS_SMP + int res; + + ASSERT(erts_smp_atomic_read(&prt->refc) > 0); + erts_smp_atomic_inc(&prt->refc); + res = erts_smp_mtx_trylock(prt->lock); + if (res == EBUSY) { + erts_smp_atomic_dec(&prt->refc); + } + + return res; +#else /* !ERTS_SMP */ + return 0; +#endif +} + +ERTS_GLB_INLINE void +erts_smp_port_lock(Port *prt) +{ +#ifdef ERTS_SMP + ASSERT(erts_smp_atomic_read(&prt->refc) > 0); + erts_smp_atomic_inc(&prt->refc); + erts_smp_mtx_lock(prt->lock); +#endif +} + +ERTS_GLB_INLINE void +erts_smp_port_unlock(Port *prt) +{ +#ifdef ERTS_SMP + long refc; + refc = erts_smp_atomic_dectest(&prt->refc); + ASSERT(refc >= 0); + if (refc == 0) + erts_port_cleanup(prt); + else + erts_smp_mtx_unlock(prt->lock); +#endif +} + +#endif /* #if ERTS_GLB_INLINE_INCL_FUNC_DEF */ + + +#define ERTS_INVALID_PORT_OPT(PP, ID, FLGS) \ + (!(PP) || ((PP)->status & (FLGS)) || (PP)->id != (ID)) + +/* port lookup */ + +#define INVALID_PORT(PP, ID) \ + ERTS_INVALID_PORT_OPT((PP), (ID), ERTS_PORT_SFLGS_INVALID_LOOKUP) + +/* Invalidate trace port if anything suspicious, for instance + * that the port is a distribution port or it is busy. + */ +#define INVALID_TRACER_PORT(PP, ID) \ + ERTS_INVALID_PORT_OPT((PP), (ID), ERTS_PORT_SFLGS_INVALID_TRACER_LOOKUP) + +#define ERTS_PORT_SCHED_ID(P, ID) \ + ((Uint) erts_prtsd_set((P), ERTS_PSD_SCHED_ID, (void *) (ID))) + +#ifdef ERTS_SMP +Port *erts_de2port(DistEntry *, Process *, ErtsProcLocks); +#endif + +#define erts_id2port(ID, P, PL) \ + erts_id2port_sflgs((ID), (P), (PL), ERTS_PORT_SFLGS_INVALID_LOOKUP) + +ERTS_GLB_INLINE Port*erts_id2port_sflgs(Eterm, Process *, ErtsProcLocks, Uint32); +ERTS_GLB_INLINE void erts_port_release(Port *); +ERTS_GLB_INLINE Port*erts_drvport2port(ErlDrvPort); +ERTS_GLB_INLINE Port*erts_drvportid2port(Eterm); +ERTS_GLB_INLINE Uint32 erts_portid2status(Eterm id); +ERTS_GLB_INLINE int erts_is_port_alive(Eterm id); +ERTS_GLB_INLINE int erts_is_valid_tracer_port(Eterm id); +ERTS_GLB_INLINE void erts_port_status_bandor_set(Port *, Uint32, Uint32); +ERTS_GLB_INLINE void erts_port_status_band_set(Port *, Uint32); +ERTS_GLB_INLINE void erts_port_status_bor_set(Port *, Uint32); +ERTS_GLB_INLINE void erts_port_status_set(Port *, Uint32); +ERTS_GLB_INLINE Uint32 erts_port_status_get(Port *); + +#if ERTS_GLB_INLINE_INCL_FUNC_DEF + +ERTS_GLB_INLINE Port* +erts_id2port_sflgs(Eterm id, Process *c_p, ErtsProcLocks c_p_locks, Uint32 sflgs) +{ +#ifdef ERTS_SMP + int no_proc_locks = !c_p || !c_p_locks; +#endif + Port *prt; + + if (is_not_internal_port(id)) + return NULL; + + prt = &erts_port[internal_port_index(id)]; + + erts_smp_port_state_lock(prt); + if (ERTS_INVALID_PORT_OPT(prt, id, sflgs)) { + erts_smp_port_state_unlock(prt); + prt = NULL; + } +#ifdef ERTS_SMP + else { + erts_smp_atomic_inc(&prt->refc); + erts_smp_port_state_unlock(prt); + + if (no_proc_locks) + erts_smp_mtx_lock(prt->lock); + else if (erts_smp_mtx_trylock(prt->lock) == EBUSY) { + /* Unlock process locks, and acquire locks in lock order... */ + erts_smp_proc_unlock(c_p, c_p_locks); + erts_smp_mtx_lock(prt->lock); + erts_smp_proc_lock(c_p, c_p_locks); + } + + /* The id may not have changed... */ + ERTS_SMP_LC_ASSERT(prt->id == id); + /* ... but status may have... */ + if (prt->status & sflgs) { + erts_smp_port_unlock(prt); /* Also decrements refc... */ + prt = NULL; + } + } +#endif + + return prt; +} + +ERTS_GLB_INLINE void +erts_port_release(Port *prt) +{ +#ifdef ERTS_SMP + erts_smp_port_unlock(prt); +#else + if (prt->status & ERTS_PORT_SFLGS_DEAD) + erts_port_cleanup(prt); +#endif +} + +ERTS_GLB_INLINE Port* +erts_drvport2port(ErlDrvPort drvport) +{ + int ix = (int) drvport; + if (ix < 0 || erts_max_ports <= ix) + return NULL; + if (erts_port[ix].status & ERTS_PORT_SFLGS_INVALID_DRIVER_LOOKUP) + return NULL; + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(&erts_port[ix])); + return &erts_port[ix]; +} + +ERTS_GLB_INLINE Port* +erts_drvportid2port(Eterm id) +{ + int ix; + if (is_not_internal_port(id)) + return NULL; + ix = (int) internal_port_index(id); + if (erts_max_ports <= ix) + return NULL; + if (erts_port[ix].status & ERTS_PORT_SFLGS_INVALID_DRIVER_LOOKUP) + return NULL; + if (erts_port[ix].id != id) + return NULL; + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(&erts_port[ix])); + return &erts_port[ix]; +} + +ERTS_GLB_INLINE Uint32 +erts_portid2status(Eterm id) +{ + if (is_not_internal_port(id)) + return ERTS_PORT_SFLG_INVALID; + else { + Uint32 status; + int ix = internal_port_index(id); + if (erts_max_ports <= ix) + return ERTS_PORT_SFLG_INVALID; + erts_smp_port_state_lock(&erts_port[ix]); + if (erts_port[ix].id == id) + status = erts_port[ix].status; + else + status = ERTS_PORT_SFLG_INVALID; + erts_smp_port_state_unlock(&erts_port[ix]); + return status; + } +} + +ERTS_GLB_INLINE int +erts_is_port_alive(Eterm id) +{ + return !(erts_portid2status(id) & (ERTS_PORT_SFLG_INVALID + | ERTS_PORT_SFLGS_DEAD)); +} + +ERTS_GLB_INLINE int +erts_is_valid_tracer_port(Eterm id) +{ + return !(erts_portid2status(id) & ERTS_PORT_SFLGS_INVALID_TRACER_LOOKUP); +} + +ERTS_GLB_INLINE void erts_port_status_bandor_set(Port *prt, + Uint32 band_status, + Uint32 bor_status) +{ + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(prt)); + erts_smp_port_state_lock(prt); + prt->status &= band_status; + prt->status |= bor_status; + erts_smp_port_state_unlock(prt); +} + +ERTS_GLB_INLINE void erts_port_status_band_set(Port *prt, Uint32 status) +{ + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(prt)); + erts_smp_port_state_lock(prt); + prt->status &= status; + erts_smp_port_state_unlock(prt); +} + +ERTS_GLB_INLINE void erts_port_status_bor_set(Port *prt, Uint32 status) +{ + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(prt)); + erts_smp_port_state_lock(prt); + prt->status |= status; + erts_smp_port_state_unlock(prt); +} + +ERTS_GLB_INLINE void erts_port_status_set(Port *prt, Uint32 status) +{ + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(prt)); + erts_smp_port_state_lock(prt); + prt->status = status; + erts_smp_port_state_unlock(prt); +} + +ERTS_GLB_INLINE Uint32 erts_port_status_get(Port *prt) +{ + Uint32 res; + erts_smp_port_state_lock(prt); + res = prt->status; + erts_smp_port_state_unlock(prt); + return res; +} +#endif /* #if ERTS_GLB_INLINE_INCL_FUNC_DEF */ + +/* erl_drv_thread.c */ +void erl_drv_thr_init(void); + +/* time.c */ + +ERTS_GLB_INLINE long do_time_read_and_reset(void); +#ifdef ERTS_TIMER_THREAD +ERTS_GLB_INLINE int next_time(void); +ERTS_GLB_INLINE void bump_timer(long); +#else +int next_time(void); +void bump_timer(long); +extern erts_smp_atomic_t do_time; /* set at clock interrupt */ +ERTS_GLB_INLINE void do_time_add(long); +#endif + +#if ERTS_GLB_INLINE_INCL_FUNC_DEF + +#ifdef ERTS_TIMER_THREAD +ERTS_GLB_INLINE long do_time_read_and_reset(void) { return 0; } +ERTS_GLB_INLINE int next_time(void) { return -1; } +ERTS_GLB_INLINE void bump_timer(long ignore) { } +#else +ERTS_GLB_INLINE long do_time_read_and_reset(void) +{ + return erts_smp_atomic_xchg(&do_time, 0L); +} +ERTS_GLB_INLINE void do_time_add(long elapsed) +{ + erts_smp_atomic_add(&do_time, elapsed); +} +#endif + +#endif /* #if ERTS_GLB_INLINE_INCL_FUNC_DEF */ + +void init_time(void); +void erl_set_timer(ErlTimer*, ErlTimeoutProc, ErlCancelProc, void*, Uint); +void erl_cancel_timer(ErlTimer*); +Uint time_left(ErlTimer *); + +Uint erts_timer_wheel_memory_size(void); + +#if (defined(HAVE_GETHRVTIME) || defined(HAVE_CLOCK_GETTIME)) +# ifndef HAVE_ERTS_NOW_CPU +# define HAVE_ERTS_NOW_CPU +# ifdef HAVE_GETHRVTIME +# define erts_start_now_cpu() sys_start_hrvtime() +# define erts_stop_now_cpu() sys_stop_hrvtime() +# endif +# endif +void erts_get_now_cpu(Uint* megasec, Uint* sec, Uint* microsec); +#endif + +void erts_get_timeval(SysTimeval *tv); +long erts_get_time(void); + +extern SysTimeval erts_first_emu_time; + +void erts_get_emu_time(SysTimeval *); + +ERTS_GLB_INLINE int erts_cmp_timeval(SysTimeval *t1p, SysTimeval *t2p); + +#if ERTS_GLB_INLINE_INCL_FUNC_DEF + +ERTS_GLB_INLINE int +erts_cmp_timeval(SysTimeval *t1p, SysTimeval *t2p) +{ + if (t1p->tv_sec == t2p->tv_sec) { + if (t1p->tv_usec < t2p->tv_usec) + return -1; + else if (t1p->tv_usec > t2p->tv_usec) + return 1; + return 0; + } + return t1p->tv_sec < t2p->tv_sec ? -1 : 1; +} + +#endif + +#ifdef DEBUG +void p_slpq(_VOID_); +#endif + +/* utils.c */ + +void erts_cleanup_offheap(ErlOffHeap *offheap); +void erts_cleanup_externals(ExternalThing *); + +Uint erts_fit_in_bits(Uint); +int list_length(Eterm); +Export* erts_find_function(Eterm, Eterm, unsigned int); +int erts_is_builtin(Eterm, Eterm, int); +Uint32 make_broken_hash(Eterm); +Uint32 block_hash(byte *, unsigned, Uint32); +Uint32 make_hash2(Eterm); +Uint32 make_hash(Eterm); + + +Eterm erts_bld_atom(Uint **hpp, Uint *szp, char *str); +Eterm erts_bld_uint(Uint **hpp, Uint *szp, Uint ui); +Eterm erts_bld_uint64(Uint **hpp, Uint *szp, Uint64 ui64); +Eterm erts_bld_sint64(Uint **hpp, Uint *szp, Sint64 si64); +Eterm erts_bld_cons(Uint **hpp, Uint *szp, Eterm car, Eterm cdr); +Eterm erts_bld_tuple(Uint **hpp, Uint *szp, Uint arity, ...); +Eterm erts_bld_tuplev(Uint **hpp, Uint *szp, Uint arity, Eterm terms[]); +Eterm erts_bld_string_n(Uint **hpp, Uint *szp, const char *str, Sint len); +#define erts_bld_string(hpp,szp,str) erts_bld_string_n(hpp,szp,str,strlen(str)) +Eterm erts_bld_list(Uint **hpp, Uint *szp, Sint length, Eterm terms[]); +Eterm erts_bld_2tup_list(Uint **hpp, Uint *szp, + Sint length, Eterm terms1[], Uint terms2[]); +Eterm +erts_bld_atom_uint_2tup_list(Uint **hpp, Uint *szp, + Sint length, Eterm atoms[], Uint uints[]); +Eterm +erts_bld_atom_2uint_3tup_list(Uint **hpp, Uint *szp, Sint length, + Eterm atoms[], Uint uints1[], Uint uints2[]); + +Eterm store_external_or_ref_in_proc_(Process *, Eterm); +Eterm store_external_or_ref_(Uint **, ExternalThing **, Eterm); + +#define NC_HEAP_SIZE(NC) \ + (ASSERT_EXPR(is_node_container((NC))), \ + IS_CONST((NC)) ? 0 : (thing_arityval(*boxed_val((NC))) + 1)) +#define STORE_NC(Hpp, ETpp, NC) \ + (ASSERT_EXPR(is_node_container((NC))), \ + IS_CONST((NC)) ? (NC) : store_external_or_ref_((Hpp), (ETpp), (NC))) +#define STORE_NC_IN_PROC(Pp, NC) \ + (ASSERT_EXPR(is_node_container((NC))), \ + IS_CONST((NC)) ? (NC) : store_external_or_ref_in_proc_((Pp), (NC))) + +void erts_init_utils(void); +void erts_init_utils_mem(void); + +erts_dsprintf_buf_t *erts_create_tmp_dsbuf(Uint); +void erts_destroy_tmp_dsbuf(erts_dsprintf_buf_t *); + +int eq(Eterm, Eterm); +#define EQ(x,y) (((x) == (y)) || (is_not_both_immed((x),(y)) && eq((x),(y)))) + +Sint cmp(Eterm, Eterm); +#define cmp_lt(a,b) (cmp((a),(b)) < 0) +#define cmp_le(a,b) (cmp((a),(b)) <= 0) +#define cmp_eq(a,b) (cmp((a),(b)) == 0) +#define cmp_ne(a,b) (cmp((a),(b)) != 0) +#define cmp_ge(a,b) (cmp((a),(b)) >= 0) +#define cmp_gt(a,b) (cmp((a),(b)) > 0) + +#define CMP_LT(a,b) ((a) != (b) && cmp_lt((a),(b))) +#define CMP_GE(a,b) ((a) == (b) || cmp_ge((a),(b))) +#define CMP_EQ(a,b) ((a) == (b) || cmp_eq((a),(b))) +#define CMP_NE(a,b) ((a) != (b) && cmp_ne((a),(b))) + +int term_to_Uint(Eterm term, Uint *up); + +#ifdef HAVE_ERTS_NOW_CPU +extern int erts_cpu_timestamp; +#endif +/* erl_bif_chksum.c */ +void erts_init_bif_chksum(void); +/* erl_bif_re.c */ +void erts_init_bif_re(void); +Sint erts_re_set_loop_limit(Sint limit); +/* erl_unicode.c */ +void erts_init_unicode(void); +Sint erts_unicode_set_loop_limit(Sint limit); +/* erl_trace.c */ +void erts_init_trace(void); +void erts_trace_check_exiting(Eterm exiting); +Eterm erts_set_system_seq_tracer(Process *c_p, + ErtsProcLocks c_p_locks, + Eterm new); +Eterm erts_get_system_seq_tracer(void); +void erts_change_default_tracing(int setflags, Uint *flagsp, Eterm *tracerp); +void erts_get_default_tracing(Uint *flagsp, Eterm *tracerp); +void erts_set_system_monitor(Eterm monitor); +Eterm erts_get_system_monitor(void); + +#ifdef ERTS_SMP +void erts_check_my_tracer_proc(Process *); +void erts_block_sys_msg_dispatcher(void); +void erts_release_sys_msg_dispatcher(void); +void erts_foreach_sys_msg_in_q(void (*func)(Eterm, + Eterm, + Eterm, + ErlHeapFragment *)); +void erts_queue_error_logger_message(Eterm, Eterm, ErlHeapFragment *); +#endif + +void erts_send_sys_msg_proc(Eterm, Eterm, Eterm, ErlHeapFragment *); +void trace_send(Process*, Eterm, Eterm); +void trace_receive(Process*, Eterm); +Uint32 erts_call_trace(Process *p, Eterm mfa[], Binary *match_spec, Eterm* args, + int local, Eterm *tracer_pid); +void erts_trace_return(Process* p, Eterm* fi, Eterm retval, Eterm *tracer_pid); +void erts_trace_exception(Process* p, Eterm mfa[], Eterm class, Eterm value, + Eterm *tracer); +void erts_trace_return_to(Process *p, Uint *pc); +void trace_sched(Process*, Eterm); +void trace_proc(Process*, Process*, Eterm, Eterm); +void trace_proc_spawn(Process*, Eterm pid, Eterm mod, Eterm func, Eterm args); +void save_calls(Process *p, Export *); +void trace_gc(Process *p, Eterm what); +/* port tracing */ +void trace_virtual_sched(Process*, Eterm); +void trace_sched_ports(Port *pp, Eterm); +void trace_sched_ports_where(Port *pp, Eterm, Eterm); +void trace_port(Port *, Eterm what, Eterm data); +void trace_port_open(Port *, Eterm calling_pid, Eterm drv_name); + +/* system_profile */ +void erts_set_system_profile(Eterm profile); +Eterm erts_get_system_profile(void); +void profile_scheduler(Eterm scheduler_id, Eterm); +void profile_scheduler_q(Eterm scheduler_id, Eterm state, Eterm no_schedulers, Uint Ms, Uint s, Uint us); +void profile_runnable_proc(Process* p, Eterm status); +void profile_runnable_port(Port* p, Eterm status); +void erts_system_profile_setup_active_schedulers(void); + +/* system_monitor */ +void monitor_long_gc(Process *p, Uint time); +void monitor_large_heap(Process *p); +void monitor_generic(Process *p, Eterm type, Eterm spec); +Uint erts_trace_flag2bit(Eterm flag); +int erts_trace_flags(Eterm List, + Uint *pMask, Eterm *pTracer, int *pCpuTimestamp); +Eterm erts_bif_trace(int bif_index, Process* p, + Eterm arg1, Eterm arg2, Eterm arg3, Uint *I); + +#ifdef ERTS_SMP +void erts_send_pending_trace_msgs(ErtsSchedulerData *esdp); +#define ERTS_SMP_CHK_PEND_TRACE_MSGS(ESDP) \ +do { \ + if ((ESDP)->pending_trace_msgs) \ + erts_send_pending_trace_msgs((ESDP)); \ +} while (0) +#else +#define ERTS_SMP_CHK_PEND_TRACE_MSGS(ESDP) +#endif + +void bin_write(int, void*, byte*, int); +int intlist_to_buf(Eterm, char*, int); /* most callers pass plain char*'s */ + +struct Sint_buf { +#ifdef ARCH_64 + char s[22]; +#else + char s[12]; +#endif +}; +char* Sint_to_buf(Sint, struct Sint_buf*); + +Eterm buf_to_intlist(Eterm**, char*, int, Eterm); /* most callers pass plain char*'s */ +int io_list_to_buf(Eterm, char*, int); +int io_list_to_buf2(Eterm, char*, int); +int io_list_len(Eterm); +int is_string(Eterm); +void erl_at_exit(FUNCTION(void,(*),(void*)), void*); +Eterm collect_memory(Process *); +void dump_memory_to_fd(int); +int dump_memory_data(const char *); + +Eterm erts_mixed_plus(Process* p, Eterm arg1, Eterm arg2); +Eterm erts_mixed_minus(Process* p, Eterm arg1, Eterm arg2); +Eterm erts_mixed_times(Process* p, Eterm arg1, Eterm arg2); +Eterm erts_mixed_div(Process* p, Eterm arg1, Eterm arg2); +Eterm erts_int_div(Process* p, Eterm arg1, Eterm arg2); +Eterm erts_int_rem(Process* p, Eterm arg1, Eterm arg2); +Eterm erts_band(Process* p, Eterm arg1, Eterm arg2); +Eterm erts_bor(Process* p, Eterm arg1, Eterm arg2); +Eterm erts_bxor(Process* p, Eterm arg1, Eterm arg2); +Eterm erts_bnot(Process* p, Eterm arg); + +Eterm erts_gc_mixed_plus(Process* p, Eterm* reg, Uint live); +Eterm erts_gc_mixed_minus(Process* p, Eterm* reg, Uint live); +Eterm erts_gc_mixed_times(Process* p, Eterm* reg, Uint live); +Eterm erts_gc_mixed_div(Process* p, Eterm* reg, Uint live); +Eterm erts_gc_int_div(Process* p, Eterm* reg, Uint live); +Eterm erts_gc_int_rem(Process* p, Eterm* reg, Uint live); +Eterm erts_gc_band(Process* p, Eterm* reg, Uint live); +Eterm erts_gc_bor(Process* p, Eterm* reg, Uint live); +Eterm erts_gc_bxor(Process* p, Eterm* reg, Uint live); +Eterm erts_gc_bnot(Process* p, Eterm* reg, Uint live); + +Eterm erts_gc_length_1(Process* p, Eterm* reg, Uint live); +Eterm erts_gc_size_1(Process* p, Eterm* reg, Uint live); +Eterm erts_gc_bit_size_1(Process* p, Eterm* reg, Uint live); +Eterm erts_gc_byte_size_1(Process* p, Eterm* reg, Uint live); +Eterm erts_gc_abs_1(Process* p, Eterm* reg, Uint live); +Eterm erts_gc_float_1(Process* p, Eterm* reg, Uint live); +Eterm erts_gc_round_1(Process* p, Eterm* reg, Uint live); +Eterm erts_gc_trunc_1(Process* p, Eterm* reg, Uint live); + +Uint erts_current_reductions(Process* current, Process *p); + +int erts_print_system_version(int to, void *arg, Process *c_p); + +/* + * Interface to erl_init + */ +void erl_init(void); +void erts_first_process(Eterm modname, void* code, unsigned size, int argc, char** argv); + +#define seq_trace_output(token, msg, type, receiver, process) \ +seq_trace_output_generic((token), (msg), (type), (receiver), (process), NIL) +#define seq_trace_output_exit(token, msg, type, receiver, exitfrom) \ +seq_trace_output_generic((token), (msg), (type), (receiver), NULL, (exitfrom)) +void seq_trace_output_generic(Eterm token, Eterm msg, Uint type, + Eterm receiver, Process *process, Eterm exitfrom); + +int seq_trace_update_send(Process *process); + +Eterm erts_seq_trace(Process *process, + Eterm atom_type, Eterm atom_true_or_false, + int build_result); + +struct trace_pattern_flags { + unsigned int breakpoint : 1; /* Set if any other is set */ + unsigned int local : 1; /* Local call trace breakpoint */ + unsigned int meta : 1; /* Metadata trace breakpoint */ + unsigned int call_count : 1; /* Fast call count breakpoint */ +}; +extern const struct trace_pattern_flags erts_trace_pattern_flags_off; +int erts_set_trace_pattern(Eterm* mfa, int specified, + Binary* match_prog_set, Binary *meta_match_prog_set, + int on, struct trace_pattern_flags, + Eterm meta_tracer_pid); +void +erts_get_default_trace_pattern(int *trace_pattern_is_on, + Binary **match_spec, + Binary **meta_match_spec, + struct trace_pattern_flags *trace_pattern_flags, + Eterm *meta_tracer_pid); +void erts_bif_trace_init(void); + +/* +** Call_trace uses this API for the parameter matching functions +*/ + struct erl_heap_fragment* saved_program_buf; + +#define MatchSetRef(MPSP) \ +do { \ + if ((MPSP) != NULL) { \ + erts_refc_inc(&(MPSP)->refc, 1); \ + } \ +} while (0) + +#define MatchSetUnref(MPSP) \ +do { \ + if (((MPSP) != NULL) && erts_refc_dectest(&(MPSP)->refc, 0) <= 0) { \ + erts_bin_free(MPSP); \ + } \ +} while(0) + +#define MatchSetGetSource(MPSP) erts_match_set_get_source(MPSP) + +extern Binary *erts_match_set_compile(Process *p, Eterm matchexpr); +Eterm erts_match_set_lint(Process *p, Eterm matchexpr); +extern void erts_match_set_release_result(Process* p); +extern Eterm erts_match_set_run(Process *p, Binary *mpsp, + Eterm *args, int num_args, + Uint32 *return_flags); +extern Eterm erts_match_set_get_source(Binary *mpsp); +extern void erts_match_prog_foreach_offheap(Binary *b, + void (*)(ErlOffHeap *, void *), + void *); + +#define MATCH_SET_RETURN_TRACE 0x1 /* return trace requested */ +#define MATCH_SET_RETURN_TO_TRACE 0x2 /* Misleading name, it is not actually + set by the match program, but by the + breakpoint functions */ +#define MATCH_SET_EXCEPTION_TRACE 0x4 /* exception trace requested */ +#define MATCH_SET_RX_TRACE (MATCH_SET_RETURN_TRACE|MATCH_SET_EXCEPTION_TRACE) +/* + * Flag values when tracing bif + */ +#define BIF_TRACE_AS_LOCAL 0x1 +#define BIF_TRACE_AS_GLOBAL 0x2 +#define BIF_TRACE_AS_META 0x4 + +extern erts_driver_t vanilla_driver; +extern erts_driver_t spawn_driver; +extern erts_driver_t fd_driver; + +/* Should maybe be placed in erl_message.h, but then we get an include mess. */ + +ERTS_GLB_INLINE Eterm * +erts_alloc_message_heap(Uint size, + ErlHeapFragment **bpp, + ErlOffHeap **ohpp, + Process *receiver, + ErtsProcLocks *receiver_locks); + +#if ERTS_GLB_INLINE_INCL_FUNC_DEF + +/* + * NOTE: erts_alloc_message_heap() releases msg q and status + * lock on receiver without ensuring that other locks are + * held. User is responsible to ensure that the receiver + * pointer cannot become invalid until after message has + * been passed. This is normal done either by increasing + * reference count on process (preferred) or by holding + * main or link lock over the whole message passing + * operation. + */ + +ERTS_GLB_INLINE Eterm * +erts_alloc_message_heap(Uint size, + ErlHeapFragment **bpp, + ErlOffHeap **ohpp, + Process *receiver, + ErtsProcLocks *receiver_locks) +{ + Eterm *hp; +#ifdef ERTS_SMP + int locked_main = 0; + ErtsProcLocks ulocks = *receiver_locks & ERTS_PROC_LOCKS_MSG_SEND; +#endif + + if (size > (Uint) INT_MAX) + erl_exit(ERTS_ABORT_EXIT, "HUGE size (%bpu)\n", size); + + if ( +#if defined(ERTS_SMP) + *receiver_locks & ERTS_PROC_LOCK_MAIN +#else + 1 +#endif + ) { +#ifdef ERTS_SMP + try_allocate_on_heap: +#endif + if (ERTS_PROC_IS_EXITING(receiver) + || HEAP_LIMIT(receiver) - HEAP_TOP(receiver) <= size) { +#ifdef ERTS_SMP + if (locked_main) + ulocks |= ERTS_PROC_LOCK_MAIN; +#endif + goto allocate_in_mbuf; + } +#ifdef ERTS_SMP + if (ulocks) { + erts_smp_proc_unlock(receiver, ulocks); + *receiver_locks &= ~ulocks; + } +#endif + hp = HEAP_TOP(receiver); + HEAP_TOP(receiver) = hp + size; + *bpp = NULL; + *ohpp = &MSO(receiver); + } +#ifdef ERTS_SMP + else if (erts_smp_proc_trylock(receiver, ERTS_PROC_LOCK_MAIN) == 0) { + locked_main = 1; + *receiver_locks |= ERTS_PROC_LOCK_MAIN; + goto try_allocate_on_heap; + } +#endif + else { + ErlHeapFragment *bp; + allocate_in_mbuf: +#ifdef ERTS_SMP + if (ulocks) { + *receiver_locks &= ~ulocks; + erts_smp_proc_unlock(receiver, ulocks); + } +#endif + bp = new_message_buffer(size); + hp = bp->mem; + *bpp = bp; + *ohpp = &bp->off_heap; + } + + return hp; +} + +#endif /* #if ERTS_GLB_INLINE_INCL_FUNC_DEF */ + +#endif diff --git a/erts/emulator/beam/hash.c b/erts/emulator/beam/hash.c new file mode 100644 index 0000000000..afaf32f8ce --- /dev/null +++ b/erts/emulator/beam/hash.c @@ -0,0 +1,407 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* +** General hash functions +** +*/ +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "hash.h" + +/* +** List of sizes (all are primes) +*/ +static const int h_size_table[] = { + 2, 5, 11, 23, 47, 97, 197, 397, 797, /* double upto here */ + 1201, 1597, + 2411, 3203, + 4813, 6421, + 9643, 12853, + 19289, 25717, + 51437, + 102877, + 205759, + 411527, + 823117, + 1646237, + 3292489, + 6584983, + 13169977, + 26339969, + 52679969, + -1 +}; + +/* +** Get info about hash +** +*/ + +void hash_get_info(HashInfo *hi, Hash *h) +{ + int size = h->size; + int i; + int max_depth = 0; + int objects = 0; + + for (i = 0; i < size; i++) { + int depth = 0; + HashBucket* b = h->bucket[i]; + + while (b != (HashBucket*) 0) { + objects++; + depth++; + b = b->next; + } + if (depth > max_depth) + max_depth = depth; + } + + hi->name = h->name; + hi->size = h->size; + hi->used = h->used; + hi->objs = objects; + hi->depth = max_depth; +} + +/* +** Display info about hash +** +*/ + +void hash_info(int to, void *arg, Hash* h) +{ + HashInfo hi; + + hash_get_info(&hi, h); + + erts_print(to, arg, "=hash_table:%s\n", hi.name); + erts_print(to, arg, "size: %d\n", hi.size); + erts_print(to, arg, "used: %d\n", hi.used); + erts_print(to, arg, "objs: %d\n", hi.objs); + erts_print(to, arg, "depth: %d\n", hi.depth); +} + + +/* + * Returns size of table in bytes. Stored objects not included. + */ +int +hash_table_sz(Hash *h) +{ + int i; + for(i=0;h->name[i];i++); + i++; + return sizeof(Hash) + h->size*sizeof(HashBucket*) + i; +} + + +/* +** init a pre allocated or static hash structure +** and allocate buckets. +*/ +Hash* hash_init(ErtsAlcType_t type, Hash* h, char* name, int size, HashFunctions fun) +{ + int sz; + int ix = 0; + + h->type = type; + + while (h_size_table[ix] != -1 && h_size_table[ix] < size) + ix++; + if (h_size_table[ix] == -1) + erl_exit(1, "panic: too large hash table size (%d)\n", size); + + size = h_size_table[ix]; + sz = size*sizeof(HashBucket*); + + h->bucket = (HashBucket**) erts_alloc(h->type, sz); + + sys_memzero(h->bucket, sz); + h->is_allocated = 0; + h->name = name; + h->fun = fun; + h->size = size; + h->size20percent = h->size/5; + h->size80percent = (4*h->size)/5; + h->ix = ix; + h->used = 0; + return h; +} + +/* +** Create a new hash table +*/ +Hash* hash_new(ErtsAlcType_t type, char* name, int size, HashFunctions fun) +{ + Hash* h; + + h = erts_alloc(type, sizeof(Hash)); + + h = hash_init(type, h, name, size, fun); + h->is_allocated = 1; + return h; +} + +/* +** Delete hash table and all objects +*/ +void hash_delete(Hash* h) +{ + int old_size = h->size; + int i; + + for (i = 0; i < old_size; i++) { + HashBucket* b = h->bucket[i]; + while (b != (HashBucket*) 0) { + HashBucket* b_next = b->next; + + h->fun.free((void*) b); + b = b_next; + } + } + erts_free(h->type, h->bucket); + if (h->is_allocated) + erts_free(h->type, (void*) h); +} + +/* +** Rehash all objects +*/ +static void rehash(Hash* h, int grow) +{ + int sz; + int old_size = h->size; + HashBucket** new_bucket; + int i; + + if (grow) { + if ((h_size_table[h->ix+1]) == -1) + return; + h->ix++; + } + else { + if (h->ix == 0) + return; + h->ix--; + } + h->size = h_size_table[h->ix]; + h->size20percent = h->size/5; + h->size80percent = (4*h->size)/5; + sz = h->size*sizeof(HashBucket*); + + new_bucket = (HashBucket **) erts_alloc(h->type, sz); + sys_memzero(new_bucket, sz); + + h->used = 0; + + for (i = 0; i < old_size; i++) { + HashBucket* b = h->bucket[i]; + while (b != (HashBucket*) 0) { + HashBucket* b_next = b->next; + int ix = b->hvalue % h->size; + if (new_bucket[ix] == NULL) + h->used++; + b->next = new_bucket[ix]; + new_bucket[ix] = b; + b = b_next; + } + } + erts_free(h->type, (void *) h->bucket); + h->bucket = new_bucket; +} + +/* +** Find an object in the hash table +** +*/ +void* hash_get(Hash* h, void* tmpl) +{ + HashValue hval = h->fun.hash(tmpl); + int ix = hval % h->size; + HashBucket* b = h->bucket[ix]; + + while(b != (HashBucket*) 0) { + if ((b->hvalue == hval) && (h->fun.cmp(tmpl, (void*)b) == 0)) + return (void*) b; + b = b->next; + } + return (void*) 0; +} + +/* +** Find or insert an object in the hash table +*/ +void* hash_put(Hash* h, void* tmpl) +{ + HashValue hval = h->fun.hash(tmpl); + int ix = hval % h->size; + HashBucket* b = h->bucket[ix]; + + while(b != (HashBucket*) 0) { + if ((b->hvalue == hval) && (h->fun.cmp(tmpl, (void*)b) == 0)) + return (void*) b; + b = b->next; + } + b = (HashBucket*) h->fun.alloc(tmpl); + + if (h->bucket[ix] == NULL) + h->used++; + + b->hvalue = hval; + b->next = h->bucket[ix]; + h->bucket[ix] = b; + + if (h->used > h->size80percent) /* rehash at 80% */ + rehash(h, 1); + return (void*) b; +} + +static void +hash_insert_entry(Hash* h, HashBucket* entry) +{ + HashValue hval = entry->hvalue; + int ix = hval % h->size; + HashBucket* b = h->bucket[ix]; + + while (b != (HashBucket*) 0) { + if ((b->hvalue == hval) && (h->fun.cmp((void*)entry, (void*)b) == 0)) { + abort(); /* Should not happen */ + } + b = b->next; + } + + if (h->bucket[ix] == NULL) + h->used++; + + entry->next = h->bucket[ix]; + h->bucket[ix] = entry; + + if (h->used > h->size80percent) /* rehash at 80% */ + rehash(h, 1); +} + + +/* + * Move all entries in src into dst; empty src. + * Entries in src must not exist in dst. + */ +void +erts_hash_merge(Hash* src, Hash* dst) +{ + int limit = src->size; + HashBucket** bucket = src->bucket; + int i; + + src->used = 0; + for (i = 0; i < limit; i++) { + HashBucket* b = bucket[i]; + HashBucket* next; + + bucket[i] = NULL; + while (b) { + next = b->next; + hash_insert_entry(dst, b); + b = next; + } + } +} + +/* +** Erase hash entry return template if erased +** return 0 if not erased +*/ +void* hash_erase(Hash* h, void* tmpl) +{ + HashValue hval = h->fun.hash(tmpl); + int ix = hval % h->size; + HashBucket* b = h->bucket[ix]; + HashBucket* prev = 0; + + while(b != 0) { + if ((b->hvalue == hval) && (h->fun.cmp(tmpl, (void*)b) == 0)) { + if (prev != 0) + prev->next = b->next; + else + h->bucket[ix] = b->next; + h->fun.free((void*)b); + if (h->bucket[ix] == NULL) + h->used--; + if (h->used < h->size20percent) /* rehash at 20% */ + rehash(h, 0); + return tmpl; + } + prev = b; + b = b->next; + } + return (void*)0; +} + +/* +** Remove hash entry from table return entry if removed +** return NULL if not removed +** NOTE: hash_remove() differs from hash_erase() in that +** it returns entry (not the template) and does +** *not* call the free() callback. +*/ +void * +hash_remove(Hash *h, void *tmpl) +{ + HashValue hval = h->fun.hash(tmpl); + int ix = hval % h->size; + HashBucket *b = h->bucket[ix]; + HashBucket *prev = NULL; + + while (b) { + if ((b->hvalue == hval) && (h->fun.cmp(tmpl, (void*)b) == 0)) { + if (prev) + prev->next = b->next; + else + h->bucket[ix] = b->next; + if (h->bucket[ix] == NULL) + h->used--; + if (h->used < h->size20percent) /* rehash at 20% */ + rehash(h, 0); + return (void *) b; + } + prev = b; + b = b->next; + } + return NULL; +} + +void hash_foreach(Hash* h, void (*func)(void *, void *), void *func_arg2) +{ + int i; + + for (i = 0; i < h->size; i++) { + HashBucket* b = h->bucket[i]; + while(b != (HashBucket*) 0) { + (*func)((void *) b, func_arg2); + b = b->next; + } + } +} + diff --git a/erts/emulator/beam/hash.h b/erts/emulator/beam/hash.h new file mode 100644 index 0000000000..6dd66fc9b3 --- /dev/null +++ b/erts/emulator/beam/hash.h @@ -0,0 +1,97 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* +** General hash functions +** +*/ +#ifndef __HASH_H__ +#define __HASH_H__ + +#ifndef __SYS_H__ +#include "sys.h" +#endif + +#include "erl_alloc.h" + +typedef unsigned long HashValue; + +typedef int (*HCMP_FUN)(void*, void*); +typedef HashValue (*H_FUN)(void*); +typedef void* (*HALLOC_FUN)(void*); +typedef void (*HFREE_FUN)(void*); + +/* +** This bucket must be placed in top of +** every object that uses hashing!!! +** (Object*) == (Object*) &bucket +*/ +typedef struct hash_bucket +{ + struct hash_bucket* next; /* Next bucket */ + HashValue hvalue; /* Store hash value for get, rehash */ +} HashBucket; + +typedef struct hash_functions +{ + H_FUN hash; + HCMP_FUN cmp; + HALLOC_FUN alloc; + HFREE_FUN free; +} HashFunctions; + +typedef struct { + char *name; + int size; + int used; + int objs; + int depth; +} HashInfo; + +typedef struct hash +{ + HashFunctions fun; /* Function block */ + int is_allocated; /* 0 iff hash structure is on stack or is static */ + ErtsAlcType_t type; + char* name; /* Table name (static string, for debugging) */ + int size; /* Number of slots */ + int size20percent; /* 20 percent of number of slots */ + int size80percent; /* 80 percent of number of slots */ + int ix; /* Size index in size table */ + int used; /* Number of slots used */ + HashBucket** bucket; /* Vector of bucket pointers (objects) */ +} Hash; + +Hash* hash_new(ErtsAlcType_t, char*, int, HashFunctions); +Hash* hash_init(ErtsAlcType_t, Hash*, char*, int, HashFunctions); + +void hash_delete(Hash*); +void hash_get_info(HashInfo*, Hash*); +void hash_info(int, void *, Hash*); +int hash_table_sz(Hash *); + +void* hash_get(Hash*, void*); +void* hash_put(Hash*, void*); +void* hash_erase(Hash*, void*); +void* hash_remove(Hash*, void*); +void hash_foreach(Hash*, void (*func)(void *, void *), void *); + +void erts_hash_merge(Hash* src, Hash* dst); + +#endif diff --git a/erts/emulator/beam/index.c b/erts/emulator/beam/index.c new file mode 100644 index 0000000000..a4a3007f93 --- /dev/null +++ b/erts/emulator/beam/index.c @@ -0,0 +1,137 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "index.h" + +void index_info(int to, void *arg, IndexTable *t) +{ + hash_info(to, arg, &t->htable); + erts_print(to, arg, "=index_table:%s\n", t->htable.name); + erts_print(to, arg, "size: %d\n", t->size); + erts_print(to, arg, "limit: %d\n", t->limit); + erts_print(to, arg, "entries: %d\n",t->entries); +} + + +/* + * Returns size of table in bytes. Stored objects not included. + */ +int +index_table_sz(IndexTable *t) +{ + return (sizeof(IndexTable) + - sizeof(Hash) + + t->size*sizeof(IndexSlot*) + + hash_table_sz(&(t->htable))); +} + + +/* +** init a pre allocated or static hash structure +** and allocate buckets. +*/ +IndexTable* +erts_index_init(ErtsAlcType_t type, IndexTable* t, char* name, + int size, int limit, HashFunctions fun) +{ + Uint base_size = ((limit+INDEX_PAGE_SIZE-1)/INDEX_PAGE_SIZE)*sizeof(IndexSlot*); + hash_init(type, &t->htable, name, 3*size/4, fun); + + t->size = 0; + t->limit = limit; + t->entries = 0; + t->type = type; + t->seg_table = (IndexSlot***) erts_alloc(type, base_size); + return t; +} + +int +index_put(IndexTable* t, void* tmpl) +{ + int ix; + IndexSlot* p = (IndexSlot*) hash_put(&t->htable, tmpl); + + if (p->index >= 0) { + return p->index; + } + + ix = t->entries; + if (ix >= t->size) { + Uint sz; + if (ix >= t->limit) { + erl_exit(1, "no more index entries in %s (max=%d)\n", + t->htable.name, t->limit); + } + sz = INDEX_PAGE_SIZE*sizeof(IndexSlot*); + t->seg_table[ix>>INDEX_PAGE_SHIFT] = erts_alloc(t->type, sz); + t->size += INDEX_PAGE_SIZE; + } + t->entries++; + p->index = ix; + t->seg_table[ix>>INDEX_PAGE_SHIFT][ix&INDEX_PAGE_MASK] = p; + return ix; +} + +int index_get(IndexTable* t, void* tmpl) +{ + IndexSlot* p = (IndexSlot*) hash_get(&t->htable, tmpl); + + if (p != NULL) { + return p->index; + } + return -1; +} + +void erts_index_merge(Hash* src, IndexTable* dst) +{ + int limit = src->size; + HashBucket** bucket = src->bucket; + int i; + + for (i = 0; i < limit; i++) { + HashBucket* b = bucket[i]; + IndexSlot* p; + int ix; + + while (b) { + Uint sz; + ix = dst->entries++; + if (ix >= dst->size) { + if (ix >= dst->limit) { + erl_exit(1, "no more index entries in %s (max=%d)\n", + dst->htable.name, dst->limit); + } + sz = INDEX_PAGE_SIZE*sizeof(IndexSlot*); + dst->seg_table[ix>>INDEX_PAGE_SHIFT] = erts_alloc(dst->type, sz); + dst->size += INDEX_PAGE_SIZE; + } + p = (IndexSlot*) b; + p->index = ix; + dst->seg_table[ix>>INDEX_PAGE_SHIFT][ix&INDEX_PAGE_MASK] = p; + b = b->next; + } + } +} diff --git a/erts/emulator/beam/index.h b/erts/emulator/beam/index.h new file mode 100644 index 0000000000..4eb9b1f992 --- /dev/null +++ b/erts/emulator/beam/index.h @@ -0,0 +1,71 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* +** General hash and index functions +** The idea behind this file was to capture the +** way Atom,Export and Module table was implemented +*/ +#ifndef __INDEX_H__ +#define __INDEX_H__ + +#ifndef __HASH_H__ +#include "hash.h" +#endif + +typedef struct index_slot +{ + HashBucket bucket; + int index; +} IndexSlot; + + +typedef struct index_table +{ + Hash htable; /* Mapping obj -> index */ + ErtsAlcType_t type; + int size; /* Allocated size */ + int limit; /* Max size */ + int entries; /* Number of entries */ + IndexSlot*** seg_table; /* Mapping index -> obj */ +} IndexTable; + +#define INDEX_PAGE_SHIFT 10 +#define INDEX_PAGE_SIZE (1 << INDEX_PAGE_SHIFT) +#define INDEX_PAGE_MASK ((1 << INDEX_PAGE_SHIFT)-1) + +IndexTable *erts_index_init(ErtsAlcType_t,IndexTable*,char*,int,int,HashFunctions); +void index_info(int, void *, IndexTable*); +int index_table_sz(IndexTable *); + +int index_get(IndexTable*, void*); +int index_put(IndexTable*, void*); +void erts_index_merge(Hash*, IndexTable*); + +ERTS_GLB_INLINE IndexSlot* erts_index_lookup(IndexTable*, Uint); + +#if ERTS_GLB_INLINE_INCL_FUNC_DEF +ERTS_GLB_INLINE IndexSlot* +erts_index_lookup(IndexTable* t, Uint ix) +{ + return t->seg_table[ix>>INDEX_PAGE_SHIFT][ix&INDEX_PAGE_MASK]; +} +#endif + +#endif diff --git a/erts/emulator/beam/io.c b/erts/emulator/beam/io.c new file mode 100644 index 0000000000..61985271e6 --- /dev/null +++ b/erts/emulator/beam/io.c @@ -0,0 +1,4732 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* + * I/O routines for manipulating ports. + */ + +#define ERL_IO_C__ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" + +/* must be included BEFORE global.h (since it includes erl_driver.h) */ +#include "erl_sys_driver.h" + +#include "erl_vm.h" +#include "global.h" +#include "erl_process.h" +#include "dist.h" +#include "big.h" +#include "erl_binary.h" +#include "erl_bits.h" +#include "erl_version.h" +#include "error.h" + +extern ErlDrvEntry fd_driver_entry; +extern ErlDrvEntry vanilla_driver_entry; +extern ErlDrvEntry spawn_driver_entry; +extern ErlDrvEntry *driver_tab[]; /* table of static drivers, only used during initialization */ + +erts_driver_t *driver_list; /* List of all drivers, static and dynamic. */ +erts_smp_mtx_t erts_driver_list_lock; /* Mutex for driver list */ +static erts_smp_tsd_key_t driver_list_lock_status_key; /*stop recursive locks when calling + driver init */ +static erts_smp_tsd_key_t driver_list_last_error_key; /* Save last DDLL error on a + per thread basis (for BC interfaces) */ + +Port* erts_port; /* The port table */ +erts_smp_atomic_t erts_ports_alive; +erts_smp_atomic_t erts_bytes_out; /* No bytes sent out of the system */ +erts_smp_atomic_t erts_bytes_in; /* No bytes gotten into the system */ + +Uint erts_max_ports; +Uint erts_port_tab_index_mask; + +const ErlDrvTermData driver_term_nil = (ErlDrvTermData)NIL; + +erts_driver_t vanilla_driver; +erts_driver_t spawn_driver; +erts_driver_t fd_driver; + +static int init_driver(erts_driver_t *, ErlDrvEntry *, DE_Handle *); +static void terminate_port(Port *p); +static void pdl_init(void); + +static ERTS_INLINE ErlIOQueue* +drvport2ioq(ErlDrvPort drvport) +{ + int ix = (int) drvport; + if (ix < 0 || erts_max_ports <= ix) + return NULL; + if (erts_port[ix].status & ERTS_PORT_SFLGS_INVALID_DRIVER_LOOKUP) + return NULL; + ERTS_LC_ASSERT(!erts_port[ix].port_data_lock + || erts_lc_mtx_is_locked(&erts_port[ix].port_data_lock->mtx)); + ERTS_SMP_LC_ASSERT(erts_port[ix].port_data_lock + || erts_lc_is_port_locked(&erts_port[ix])); + return &erts_port[ix].ioq; +} + +static ERTS_INLINE int +is_port_ioq_empty(Port *pp) +{ + int res; + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(pp)); + if (!pp->port_data_lock) + res = (pp->ioq.size == 0); + else { + ErlDrvPDL pdl = pp->port_data_lock; + erts_mtx_lock(&pdl->mtx); + res = (pp->ioq.size == 0); + erts_mtx_unlock(&pdl->mtx); + } + return res; +} + +int +erts_is_port_ioq_empty(Port *pp) +{ + return is_port_ioq_empty(pp); +} + +Uint +erts_port_ioq_size(Port *pp) +{ + int res; + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(pp)); + if (!pp->port_data_lock) + res = pp->ioq.size; + else { + ErlDrvPDL pdl = pp->port_data_lock; + erts_mtx_lock(&pdl->mtx); + res = pp->ioq.size; + erts_mtx_unlock(&pdl->mtx); + } + return (Uint) res; +} + +/* + * Line buffered I/O. + */ +typedef struct line_buf_context { + LineBuf **b; + char *buf; + int left; + int retlen; +} LineBufContext; + +#define LINEBUF_EMPTY 0 +#define LINEBUF_EOL 1 +#define LINEBUF_NOEOL 2 +#define LINEBUF_ERROR -1 + +#define LINEBUF_STATE(LBC) ((*(LBC).b)->data[0]) + +#define LINEBUF_DATA(LBC) (((*(LBC).b)->data) + 1) +#define LINEBUF_DATALEN(LBC) ((LBC).retlen) + +#define LINEBUF_INITIAL 100 + + +/* The 'number' field in a port now has two parts: the lowest bits + contain the index in the port table, and the higher bits are a counter + which is incremented each time we look for a free port and start from + the beginning of the table. erts_max_ports is the number of file descriptors, + rounded up to a power of 2. + To get the index from a port, use the macro 'internal_port_index'; + 'port_number' returns the whole number field. +*/ + +static erts_smp_spinlock_t get_free_port_lck; +static Uint last_port_num; +static Uint port_num_mask; +erts_smp_atomic_t erts_ports_snapshot; /* Identifies the _next_ snapshot (not the ongoing) */ + + +static ERTS_INLINE void +kill_port(Port *pp) +{ + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(pp)); + erts_port_task_free_port(pp); + ASSERT(pp->status & ERTS_PORT_SFLGS_DEAD); +} + +#ifdef ERTS_SMP + +#ifdef ERTS_ENABLE_LOCK_CHECK +int +erts_lc_is_port_locked(Port *prt) +{ + if (!prt) + return 0; + return erts_smp_lc_mtx_is_locked(prt->lock); +} +#endif + +#endif /* #ifdef ERTS_SMP */ + +static int +get_free_port(void) +{ + Uint num; + Uint tries = erts_max_ports; + Port* port; + + erts_smp_spin_lock(&get_free_port_lck); + num = last_port_num + 1; + for (;; ++num) { + port = &erts_port[num & erts_port_tab_index_mask]; + + erts_smp_port_state_lock(port); + if (port->status & ERTS_PORT_SFLG_FREE) { + last_port_num = num; + erts_smp_spin_unlock(&get_free_port_lck); + break; + } + erts_smp_port_state_unlock(port); + + if (--tries == 0) { + erts_smp_spin_unlock(&get_free_port_lck); + return -1; + } + } + port->status = ERTS_PORT_SFLG_INITIALIZING; +#ifdef ERTS_SMP + ERTS_SMP_LC_ASSERT(erts_smp_atomic_read(&port->refc) == 0); + erts_smp_atomic_set(&port->refc, 2); /* Port alive + lock */ +#endif + erts_smp_port_state_unlock(port); + return num & port_num_mask; +} + +/* + * erts_test_next_port() is only used for testing. + */ +Sint +erts_test_next_port(int set, Uint next) +{ + Uint i, num; + Sint res = -1; + + erts_smp_spin_lock(&get_free_port_lck); + if (set) { + last_port_num = (next - 1) & port_num_mask; + } + num = last_port_num + 1; + + for (i=0; i < erts_max_ports && res<0; ++i, ++num) { + + Port* port = &erts_port[num & erts_port_tab_index_mask]; + + erts_smp_port_state_lock(port); + + if (port->status & ERTS_PORT_SFLG_FREE) { + last_port_num = num - 1; + res = num & port_num_mask; + } + erts_smp_port_state_unlock(port); + } + erts_smp_spin_unlock(&get_free_port_lck); + return res; +} + +void +erts_port_cleanup(Port *prt) +{ +#ifdef ERTS_SMP + Uint32 port_specific; + erts_smp_mtx_t *mtx; +#endif + erts_driver_t *driver; + + erts_smp_port_state_lock(prt); + + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(prt)); + driver = prt->drv_ptr; + prt->drv_ptr = NULL; + ASSERT(driver); + +#ifdef ERTS_SMP + + ASSERT(prt->status & ERTS_PORT_SFLG_FREE_SCHEDULED); + ERTS_SMP_LC_ASSERT(erts_smp_atomic_read(&prt->refc) == 0); + + port_specific = (prt->status & ERTS_PORT_SFLG_PORT_SPECIFIC_LOCK); + + mtx = prt->lock; + ASSERT(mtx); + + prt->lock = NULL; + + ASSERT(prt->status & ERTS_PORT_SFLG_PORT_DEBUG); + ASSERT(!(prt->status & ERTS_PORT_SFLG_FREE)); + prt->status = ERTS_PORT_SFLG_FREE; + + erts_smp_port_state_unlock(prt); + erts_smp_mtx_unlock(mtx); + + if (port_specific) { + erts_smp_mtx_destroy(mtx); + erts_free(ERTS_ALC_T_PORT_LOCK, mtx); + } +#endif + + if (driver->handle) + erts_ddll_dereference_driver(driver->handle); +} + + +/* +** Initialize v_start to point to the small fixed vector. +** Once (reallocated) we never reset the pointer to the small vector +** This is a possible optimisation. +*/ +static void initq(Port* prt) +{ + ErlIOQueue* q = &prt->ioq; + + ERTS_LC_ASSERT(!prt->port_data_lock); + + q->size = 0; + q->v_head = q->v_tail = q->v_start = q->v_small; + q->v_end = q->v_small + SMALL_IO_QUEUE; + q->b_head = q->b_tail = q->b_start = q->b_small; + q->b_end = q->b_small + SMALL_IO_QUEUE; +} + +static void stopq(Port* prt) +{ + ErlIOQueue* q; + ErlDrvBinary** binp; + + if (prt->port_data_lock) + driver_pdl_lock(prt->port_data_lock); + + q = &prt->ioq; + binp = q->b_head; + + if (q->v_start != q->v_small) + erts_free(ERTS_ALC_T_IOQ, (void *) q->v_start); + + while(binp < q->b_tail) { + if (*binp != NULL) + driver_free_binary(*binp); + binp++; + } + if (q->b_start != q->b_small) + erts_free(ERTS_ALC_T_IOQ, (void *) q->b_start); + q->v_start = q->v_end = q->v_head = q->v_tail = NULL; + q->b_start = q->b_end = q->b_head = q->b_tail = NULL; + q->size = 0; + + if (prt->port_data_lock) { + driver_pdl_unlock(prt->port_data_lock); + driver_pdl_dec_refc(prt->port_data_lock); + prt->port_data_lock = NULL; + } +} + + + +static void +setup_port(Port* prt, Eterm pid, erts_driver_t *driver, + ErlDrvData drv_data, char *name, Uint32 xstatus) +{ + ErtsRunQueue *runq = erts_get_runq_current(NULL); + char *new_name, *old_name; +#ifdef DEBUG + /* Make sure the debug flags survives until port is freed */ + xstatus |= ERTS_PORT_SFLG_PORT_DEBUG; +#endif + ASSERT(runq); + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(prt)); + + + new_name = (char*) erts_alloc(ERTS_ALC_T_PORT_NAME, sys_strlen(name)+1); + sys_strcpy(new_name, name); + erts_smp_runq_lock(runq); + erts_smp_atomic_inc(&erts_ports_alive); + erts_smp_port_state_lock(prt); + prt->status = ERTS_PORT_SFLG_CONNECTED | xstatus; + prt->snapshot = (Uint32) erts_smp_atomic_read(&erts_ports_snapshot); + old_name = prt->name; + prt->name = new_name; +#ifdef ERTS_SMP + erts_smp_atomic_set(&prt->run_queue, (long) runq); +#endif + ASSERT(!prt->drv_ptr); + prt->drv_ptr = driver; + erts_smp_port_state_unlock(prt); + erts_smp_runq_unlock(runq); +#ifdef ERTS_SMP + ASSERT(!prt->xports); +#endif + if (old_name) { + erts_free(ERTS_ALC_T_PORT_NAME, (void *) old_name); + } + + prt->control_flags = 0; + prt->connected = pid; + prt->drv_data = (long) drv_data; + prt->bytes_in = 0; + prt->bytes_out = 0; + prt->dist_entry = NULL; + prt->reg = NULL; +#ifdef ERTS_SMP + prt->ptimer = NULL; +#else + sys_memset(&prt->tm, 0, sizeof(ErlTimer)); +#endif + erts_port_task_handle_init(&prt->timeout_task); + prt->suspended = NULL; + sys_strcpy(prt->name, name); + prt->nlinks = NULL; + prt->monitors = NULL; + prt->linebuf = NULL; + prt->bp = NULL; + prt->data = am_undefined; + /* Set default tracing */ + erts_get_default_tracing(&(prt->trace_flags), &(prt->tracer_proc)); + + prt->psd = NULL; + + initq(prt); +} + +void +erts_wake_process_later(Port *prt, Process *process) +{ + ErtsProcList** p; + ErtsProcList* new_p; + + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(prt)); + + if (prt->status & ERTS_PORT_SFLGS_DEAD) + return; + + for (p = &(prt->suspended); *p != NULL; p = &((*p)->next)) + /* Empty loop body */; + + new_p = erts_proclist_create(process); + new_p->next = NULL; + *p = new_p; +} + +/* + Opens a driver. + Returns the non-negative port number, if successful. + If there is an error, -1 or -2 or -3 is returned. -2 means that + there is valid error information in *error_number_ptr. + Returning -3 means that an error in the given options was detected + (*error_number_ptr must contain either BADARG or SYSTEM_LIMIT). + The driver start function must obey the same conventions. +*/ +int +erts_open_driver(erts_driver_t* driver, /* Pointer to driver. */ + Eterm pid, /* Current process. */ + char* name, /* Driver name. */ + SysDriverOpts* opts, /* Options. */ + int *error_number_ptr) /* errno in case -2 is returned */ +{ + int port_num; + int port_ix; + ErlDrvData drv_data = 0; + Uint32 xstatus = 0; + Port *port; + int fpe_was_unmasked; + + if (error_number_ptr) + *error_number_ptr = 0; + + ERTS_SMP_CHK_NO_PROC_LOCKS; + + if ((port_num = get_free_port()) < 0) { + if (error_number_ptr) { + *error_number_ptr = SYSTEM_LIMIT; + } + return -3; + } + + port_ix = port_num & erts_port_tab_index_mask; + port = &erts_port[port_ix]; + port->id = make_internal_port(port_num); + + erts_smp_mtx_lock(&erts_driver_list_lock); + if (!driver) { + for (driver = driver_list; driver; driver = driver->next) { + if (sys_strcmp(driver->name, name) == 0) + break; + } + if (!driver) { + erts_smp_mtx_unlock(&erts_driver_list_lock); + if (error_number_ptr) + *error_number_ptr = BADARG; + return -3; + } + } + if (driver == &spawn_driver) { + char *p; + erts_driver_t *d; + + /* + * Dig out the name of the driver or port program. + */ + + if (!(opts->spawn_type & ERTS_SPAWN_EXECUTABLE)) { + /* No spawn driver default */ + driver = NULL; + } + + + if (opts->spawn_type != ERTS_SPAWN_EXECUTABLE) { + p = name; + while(*p != '\0' && *p != ' ') + p++; + if (*p == '\0') + p = NULL; + else + *p = '\0'; + + /* + * Search for a driver having this name. Defaults to spawn_driver + * if not found. + */ + + for (d = driver_list; d; d = d->next) { + if (strcmp(d->name, name) == 0 && + erts_ddll_driver_ok(d->handle)) { + driver = d; + break; + } + } + if (p != NULL) + *p = ' '; + } + } + + if (driver == NULL || (driver != &spawn_driver && opts->exit_status)) { + erts_smp_mtx_unlock(&erts_driver_list_lock); + if (error_number_ptr) { + *error_number_ptr = BADARG; + } + /* Need to mark the port as free again */ + erts_smp_port_state_lock(port); + port->status = ERTS_PORT_SFLG_FREE; +#ifdef ERTS_SMP + ERTS_SMP_LC_ASSERT(erts_smp_atomic_read(&port->refc) == 2); + erts_smp_atomic_set(&port->refc, 0); +#endif + erts_smp_port_state_unlock(port); + return -3; + } + + /* + * We'll set up the port before calling the start function, + * to allow message sending and setting timers in the start function. + */ + +#ifdef ERTS_SMP + ASSERT(!port->lock); + port->lock = driver->lock; + if (!port->lock) { + port->lock = erts_alloc(ERTS_ALC_T_PORT_LOCK, + sizeof(erts_smp_mtx_t)); + erts_smp_mtx_init_x(port->lock, + "port_lock", + port->id); + xstatus |= ERTS_PORT_SFLG_PORT_SPECIFIC_LOCK; + } +#endif + + if (driver->handle != NULL) { + erts_ddll_increment_port_count(driver->handle); + erts_ddll_reference_driver(driver->handle); + } + erts_smp_mtx_unlock(&erts_driver_list_lock); + +#ifdef ERTS_SMP + erts_smp_mtx_lock(port->lock); +#endif + + setup_port(port, pid, driver, drv_data, name, xstatus); + + if (IS_TRACED_FL(port, F_TRACE_PORTS)) { + trace_port_open(port, + pid, + am_atom_put(port->name, strlen(port->name))); + } + + if (driver->start) { + if (IS_TRACED_FL(port, F_TRACE_SCHED_PORTS)) { + trace_sched_ports_where(port, am_in, am_start); + } + port->caller = pid; + fpe_was_unmasked = erts_block_fpe(); + drv_data = (*driver->start)((ErlDrvPort)(port_ix), + name, opts); + erts_unblock_fpe(fpe_was_unmasked); + port->caller = NIL; + erts_unblock_fpe(fpe_was_unmasked); + if (IS_TRACED_FL(port, F_TRACE_SCHED_PORTS)) { + trace_sched_ports_where(port, am_out, am_start); + } + if (error_number_ptr && ((long) drv_data) == (long) -2) + *error_number_ptr = errno; +#ifdef ERTS_SMP + if (port->xports) + erts_smp_xports_unlock(port); + ASSERT(!port->xports); +#endif + } + + if (((long)drv_data) == -1 || + ((long)drv_data) == -2 || + ((long)drv_data) == -3) { + int res = (int) ((long) drv_data); + + if (res == -3 && error_number_ptr) { + *error_number_ptr = BADARG; + } + + /* + * Must clean up the port. + */ +#ifdef ERTS_SMP + erts_cancel_smp_ptimer(port->ptimer); +#else + erl_cancel_timer(&(port->tm)); +#endif + stopq(port); + kill_port(port); + if (port->linebuf != NULL) { + erts_free(ERTS_ALC_T_LINEBUF, + (void *) port->linebuf); + port->linebuf = NULL; + } + if (driver->handle != NULL) { + erts_smp_mtx_lock(&erts_driver_list_lock); + erts_ddll_decrement_port_count(driver->handle); + erts_smp_mtx_unlock(&erts_driver_list_lock); + } + erts_port_release(port); + return res; + } + port->drv_data = (long) drv_data; + return port_ix; +} + +#ifdef ERTS_SMP + +struct ErtsXPortsList_ { + ErtsXPortsList *next; + Port *port; +}; + +ERTS_SCHED_PREF_QUICK_ALLOC_IMPL(xports_list, ErtsXPortsList, 50, ERTS_ALC_T_XPORTS_LIST) + +#endif + +/* + * Driver function to create new instances of a driver + * Historical reason: to be used with inet_drv for creating + * accept sockets inorder to avoid a global table. + */ +ErlDrvPort +driver_create_port(ErlDrvPort creator_port_ix, /* Creating port */ + ErlDrvTermData pid, /* Owner/Caller */ + char* name, /* Driver name */ + ErlDrvData drv_data) /* Driver data */ +{ + Port *creator_port; + Port* port; + erts_driver_t *driver; + Process *rp; + int port_num; + Eterm port_id; + Uint32 xstatus = 0; + + ERTS_SMP_CHK_NO_PROC_LOCKS; + + creator_port = erts_drvport2port(creator_port_ix); + if (!creator_port) + return (ErlDrvTermData) -1; + + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(creator_port)); + + driver = creator_port->drv_ptr; + erts_smp_mtx_lock(&erts_driver_list_lock); + if (!erts_ddll_driver_ok(driver->handle)) { + erts_smp_mtx_unlock(&erts_driver_list_lock); + return (ErlDrvTermData) -1; + } + + rp = erts_pid2proc(NULL, 0, pid, ERTS_PROC_LOCK_LINK); + if (!rp) { + erts_smp_mtx_unlock(&erts_driver_list_lock); + return (ErlDrvTermData) -1; /* pid does not exist */ + } + if ((port_num = get_free_port()) < 0) { + errno = ENFILE; + erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_LINK); + erts_smp_mtx_unlock(&erts_driver_list_lock); + return (ErlDrvTermData) -1; + } + + port_id = make_internal_port(port_num); + port = &erts_port[port_num & erts_port_tab_index_mask]; + +#ifdef ERTS_SMP + ASSERT(!port->lock); + port->lock = driver->lock; + if (!port->lock) { + ErtsXPortsList *xplp = xports_list_alloc(); + xplp->port = port; + xplp->next = creator_port->xports; + creator_port->xports = xplp; + port->lock = erts_alloc(ERTS_ALC_T_PORT_LOCK, + sizeof(erts_smp_mtx_t)); + erts_smp_mtx_init_locked_x(port->lock, "port_lock", port_id); + xstatus |= ERTS_PORT_SFLG_PORT_SPECIFIC_LOCK; + } + +#endif + + if (driver->handle != NULL) { + erts_ddll_increment_port_count(driver->handle); + erts_ddll_reference_referenced_driver(driver->handle); + } + erts_smp_mtx_unlock(&erts_driver_list_lock); + + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(port)); + + setup_port(port, pid, driver, drv_data, name, xstatus); + port->id = port_id; + + erts_add_link(&(port->nlinks), LINK_PID, pid); + erts_add_link(&(rp->nlinks), LINK_PID, port_id); + erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_LINK); + return port_num & erts_port_tab_index_mask; +} + +#ifdef ERTS_SMP +void +erts_smp_xports_unlock(Port *prt) +{ + ErtsXPortsList *xplp; + + ASSERT(prt); + xplp = prt->xports; + ASSERT(xplp); + while (xplp) { + ErtsXPortsList *free_xplp; + if (xplp->port->xports) + erts_smp_xports_unlock(xplp->port); + erts_port_release(xplp->port); + free_xplp = xplp; + xplp = xplp->next; + xports_list_free(free_xplp); + } + prt->xports = NULL; +} +#endif + +/* Fills a possibly deep list of chars and binaries into vec +** Small characters are first stored in the buffer buf of length ln +** binaries found are copied and linked into msoh +** Return vector length on succsess, +** -1 on overflow +** -2 on type error +*/ + +#define SET_VEC(iov, bv, bin, ptr, len, vlen) do { \ + (iov)->iov_base = (ptr); \ + (iov)->iov_len = (len); \ + *(bv)++ = (bin); \ + (iov)++; \ + (vlen)++; \ +} while(0) + +static int +io_list_to_vec(Eterm obj, /* io-list */ + SysIOVec* iov, /* io vector */ + ErlDrvBinary** binv, /* binary reference vector */ + ErlDrvBinary* cbin, /* binary to store characters */ + int bin_limit) /* small binaries limit */ +{ + DECLARE_ESTACK(s); + Eterm* objp; + char *buf = cbin->orig_bytes; + int len = cbin->orig_size; + int csize = 0; + int vlen = 0; + char* cptr = buf; + + goto L_jump_start; /* avoid push */ + + while (!ESTACK_ISEMPTY(s)) { + obj = ESTACK_POP(s); + L_jump_start: + if (is_list(obj)) { + L_iter_list: + objp = list_val(obj); + obj = CAR(objp); + if (is_byte(obj)) { + if (len == 0) + goto L_overflow; + *buf++ = unsigned_val(obj); + csize++; + len--; + } else if (is_binary(obj)) { + ESTACK_PUSH(s, CDR(objp)); + goto handle_binary; + } else if (is_list(obj)) { + ESTACK_PUSH(s, CDR(objp)); + goto L_iter_list; /* on head */ + } else if (!is_nil(obj)) { + goto L_type_error; + } + obj = CDR(objp); + if (is_list(obj)) + goto L_iter_list; /* on tail */ + else if (is_binary(obj)) { + goto handle_binary; + } else if (!is_nil(obj)) { + goto L_type_error; + } + } else if (is_binary(obj)) { + Eterm real_bin; + Uint offset; + Eterm* bptr; + int size; + int bitoffs; + int bitsize; + + handle_binary: + size = binary_size(obj); + ERTS_GET_REAL_BIN(obj, real_bin, offset, bitoffs, bitsize); + ASSERT(bitsize == 0); + bptr = binary_val(real_bin); + if (*bptr == HEADER_PROC_BIN) { + ProcBin* pb = (ProcBin *) bptr; + if (bitoffs != 0) { + if (len < size) { + goto L_overflow; + } + erts_copy_bits(pb->bytes+offset, bitoffs, 1, + (byte *) buf, 0, 1, size*8); + csize += size; + buf += size; + len -= size; + } else if (bin_limit && size < bin_limit) { + if (len < size) { + goto L_overflow; + } + sys_memcpy(buf, pb->bytes+offset, size); + csize += size; + buf += size; + len -= size; + } else { + if (csize != 0) { + SET_VEC(iov, binv, cbin, cptr, csize, vlen); + cptr = buf; + csize = 0; + } + if (pb->flags) { + erts_emasculate_writable_binary(pb); + } + SET_VEC(iov, binv, Binary2ErlDrvBinary(pb->val), + pb->bytes+offset, size, vlen); + } + } else { + ErlHeapBin* hb = (ErlHeapBin *) bptr; + if (len < size) { + goto L_overflow; + } + copy_binary_to_buffer(buf, 0, + ((byte *) hb->data)+offset, bitoffs, + 8*size); + csize += size; + buf += size; + len -= size; + } + } else if (!is_nil(obj)) { + goto L_type_error; + } + } + + if (csize != 0) { + SET_VEC(iov, binv, cbin, cptr, csize, vlen); + } + + DESTROY_ESTACK(s); + return vlen; + + L_type_error: + DESTROY_ESTACK(s); + return -2; + + L_overflow: + DESTROY_ESTACK(s); + return -1; +} + +#define IO_LIST_VEC_COUNT(obj) \ +do { \ + int _size = binary_size(obj); \ + Eterm _real; \ + Uint _offset; \ + int _bitoffs; \ + int _bitsize; \ + ERTS_GET_REAL_BIN(obj, _real, _offset, _bitoffs, _bitsize); \ + ASSERT(_bitsize == 0); \ + if (thing_subtag(*binary_val(_real)) == REFC_BINARY_SUBTAG && \ + _bitoffs == 0) { \ + b_size += _size; \ + in_clist = 0; \ + v_size++; \ + if (_size >= bin_limit) { \ + p_in_clist = 0; \ + p_v_size++; \ + } else { \ + p_c_size += _size; \ + if (!p_in_clist) { \ + p_in_clist = 1; \ + p_v_size++; \ + } \ + } \ + } else { \ + c_size += _size; \ + if (!in_clist) { \ + in_clist = 1; \ + v_size++; \ + } \ + p_c_size += _size; \ + if (!p_in_clist) { \ + p_in_clist = 1; \ + p_v_size++; \ + } \ + } \ +} while (0) + + +/* +** Size of a io list in bytes +** return -1 if error +** returns: - Total size of io list +** vsize - SysIOVec size needed for a writev +** csize - Number of bytes not in binary (in the common binary) +** pvsize - SysIOVec size needed if packing small binaries +** pcsize - Number of bytes in the common binary if packing +*/ + +static int +io_list_vec_len(Eterm obj, int* vsize, int* csize, + int bin_limit, /* small binaries limit */ + int * pvsize, int * pcsize) +{ + DECLARE_ESTACK(s); + Eterm* objp; + int v_size = 0; + int c_size = 0; + int b_size = 0; + int in_clist = 0; + int p_v_size = 0; + int p_c_size = 0; + int p_in_clist = 0; + + goto L_jump_start; /* avoid a push */ + + while (!ESTACK_ISEMPTY(s)) { + obj = ESTACK_POP(s); + L_jump_start: + if (is_list(obj)) { + L_iter_list: + objp = list_val(obj); + obj = CAR(objp); + + if (is_byte(obj)) { + c_size++; + if (!in_clist) { + in_clist = 1; + v_size++; + } + p_c_size++; + if (!p_in_clist) { + p_in_clist = 1; + p_v_size++; + } + } + else if (is_binary(obj)) { + IO_LIST_VEC_COUNT(obj); + } + else if (is_list(obj)) { + ESTACK_PUSH(s, CDR(objp)); + goto L_iter_list; /* on head */ + } + else if (!is_nil(obj)) { + goto L_type_error; + } + + obj = CDR(objp); + if (is_list(obj)) + goto L_iter_list; /* on tail */ + else if (is_binary(obj)) { /* binary tail is OK */ + IO_LIST_VEC_COUNT(obj); + } + else if (!is_nil(obj)) { + goto L_type_error; + } + } + else if (is_binary(obj)) { + IO_LIST_VEC_COUNT(obj); + } + else if (!is_nil(obj)) { + goto L_type_error; + } + } + + DESTROY_ESTACK(s); + if (vsize != NULL) + *vsize = v_size; + if (csize != NULL) + *csize = c_size; + if (pvsize != NULL) + *pvsize = p_v_size; + if (pcsize != NULL) + *pcsize = p_c_size; + return c_size + b_size; + + L_type_error: + DESTROY_ESTACK(s); + return -1; +} + +#define ERL_SMALL_IO_BIN_LIMIT (4*ERL_ONHEAP_BIN_LIMIT) +#define SMALL_WRITE_VEC 16 + + +/* write data to a port */ +int erts_write_to_port(Eterm caller_id, Port *p, Eterm list) +{ + char *buf; + erts_driver_t *drv = p->drv_ptr; + int size; + int fpe_was_unmasked; + + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(p)); + ERTS_SMP_CHK_NO_PROC_LOCKS; + + p->caller = caller_id; + if (drv->outputv != NULL) { + int vsize; + int csize; + int pvsize; + int pcsize; + int blimit; + SysIOVec iv[SMALL_WRITE_VEC]; + ErlDrvBinary* bv[SMALL_WRITE_VEC]; + SysIOVec* ivp; + ErlDrvBinary** bvp; + ErlDrvBinary* cbin; + ErlIOVec ev; + + if ((size = io_list_vec_len(list, &vsize, &csize, + ERL_SMALL_IO_BIN_LIMIT, + &pvsize, &pcsize)) < 0) { + goto bad_value; + } + /* To pack or not to pack (small binaries) ...? */ + vsize++; + if (vsize <= SMALL_WRITE_VEC) { + /* Do NOT pack */ + blimit = 0; + } else { + /* Do pack */ + vsize = pvsize + 1; + csize = pcsize; + blimit = ERL_SMALL_IO_BIN_LIMIT; + } + /* Use vsize and csize from now on */ + if (vsize <= SMALL_WRITE_VEC) { + ivp = iv; + bvp = bv; + } else { + ivp = (SysIOVec *) erts_alloc(ERTS_ALC_T_TMP, + vsize * sizeof(SysIOVec)); + bvp = (ErlDrvBinary**) erts_alloc(ERTS_ALC_T_TMP, + vsize * sizeof(ErlDrvBinary*)); + } + cbin = driver_alloc_binary(csize); + if (!cbin) + erts_alloc_enomem(ERTS_ALC_T_DRV_BINARY, sizeof(Binary) + csize); + + /* Element 0 is for driver usage to add header block */ + ivp[0].iov_base = NULL; + ivp[0].iov_len = 0; + bvp[0] = NULL; + ev.vsize = io_list_to_vec(list, ivp+1, bvp+1, cbin, blimit); + ev.vsize++; +#if 0 + /* This assertion may say something useful, but it can + be falsified during the emulator test suites. */ + ASSERT((ev.vsize >= 0) && (ev.vsize == vsize)); +#endif + ev.size = size; /* total size */ + ev.iov = ivp; + ev.binv = bvp; + fpe_was_unmasked = erts_block_fpe(); + (*drv->outputv)((ErlDrvData)p->drv_data, &ev); + erts_unblock_fpe(fpe_was_unmasked); + if (ivp != iv) { + erts_free(ERTS_ALC_T_TMP, (void *) ivp); + } + if (bvp != bv) { + erts_free(ERTS_ALC_T_TMP, (void *) bvp); + } + driver_free_binary(cbin); + } else { + int r; + + /* Try with an 8KB buffer first (will often be enough I guess). */ + size = 8*1024; + /* See below why the extra byte is added. */ + buf = erts_alloc(ERTS_ALC_T_TMP, size+1); + r = io_list_to_buf(list, buf, size); + + if (r >= 0) { + size -= r; + fpe_was_unmasked = erts_block_fpe(); + (*drv->output)((ErlDrvData)p->drv_data, buf, size); + erts_unblock_fpe(fpe_was_unmasked); + erts_free(ERTS_ALC_T_TMP, buf); + } + else if (r == -2) { + erts_free(ERTS_ALC_T_TMP, buf); + goto bad_value; + } + else { + ASSERT(r == -1); /* Overflow */ + erts_free(ERTS_ALC_T_TMP, buf); + if ((size = io_list_len(list)) < 0) { + goto bad_value; + } + + /* + * I know drivers that pad space with '\0' this is clearly + * incorrect but I don't feel like fixing them now, insted + * add ONE extra byte. + */ + buf = erts_alloc(ERTS_ALC_T_TMP, size+1); + r = io_list_to_buf(list, buf, size); + fpe_was_unmasked = erts_block_fpe(); + (*drv->output)((ErlDrvData)p->drv_data, buf, size); + erts_unblock_fpe(fpe_was_unmasked); + erts_free(ERTS_ALC_T_TMP, buf); + } + } + p->bytes_out += size; + erts_smp_atomic_add(&erts_bytes_out, size); + +#ifdef ERTS_SMP + if (p->xports) + erts_smp_xports_unlock(p); + ASSERT(!p->xports); +#endif + p->caller = NIL; + return 0; + + bad_value: + p->caller = NIL; + { + erts_dsprintf_buf_t *dsbufp = erts_create_logger_dsbuf(); + erts_dsprintf(dsbufp, "Bad value on output port '%s'\n", p->name); + erts_send_error_to_logger_nogl(dsbufp); + return 1; + } +} + +/* initialize the port array */ +void init_io(void) +{ + int i; + ErlDrvEntry** dp; + ErlDrvEntry* drv; + char maxports[21]; /* enough for any 64-bit integer */ + size_t maxportssize = sizeof(maxports); + Uint ports_bits = ERTS_PORTS_BITS; + Sint port_extra_shift; + +#ifdef ERTS_SMP + init_xports_list_alloc(); +#endif + + pdl_init(); + + if (erts_sys_getenv("ERL_MAX_PORTS", maxports, &maxportssize) == 0) + erts_max_ports = atoi(maxports); + else + erts_max_ports = sys_max_files(); + + if (erts_max_ports > ERTS_MAX_PORTS) + erts_max_ports = ERTS_MAX_PORTS; + if (erts_max_ports < 1024) + erts_max_ports = 1024; + + if (erts_use_r9_pids_ports) { + ports_bits = ERTS_R9_PORTS_BITS; + if (erts_max_ports > ERTS_MAX_R9_PORTS) + erts_max_ports = ERTS_MAX_R9_PORTS; + } + + port_extra_shift = erts_fit_in_bits(erts_max_ports - 1); + port_num_mask = (1 << ports_bits) - 1; + + erts_port_tab_index_mask = ~(~((Uint) 0) << port_extra_shift); + erts_max_ports = 1 << port_extra_shift; + + erts_smp_mtx_init(&erts_driver_list_lock,"driver_list"); + driver_list = NULL; + erts_smp_tsd_key_create(&driver_list_lock_status_key); + erts_smp_tsd_key_create(&driver_list_last_error_key); + + if (erts_max_ports * sizeof(Port) <= erts_max_ports) { + /* More memory needed than the whole address space. */ + erts_alloc_enomem(ERTS_ALC_T_PORT_TABLE, ~((Uint) 0)); + } + + erts_port = (Port *) erts_alloc(ERTS_ALC_T_PORT_TABLE, + erts_max_ports * sizeof(Port)); + + erts_smp_atomic_init(&erts_bytes_out, 0); + erts_smp_atomic_init(&erts_bytes_in, 0); + erts_smp_atomic_init(&erts_ports_alive, 0); + + for (i = 0; i < erts_max_ports; i++) { + erts_port_task_init_sched(&erts_port[i].sched); +#ifdef ERTS_SMP + erts_smp_atomic_init(&erts_port[i].refc, 0); + erts_port[i].lock = NULL; + erts_port[i].xports = NULL; + erts_smp_spinlock_init(&erts_port[i].state_lck, "port_state"); +#endif + erts_port[i].tracer_proc = NIL; + erts_port[i].trace_flags = 0; + + erts_port[i].drv_ptr = NULL; + erts_port[i].status = ERTS_PORT_SFLG_FREE; + erts_port[i].name = NULL; + erts_port[i].nlinks = NULL; + erts_port[i].monitors = NULL; + erts_port[i].linebuf = NULL; + erts_port[i].port_data_lock = NULL; + } + + erts_smp_atomic_init(&erts_ports_snapshot, (long) 0); + last_port_num = 0; + erts_smp_spinlock_init(&get_free_port_lck, "get_free_port"); + + sys_init_io(); + + erts_smp_tsd_set(driver_list_lock_status_key, (void *) 1); + erts_smp_mtx_lock(&erts_driver_list_lock); + + init_driver(&fd_driver, &fd_driver_entry, NULL); + init_driver(&vanilla_driver, &vanilla_driver_entry, NULL); + init_driver(&spawn_driver, &spawn_driver_entry, NULL); + for (dp = driver_tab; *dp != NULL; dp++) { + drv = *dp; + erts_add_driver_entry(*dp, NULL, 1); + } + + erts_smp_tsd_set(driver_list_lock_status_key, NULL); + erts_smp_mtx_unlock(&erts_driver_list_lock); +} + +/* + * Buffering of data when using line oriented I/O on ports + */ + +/* + * Buffer states + */ +#define LINEBUF_MAIN 0 +#define LINEBUF_FULL 1 +#define LINEBUF_CR_INSIDE 2 +#define LINEBUF_CR_AFTER 3 + +/* + * Creates a LineBuf to be added to the port structure, + * Returns: Pointer to a newly allocated and initialized LineBuf. + * Parameters: + * bufsiz - The (maximum) size of the line buffer. + */ +LineBuf *allocate_linebuf(bufsiz) +int bufsiz; +{ + int ovsiz = (bufsiz < LINEBUF_INITIAL) ? bufsiz : LINEBUF_INITIAL; + LineBuf *lb = (LineBuf *) erts_alloc(ERTS_ALC_T_LINEBUF, + sizeof(LineBuf)+ovsiz); + lb->ovsiz = ovsiz; + lb->bufsiz = bufsiz; + lb->ovlen = 0; + lb->data[0] = LINEBUF_MAIN; /* state */ + return lb; +} + +/* + * Initializes a LineBufContext to be used in calls to read_linebuf + * or flush_linebuf. + * Returns: 0 if ok, <0 on error. + * Parameters: + * lc - Pointer to an allocated LineBufContext. + * lb - Pointer to a LineBuf structure (probably from the Port structure). + * buf - A buffer containing the data to be read and split to lines. + * len - The number of bytes in buf. + */ +static int init_linebuf_context(LineBufContext *lc, LineBuf **lb, char *buf, int len) +{ + if(lc == NULL || lb == NULL) + return -1; + lc->b = lb; + lc->buf = buf; + lc->left = len; + return 0; +} + +static void resize_linebuf(LineBuf **b) +{ + int newsiz = (((*b)->ovsiz * 2) > (*b)->bufsiz) ? (*b)->bufsiz : + (*b)->ovsiz * 2; + *b = (LineBuf *) erts_realloc(ERTS_ALC_T_LINEBUF, + (void *) *b, + sizeof(LineBuf)+newsiz); + (*b)->ovsiz = newsiz; +} + +/* + * Delivers all data in the buffer regardless of newlines (always + * an LINEBUF_NOEOL. Has to be called until it return LINEBUF_EMPTY. + * Return values and barameters as read_linebuf (see below). + */ +static int flush_linebuf(LineBufContext *bp) +{ + bp->retlen = (*bp->b)->ovlen; + switch(LINEBUF_STATE(*bp)){ + case LINEBUF_CR_INSIDE: + if((*bp->b)->ovlen >= (*bp->b)->ovsiz) + resize_linebuf(bp->b); + LINEBUF_DATA(*bp)[((*bp->b)->ovlen)++] = '\r'; + ++bp->retlen; /* fall through instead of switching state... */ + case LINEBUF_MAIN: + case LINEBUF_FULL: + (*bp->b)->ovlen = 0; + LINEBUF_STATE(*bp) = LINEBUF_MAIN; + if(!bp->retlen) + return LINEBUF_EMPTY; + return LINEBUF_NOEOL; + case LINEBUF_CR_AFTER: + LINEBUF_STATE(*bp) = LINEBUF_CR_INSIDE; + (*bp->b)->ovlen = 0; + if(!bp->retlen) + return LINEBUF_EMPTY; + return LINEBUF_NOEOL; + default: + return LINEBUF_ERROR; + } +} + +/* + * Reads input from a buffer and "chops" it up in lines. + * Has to be called repeatedly until it returns LINEBUF_EMPTY + * to get all lines in buffer. + * Handles both and style newlines. + * On Unix, this is slightly incorrect, as is NOT to be regarded + * as a newline together, but i treat newlines equally in all systems + * to avoid putting this in sys.c or clutter it with #ifdef's. + * Returns: LINEBUF_EMPTY if there is no more data that can be + * determined as a line (only part of a line left), LINEBUF_EOL if a whole + * line could be delivered and LINEBUF_NOEOL if the buffer size has been + * exceeded. The data and the data length can be accesed through the + * LINEBUF_DATA and the LINEBUF_DATALEN macros applied to the LineBufContext. + * Parameters: + * bp - A LineBufContext that is initialized with + * the init_linebuf_context call. The context has to be retained during + * all calls that returns other than LINEBUF_EMPTY. When LINEBUF_EMPTY + * is returned the context can be discarded and a new can be created when new + * data arrives (the state is saved in the Port structure). + */ +static int read_linebuf(LineBufContext *bp) +{ + for(;;){ + if(bp->left == 0) + return LINEBUF_EMPTY; + if(*bp->buf == '\n'){ + LINEBUF_STATE(*bp) = LINEBUF_MAIN; + ++(bp->buf); + --(bp->left); + bp->retlen = (*bp->b)->ovlen; + (*bp->b)->ovlen = 0; + return LINEBUF_EOL; + } + switch(LINEBUF_STATE(*bp)){ + case LINEBUF_MAIN: + if((*bp->b)->ovlen == (*bp->b)->bufsiz) + LINEBUF_STATE(*bp) = LINEBUF_FULL; + else if(*bp->buf == '\r'){ + ++(bp->buf); + --(bp->left); + LINEBUF_STATE(*bp) = LINEBUF_CR_INSIDE; + } else { + if((*bp->b)->ovlen >= (*bp->b)->ovsiz) + resize_linebuf(bp->b); + LINEBUF_DATA(*bp)[((*bp->b)->ovlen)++] = *((bp->buf)++); + --(bp->left); + } + continue; + case LINEBUF_FULL: + if(*bp->buf == '\r'){ + ++(bp->buf); + --(bp->left); + LINEBUF_STATE(*bp) = LINEBUF_CR_AFTER; + } else { + bp->retlen = (*bp->b)->ovlen; + (*bp->b)->ovlen = 0; + LINEBUF_STATE(*bp) = LINEBUF_MAIN; + return LINEBUF_NOEOL; + } + continue; + case LINEBUF_CR_INSIDE: + if((*bp->b)->ovlen >= (*bp->b)->ovsiz) + resize_linebuf(bp->b); + LINEBUF_DATA(*bp)[((*bp->b)->ovlen)++] = '\r'; + LINEBUF_STATE(*bp) = LINEBUF_MAIN; + continue; + case LINEBUF_CR_AFTER: + bp->retlen = (*bp->b)->ovlen; + (*bp->b)->ovlen = 0; + LINEBUF_STATE(*bp) = LINEBUF_CR_INSIDE; + return LINEBUF_NOEOL; + default: + return LINEBUF_ERROR; + } + } +} + +static void +deliver_result(Eterm sender, Eterm pid, Eterm res) +{ + Process *rp; + ErtsProcLocks rp_locks = 0; + + ERTS_SMP_CHK_NO_PROC_LOCKS; + + ASSERT(is_internal_port(sender) + && is_internal_pid(pid) + && internal_pid_index(pid) < erts_max_processes); + + rp = erts_pid2proc_opt(NULL, 0, pid, 0, ERTS_P2P_FLG_SMP_INC_REFC); + + if (rp) { + Eterm tuple; + ErlHeapFragment *bp; + ErlOffHeap *ohp; + Eterm* hp; + Uint sz_res; + sz_res = size_object(res); + hp = erts_alloc_message_heap(sz_res + 3, &bp, &ohp, rp, &rp_locks); + res = copy_struct(res, sz_res, &hp, ohp); + tuple = TUPLE2(hp, sender, res); + erts_queue_message(rp, &rp_locks, bp, tuple, NIL); + erts_smp_proc_unlock(rp, rp_locks); + erts_smp_proc_dec_refc(rp); + } +} + + +/* + * Deliver a "read" message. + * hbuf -- byte that are always formated as a list + * hlen -- number of byte in header + * buf -- data + * len -- length of data + */ + +static void deliver_read_message(Port* prt, Eterm to, + char *hbuf, int hlen, + char *buf, int len, int eol) +{ + int need; + Eterm listp; + Eterm tuple; + Process* rp; + Eterm* hp; + ErlHeapFragment *bp; + ErlOffHeap *ohp; + ErtsProcLocks rp_locks = 0; + + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(prt)); + ERTS_SMP_CHK_NO_PROC_LOCKS; + + need = 3 + 3 + 2*hlen; + if (prt->status & ERTS_PORT_SFLG_LINEBUF_IO) { + need += 3; + } + if (prt->status & ERTS_PORT_SFLG_BINARY_IO && buf != NULL) { + need += PROC_BIN_SIZE; + } else { + need += 2*len; + } + + rp = erts_pid2proc_opt(NULL, 0, to, 0, ERTS_P2P_FLG_SMP_INC_REFC); + if (!rp) + return; + + hp = erts_alloc_message_heap(need, &bp, &ohp, rp, &rp_locks); + + listp = NIL; + if ((prt->status & ERTS_PORT_SFLG_BINARY_IO) == 0) { + listp = buf_to_intlist(&hp, buf, len, listp); + } else if (buf != NULL) { + ProcBin* pb; + Binary* bptr; + + bptr = erts_bin_nrml_alloc(len); + bptr->flags = 0; + bptr->orig_size = len; + erts_refc_init(&bptr->refc, 1); + sys_memcpy(bptr->orig_bytes, buf, len); + + pb = (ProcBin *) hp; + pb->thing_word = HEADER_PROC_BIN; + pb->size = len; + pb->next = ohp->mso; + ohp->mso = pb; + pb->val = bptr; + pb->bytes = (byte*) bptr->orig_bytes; + pb->flags = 0; + hp += PROC_BIN_SIZE; + + ohp->overhead += pb->size / sizeof(Eterm); + listp = make_binary(pb); + } + + /* Prepend the header */ + if (hlen > 0) { + listp = buf_to_intlist(&hp, hbuf, hlen, listp); + } + + if (prt->status & ERTS_PORT_SFLG_LINEBUF_IO){ + listp = TUPLE2(hp, (eol) ? am_eol : am_noeol, listp); + hp += 3; + } + tuple = TUPLE2(hp, am_data, listp); + hp += 3; + + tuple = TUPLE2(hp, prt->id, tuple); + hp += 3; + + erts_queue_message(rp, &rp_locks, bp, tuple, am_undefined); + erts_smp_proc_unlock(rp, rp_locks); + erts_smp_proc_dec_refc(rp); +} + +/* + * Deliver all lines in a line buffer, repeats calls to + * deliver_read_message, and takes the same parameters. + */ +static void deliver_linebuf_message(Port* prt, Eterm to, + char* hbuf, int hlen, + char *buf, int len) +{ + LineBufContext lc; + int ret; + if(init_linebuf_context(&lc,&(prt->linebuf), buf, len) < 0) + return; + while((ret = read_linebuf(&lc)) > LINEBUF_EMPTY) + deliver_read_message(prt, to, hbuf, hlen, LINEBUF_DATA(lc), + LINEBUF_DATALEN(lc), (ret == LINEBUF_EOL)); +} + +/* + * Deliver any nonterminated lines in the line buffer before the + * port gets closed. + * Has to be called before terminate_port. + * Parameters: + * prt - Pointer to a Port structure for this port. + */ +static void flush_linebuf_messages(Port *prt) +{ + LineBufContext lc; + int ret; + + ERTS_SMP_LC_ASSERT(!prt || erts_lc_is_port_locked(prt)); + if(prt == NULL || !(prt->status & ERTS_PORT_SFLG_LINEBUF_IO)) + return; + + if(init_linebuf_context(&lc,&(prt->linebuf), NULL, 0) < 0) + return; + while((ret = flush_linebuf(&lc)) > LINEBUF_EMPTY) + deliver_read_message(prt, + prt->connected, + NULL, + 0, + LINEBUF_DATA(lc), + LINEBUF_DATALEN(lc), + (ret == LINEBUF_EOL)); +} + +static void +deliver_vec_message(Port* prt, /* Port */ + Eterm to, /* Receiving pid */ + char* hbuf, /* "Header" buffer... */ + int hlen, /* ... and its length */ + ErlDrvBinary** binv, /* Vector of binaries */ + SysIOVec* iov, /* I/O vector */ + int vsize, /* Size of binv & iov */ + int csize) /* Size of characters in + iov (not hlen) */ +{ + int need; + Eterm listp; + Eterm tuple; + Process* rp; + Eterm* hp; + ErlHeapFragment *bp; + ErlOffHeap *ohp; + ErtsProcLocks rp_locks = 0; + + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(prt)); + ERTS_SMP_CHK_NO_PROC_LOCKS; + + /* + * Check arguments for validity. + */ + + rp = erts_pid2proc_opt(NULL, 0, to, 0, ERTS_P2P_FLG_SMP_INC_REFC); + if (!rp) + return; + + /* + * Calculate the exact number of heap words needed. + */ + + need = 3 + 3; /* Heap space for two tuples */ + if (prt->status & ERTS_PORT_SFLG_BINARY_IO) { + need += (2+PROC_BIN_SIZE)*vsize - 2 + hlen*2; + } else { + need += (hlen+csize)*2; + } + + hp = erts_alloc_message_heap(need, &bp, &ohp, rp, &rp_locks); + + listp = NIL; + iov += vsize; + + if ((prt->status & ERTS_PORT_SFLG_BINARY_IO) == 0) { + Eterm* thp = hp; + while (vsize--) { + iov--; + listp = buf_to_intlist(&thp, iov->iov_base, iov->iov_len, listp); + } + hp = thp; + } else { + binv += vsize; + while (vsize--) { + ErlDrvBinary* b; + ProcBin* pb = (ProcBin*) hp; + byte* base; + + iov--; + binv--; + if ((b = *binv) == NULL) { + b = driver_alloc_binary(iov->iov_len); + sys_memcpy(b->orig_bytes, iov->iov_base, iov->iov_len); + base = (byte*) b->orig_bytes; + } else { + /* Must increment reference count, caller calls free */ + driver_binary_inc_refc(b); + base = iov->iov_base; + } + pb->thing_word = HEADER_PROC_BIN; + pb->size = iov->iov_len; + pb->next = ohp->mso; + ohp->mso = pb; + pb->val = ErlDrvBinary2Binary(b); + pb->bytes = base; + pb->flags = 0; + hp += PROC_BIN_SIZE; + + ohp->overhead += iov->iov_len / sizeof(Eterm); + + if (listp == NIL) { /* compatible with deliver_bin_message */ + listp = make_binary(pb); + } else { + listp = CONS(hp, make_binary(pb), listp); + hp += 2; + } + } + } + + if (hlen > 0) { /* Prepend the header */ + Eterm* thp = hp; + listp = buf_to_intlist(&thp, hbuf, hlen, listp); + hp = thp; + } + + tuple = TUPLE2(hp, am_data, listp); + hp += 3; + tuple = TUPLE2(hp, prt->id, tuple); + hp += 3; + + erts_queue_message(rp, &rp_locks, bp, tuple, am_undefined); + erts_smp_proc_unlock(rp, rp_locks); + erts_smp_proc_dec_refc(rp); +} + + +static void deliver_bin_message(Port* prt, /* port */ + Eterm to, /* receiving pid */ + char* hbuf, /* "header" buffer */ + int hlen, /* and it's length */ + ErlDrvBinary* bin, /* binary data */ + int offs, /* offset into binary */ + int len) /* length of binary */ +{ + SysIOVec vec; + + vec.iov_base = bin->orig_bytes+offs; + vec.iov_len = len; + deliver_vec_message(prt, to, hbuf, hlen, &bin, &vec, 1, len); +} + +/* flush the port I/O queue and terminate if empty */ +/* + * Note. + * + * The test for (p->status & ERTS_PORT_SFLGS_DEAD) == 0 is important since the + * driver's flush function might call driver_async, which when using no + * threads and being short circuited will notice that the io queue is empty + * (after calling the driver's async_ready) and recursively call + * terminate_port. So when we get back here, the port is already terminated. + */ +static void flush_port(Port *p) +{ + int fpe_was_unmasked; + + ERTS_SMP_CHK_NO_PROC_LOCKS; + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(p)); + + if (p->drv_ptr->flush != NULL) { + if (IS_TRACED_FL(p, F_TRACE_SCHED_PORTS)) { + trace_sched_ports_where(p, am_in, am_flush); + } + fpe_was_unmasked = erts_block_fpe(); + (*p->drv_ptr->flush)((ErlDrvData)p->drv_data); + erts_unblock_fpe(fpe_was_unmasked); + if (IS_TRACED_FL(p, F_TRACE_SCHED_PORTS)) { + trace_sched_ports_where(p, am_out, am_flush); + } +#ifdef ERTS_SMP + if (p->xports) + erts_smp_xports_unlock(p); + ASSERT(!p->xports); +#endif + } + if ((p->status & ERTS_PORT_SFLGS_DEAD) == 0 && is_port_ioq_empty(p)) { + terminate_port(p); + } +} + +/* stop and delete a port that is ERTS_PORT_SFLG_CLOSING */ +static void +terminate_port(Port *prt) +{ + Eterm send_closed_port_id; + Eterm connected_id = NIL /* Initialize to silence compiler */; + erts_driver_t *drv; + + ERTS_SMP_CHK_NO_PROC_LOCKS; + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(prt)); + + ASSERT(!prt->nlinks); + ASSERT(!prt->monitors); + + if (prt->status & ERTS_PORT_SFLG_SEND_CLOSED) { + erts_port_status_band_set(prt, ~ERTS_PORT_SFLG_SEND_CLOSED); + send_closed_port_id = prt->id; + connected_id = prt->connected; + } + else { + send_closed_port_id = NIL; + } + +#ifdef ERTS_SMP + erts_cancel_smp_ptimer(prt->ptimer); +#else + erl_cancel_timer(&prt->tm); +#endif + + drv = prt->drv_ptr; + if ((drv != NULL) && (drv->stop != NULL)) { + int fpe_was_unmasked = erts_block_fpe(); + (*drv->stop)((ErlDrvData)prt->drv_data); + erts_unblock_fpe(fpe_was_unmasked); +#ifdef ERTS_SMP + if (prt->xports) + erts_smp_xports_unlock(prt); + ASSERT(!prt->xports); +#endif + } + if(drv->handle != NULL) { + erts_smp_mtx_lock(&erts_driver_list_lock); + erts_ddll_decrement_port_count(drv->handle); + erts_smp_mtx_unlock(&erts_driver_list_lock); + } + stopq(prt); /* clear queue memory */ + if(prt->linebuf != NULL){ + erts_free(ERTS_ALC_T_LINEBUF, (void *) prt->linebuf); + prt->linebuf = NULL; + } + if (prt->bp != NULL) { + free_message_buffer(prt->bp); + prt->bp = NULL; + prt->data = am_undefined; + } + + if (prt->psd) + erts_free(ERTS_ALC_T_PRTSD, prt->psd); + + kill_port(prt); + + /* + * We don't want to send the closed message until after the + * port has been removed from the port table (in kill_port()). + */ + if (is_internal_port(send_closed_port_id)) + deliver_result(send_closed_port_id, connected_id, am_closed); + + ASSERT(prt->dist_entry == NULL); +} + +void +erts_terminate_port(Port *pp) +{ + terminate_port(pp); +} + +static void sweep_one_monitor(ErtsMonitor *mon, void *vpsc) +{ + ErtsMonitor *rmon; + Process *rp; + + ASSERT(mon->type == MON_ORIGIN); + ASSERT(is_internal_pid(mon->pid)); + rp = erts_pid2proc(NULL, 0, mon->pid, ERTS_PROC_LOCK_LINK); + if (!rp) { + goto done; + } + rmon = erts_remove_monitor(&(rp->monitors),mon->ref); + erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_LINK); + if (rmon == NULL) { + goto done; + } + erts_destroy_monitor(rmon); + done: + erts_destroy_monitor(mon); +} + + + +typedef struct { + Eterm port; + Eterm reason; +} SweepContext; + +static void sweep_one_link(ErtsLink *lnk, void *vpsc) +{ + SweepContext *psc = vpsc; + DistEntry *dep; + Process *rp; + + + ASSERT(lnk->type == LINK_PID); + + if (is_external_pid(lnk->pid)) { + dep = external_pid_dist_entry(lnk->pid); + if(dep != erts_this_dist_entry) { + ErtsDistLinkData dld; + ErtsDSigData dsd; + int code; + code = erts_dsig_prepare(&dsd, dep, NULL, ERTS_DSP_NO_LOCK, 0); + switch (code) { + case ERTS_DSIG_PREP_NOT_ALIVE: + case ERTS_DSIG_PREP_NOT_CONNECTED: + break; + case ERTS_DSIG_PREP_CONNECTED: + erts_remove_dist_link(&dld, psc->port, lnk->pid, dep); + erts_destroy_dist_link(&dld); + code = erts_dsig_send_exit(&dsd, psc->port, lnk->pid, + psc->reason); + ASSERT(code == ERTS_DSIG_SEND_OK); + break; + default: + ASSERT(! "Invalid dsig prepare result"); + break; + } + } + } else { + ErtsProcLocks rp_locks = ERTS_PROC_LOCK_LINK|ERTS_PROC_LOCKS_XSIG_SEND; + ASSERT(is_internal_pid(lnk->pid)); + rp = erts_pid2proc(NULL, 0, lnk->pid, rp_locks); + if (rp) { + ErtsLink *rlnk = erts_remove_link(&(rp->nlinks), psc->port); + + if (rlnk) { + int xres = erts_send_exit_signal(NULL, + psc->port, + rp, + &rp_locks, + psc->reason, + NIL, + NULL, + 0); + if (xres >= 0 && IS_TRACED_FL(rp, F_TRACE_PROCS)) { + /* We didn't exit the process and it is traced */ + if (IS_TRACED_FL(rp, F_TRACE_PROCS)) { + trace_proc(NULL, rp, am_getting_unlinked, + psc->port); + } + } + erts_destroy_link(rlnk); + } + + erts_smp_proc_unlock(rp, rp_locks); + } + } + erts_destroy_link(lnk); +} + +/* 'from' is sending 'this_port' an exit signal, (this_port must be internal). + * If reason is normal we don't do anything, *unless* from is our connected + * process in which case we close the port. Any other reason kills the port. + * If 'from' is ourself we always die. + * When a driver has data in ioq then driver will be set to closing + * and become inaccessible to the processes. One exception exists and + * that is to kill a port till reason kill. Then the port is stopped. + * + */ +void +erts_do_exit_port(Port *p, Eterm from, Eterm reason) +{ + ErtsLink *lnk; + Eterm rreason; + + ERTS_SMP_CHK_NO_PROC_LOCKS; + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(p)); + + rreason = (reason == am_kill) ? am_killed : reason; + + if ((p->status & (ERTS_PORT_SFLGS_DEAD + | ERTS_PORT_SFLG_EXITING + | ERTS_PORT_SFLG_IMMORTAL)) + || ((reason == am_normal) && + ((from != p->connected) && (from != p->id)))) { + return; + } + + if (IS_TRACED_FL(p, F_TRACE_PORTS)) { + trace_port(p, am_closed, reason); + } + + erts_trace_check_exiting(p->id); + + /* + * Setting the port to not busy here, frees the list of pending + * processes and makes them runnable. + */ + set_busy_port((ErlDrvPort)internal_port_index(p->id), 0); + + if (p->reg != NULL) + (void) erts_unregister_name(NULL, 0, p, p->reg->name); + + erts_port_status_bor_set(p, ERTS_PORT_SFLG_EXITING); + + { + SweepContext sc = {p->id, rreason}; + lnk = p->nlinks; + p->nlinks = NULL; + erts_sweep_links(lnk, &sweep_one_link, &sc); + } + { + ErtsMonitor *moni = p->monitors; + p->monitors = NULL; + erts_sweep_monitors(moni, &sweep_one_monitor, NULL); + } + + + if ((p->status & ERTS_PORT_SFLG_DISTRIBUTION) && p->dist_entry) { + erts_do_net_exits(p->dist_entry, rreason); + erts_deref_dist_entry(p->dist_entry); + p->dist_entry = NULL; + erts_port_status_band_set(p, ~ERTS_PORT_SFLG_DISTRIBUTION); + } + + if ((reason != am_kill) && !is_port_ioq_empty(p)) { + erts_port_status_bandor_set(p, + ~ERTS_PORT_SFLG_EXITING, /* must turn it off */ + ERTS_PORT_SFLG_CLOSING); + flush_port(p); + } + else { + terminate_port(p); + } +} + +/* About the states ERTS_PORT_SFLG_EXITING and ERTS_PORT_SFLG_CLOSING used above. +** +** ERTS_PORT_SFLG_EXITING is a recursion protection for erts_do_exit_port(). +** It is unclear whether this state is necessary or not, it might be possible +** to merge it with ERTS_PORT_SFLG_CLOSING. ERTS_PORT_SFLG_EXITING only persists +** over a section of sequential (but highly recursive) code. +** +** ERTS_PORT_SFLG_CLOSING is a state where the port is in Limbo, waiting to +** pass on. All links are removed, and the port receives in/out-put events so +** as soon as the port queue gets empty terminate_port() is called. +*/ + + + +/* Command should be of the form +** {PID, close} +** {PID, {command, io-list}} +** {PID, {connect, New_PID}} +** +** +*/ +void erts_port_command(Process *proc, + Eterm caller_id, + Port *port, + Eterm command) +{ + Eterm *tp; + Eterm pid; + + if (!port) + return; + + erts_smp_proc_unlock(proc, ERTS_PROC_LOCK_MAIN); + ERTS_SMP_CHK_NO_PROC_LOCKS; + ASSERT(!INVALID_PORT(port, port->id)); + + if (is_tuple_arity(command, 2)) { + tp = tuple_val(command); + if ((pid = port->connected) == tp[1]) { + /* PID must be connected */ + if (tp[2] == am_close) { + erts_port_status_bor_set(port, ERTS_PORT_SFLG_SEND_CLOSED); + erts_do_exit_port(port, pid, am_normal); + goto done; + } else if (is_tuple_arity(tp[2], 2)) { + tp = tuple_val(tp[2]); + if (tp[1] == am_command) { + if (erts_write_to_port(caller_id, port, tp[2]) == 0) + goto done; + } else if ((tp[1] == am_connect) && is_internal_pid(tp[2])) { + port->connected = tp[2]; + deliver_result(port->id, pid, am_connected); + goto done; + } + } + } + } + + { + ErtsProcLocks rp_locks = ERTS_PROC_LOCKS_XSIG_SEND; + Process* rp = erts_pid2proc_opt(NULL, 0, + port->connected, rp_locks, + ERTS_P2P_FLG_SMP_INC_REFC); + if (rp) { + (void) erts_send_exit_signal(NULL, + port->id, + rp, + &rp_locks, + am_badsig, + NIL, + NULL, + 0); + erts_smp_proc_unlock(rp, rp_locks); + erts_smp_proc_dec_refc(rp); + } + + } + done: + erts_smp_proc_lock(proc, ERTS_PROC_LOCK_MAIN); +} + +/* + * Control a port synchronously. + * Returns either a list or a binary. + */ +Eterm +erts_port_control(Process* p, Port* prt, Uint command, Eterm iolist) +{ + byte* to_port = NULL; /* Buffer to write to port. */ + /* Initialization is for shutting up + warning about use before set. */ + int to_len = 0; /* Length of buffer. */ + int must_free = 0; /* True if the buffer should be freed. */ + char port_result[ERL_ONHEAP_BIN_LIMIT]; /* Default buffer for result from port. */ + char* port_resp; /* Pointer to result buffer. */ + int n; + int (*control)(ErlDrvData, unsigned, char*, int, char**, int); + int fpe_was_unmasked; + + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(prt)); + + if ((control = prt->drv_ptr->control) == NULL) { + return THE_NON_VALUE; + } + + /* + * Convert the iolist to a buffer, pointed to by to_port, + * and with its length in to_len. + */ + if (is_binary(iolist) && binary_bitoffset(iolist) == 0) { + Uint bitoffs; + Uint bitsize; + ERTS_GET_BINARY_BYTES(iolist, to_port, bitoffs, bitsize); + to_len = binary_size(iolist); + } else { + int r; + + /* Try with an 8KB buffer first (will often be enough I guess). */ + to_len = 8*1024; + to_port = erts_alloc(ERTS_ALC_T_TMP, to_len); + must_free = 1; + + /* + * In versions before R10B, we used to reserve random + * amounts of extra memory. From R10B, we allocate the + * exact amount. + */ + r = io_list_to_buf(iolist, (char*) to_port, to_len); + if (r >= 0) { + to_len -= r; + } else if (r == -2) { /* Type error */ + erts_free(ERTS_ALC_T_TMP, (void *) to_port); + return THE_NON_VALUE; + } else { + ASSERT(r == -1); /* Overflow */ + erts_free(ERTS_ALC_T_TMP, (void *) to_port); + if ((to_len = io_list_len(iolist)) < 0) { /* Type error */ + return THE_NON_VALUE; + } + must_free = 1; + to_port = erts_alloc(ERTS_ALC_T_TMP, to_len); + r = io_list_to_buf(iolist, (char*) to_port, to_len); + ASSERT(r == 0); + } + } + + prt->caller = p->id; /* Internal pid */ + + erts_smp_proc_unlock(p, ERTS_PROC_LOCK_MAIN); + ERTS_SMP_CHK_NO_PROC_LOCKS; + + /* + * Call the port's control routine. + */ + + port_resp = port_result; + fpe_was_unmasked = erts_block_fpe(); + n = control((ErlDrvData)prt->drv_data, command, (char*)to_port, to_len, + &port_resp, sizeof(port_result)); + erts_unblock_fpe(fpe_was_unmasked); + if (must_free) { + erts_free(ERTS_ALC_T_TMP, (void *) to_port); + } + prt->caller = NIL; +#ifdef ERTS_SMP + if (prt->xports) + erts_smp_xports_unlock(prt); + ASSERT(!prt->xports); +#endif + + erts_smp_proc_lock(p, ERTS_PROC_LOCK_MAIN); + /* + * Handle the result. + */ + + if (n < 0) { + return THE_NON_VALUE; + } + + if ((prt->control_flags & PORT_CONTROL_FLAG_BINARY) == 0) { /* List result */ + Eterm ret; + Eterm* hp = HAlloc(p, 2*n); + ret = buf_to_intlist(&hp, port_resp, n, NIL); + if (port_resp != port_result) { + driver_free(port_resp); + } + return ret; + } + else if (port_resp == NULL) { + return NIL; + } + else { /* Binary result */ + ErlDrvBinary *dbin; + ErlHeapBin *hbin; + if (port_resp != port_result) { + dbin = (ErlDrvBinary *) port_resp; + if (dbin->orig_size > ERL_ONHEAP_BIN_LIMIT) { + ProcBin* pb = (ProcBin *) HAlloc(p, PROC_BIN_SIZE); + pb->thing_word = HEADER_PROC_BIN; + pb->size = dbin->orig_size; + pb->next = MSO(p).mso; + MSO(p).mso = pb; + pb->val = ErlDrvBinary2Binary(dbin); + pb->bytes = (byte*) dbin->orig_bytes; + pb->flags = 0; + MSO(p).overhead += dbin->orig_size / sizeof(Eterm); + return make_binary(pb); + } + port_resp = dbin->orig_bytes; + n = dbin->orig_size; + } else { + dbin = NULL; + } + hbin = (ErlHeapBin*) HAlloc(p, heap_bin_size(n)); + ASSERT(n <= ERL_ONHEAP_BIN_LIMIT); + hbin->thing_word = header_heap_bin(n); + hbin->size = n; + sys_memcpy(hbin->data, port_resp, n); + if (dbin != NULL) { + driver_free_binary(dbin); + } + return make_binary(hbin); + } +} + +typedef struct { + int to; + void *arg; +} prt_one_lnk_data; + +static void prt_one_monitor(ErtsMonitor *mon, void *vprtd) +{ + prt_one_lnk_data *prtd = (prt_one_lnk_data *) vprtd; + erts_print(prtd->to, prtd->arg, "(%T,%T)", mon->pid,mon->ref); +} + +static void prt_one_lnk(ErtsLink *lnk, void *vprtd) +{ + prt_one_lnk_data *prtd = (prt_one_lnk_data *) vprtd; + erts_print(prtd->to, prtd->arg, "%T", lnk->pid); +} + +void +print_port_info(int to, void *arg, int i) +{ + Port* p = &erts_port[i]; + + if (p->status & ERTS_PORT_SFLGS_DEAD) + return; + + erts_print(to, arg, "=port:%T\n", p->id); + erts_print(to, arg, "Slot: %d\n", i); + if (p->status & ERTS_PORT_SFLG_CONNECTED) { + erts_print(to, arg, "Connected: %T", p->connected); + erts_print(to, arg, "\n"); + } + + if (p->nlinks != NULL) { + prt_one_lnk_data prtd; + prtd.to = to; + prtd.arg = arg; + erts_print(to, arg, "Links: "); + erts_doforall_links(p->nlinks, &prt_one_lnk, &prtd); + erts_print(to, arg, "\n"); + } + if (p->monitors != NULL) { + prt_one_lnk_data prtd; + prtd.to = to; + prtd.arg = arg; + erts_print(to, arg, "Monitors: "); + erts_doforall_monitors(p->monitors, &prt_one_monitor, &prtd); + erts_print(to, arg, "\n"); + } + + if (p->reg != NULL) + erts_print(to, arg, "Registered as: %T\n", p->reg->name); + + if (p->drv_ptr == &fd_driver) { + erts_print(to, arg, "Port is UNIX fd not opened by emulator: %s\n", p->name); + } else if (p->drv_ptr == &vanilla_driver) { + erts_print(to, arg, "Port is a file: %s\n",p->name); + } else if (p->drv_ptr == &spawn_driver) { + erts_print(to, arg, "Port controls external process: %s\n",p->name); + } else { + erts_print(to, arg, "Port controls linked-in driver: %s\n",p->name); + } +} + +void +set_busy_port(ErlDrvPort port_num, int on) +{ + ERTS_SMP_CHK_NO_PROC_LOCKS; + + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(&erts_port[port_num])); + + if (on) { + erts_port_status_bor_set(&erts_port[port_num], + ERTS_PORT_SFLG_PORT_BUSY); + } else { + ErtsProcList* plp = erts_port[port_num].suspended; + erts_port_status_band_set(&erts_port[port_num], + ~ERTS_PORT_SFLG_PORT_BUSY); + erts_port[port_num].suspended = NULL; + + if (erts_port[port_num].dist_entry) { + /* + * Processes suspended on distribution ports are + * normally queued on the dist entry. + */ + erts_dist_port_not_busy(&erts_port[port_num]); + } + + /* + * Resume, in a round-robin fashion, all processes waiting on the port. + * + * This version submitted by Tony Rogvall. The earlier version used + * to resume the processes in order, which caused starvation of all but + * the first process. + */ + + if (plp) { + /* First proc should be resumed last */ + if (plp->next) { + erts_resume_processes(plp->next); + plp->next = NULL; + } + erts_resume_processes(plp); + } + } +} + +void set_port_control_flags(ErlDrvPort port_num, int flags) +{ + + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(&erts_port[port_num])); + + erts_port[port_num].control_flags = flags; +} + +int get_port_flags(ErlDrvPort ix) { + Port* prt = erts_drvport2port(ix); + + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(prt)); + + if (prt == NULL) + return 0; + + return (prt->status & ERTS_PORT_SFLG_BINARY_IO ? PORT_FLAG_BINARY : 0) + | (prt->status & ERTS_PORT_SFLG_LINEBUF_IO ? PORT_FLAG_LINE : 0); +} + + +void erts_raw_port_command(Port* p, byte* buf, Uint len) +{ + int fpe_was_unmasked; + + ERTS_SMP_CHK_NO_PROC_LOCKS; + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(p)); + + if (len > (Uint) INT_MAX) + erl_exit(ERTS_ABORT_EXIT, + "Absurdly large data buffer (%bpu bytes) passed to" + "output callback of %s driver.\n", + len, + p->drv_ptr->name ? p->drv_ptr->name : "unknown"); + + p->caller = NIL; + fpe_was_unmasked = erts_block_fpe(); + (*p->drv_ptr->output)((ErlDrvData)p->drv_data, (char*) buf, (int) len); + erts_unblock_fpe(fpe_was_unmasked); +} + +int async_ready(Port *p, void* data) +{ + int need_free = 1; + + ERTS_SMP_CHK_NO_PROC_LOCKS; + + if (p) { + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(p)); + ASSERT(!(p->status & ERTS_PORT_SFLGS_DEAD)); + if (p->drv_ptr->ready_async != NULL) { + (*p->drv_ptr->ready_async)((ErlDrvData)p->drv_data, data); + need_free = 0; +#ifdef ERTS_SMP + if (p->xports) + erts_smp_xports_unlock(p); + ASSERT(!p->xports); +#endif + } + if ((p->status & ERTS_PORT_SFLG_CLOSING) && is_port_ioq_empty(p)) { + terminate_port(p); + } + } + return need_free; +} + +static void +report_missing_drv_callback(Port *p, char *drv_type, char *callback) +{ + ErtsPortNames *pnp = erts_get_port_names(p->id); + char *unknown = ""; + char *drv_name = pnp->driver_name ? pnp->driver_name : unknown; + char *prt_name = pnp->name ? pnp->name : unknown; + erts_dsprintf_buf_t *dsbufp = erts_create_logger_dsbuf(); + erts_dsprintf(dsbufp, "%T: %s driver '%s' ", p->id, drv_type, drv_name); + if (sys_strcmp(drv_name, prt_name) != 0) + erts_dsprintf(dsbufp, "(%s) ", prt_name); + erts_dsprintf(dsbufp, "does not implement the %s callback!\n", callback); + erts_free_port_names(pnp); + erts_send_error_to_logger_nogl(dsbufp); +} + +void +erts_stale_drv_select(Eterm port, + ErlDrvEvent hndl, + int mode, + int deselect) +{ + char *type; + ErlDrvPort drv_port = internal_port_index(port); + ErtsPortNames *pnp = erts_get_port_names(port); + erts_dsprintf_buf_t *dsbufp; + + switch (mode) { + case ERL_DRV_READ | ERL_DRV_WRITE: + type = "Input/Output"; + goto deselect; + case ERL_DRV_WRITE: + type = "Output"; + goto deselect; + case ERL_DRV_READ: + type = "Input"; + deselect: + if (deselect) { + driver_select(drv_port, hndl, + mode | ERL_DRV_USE_NO_CALLBACK, + 0); + } + break; + default: + type = "Event"; + if (deselect) + driver_event(drv_port, hndl, NULL); + break; + } + + dsbufp = erts_create_logger_dsbuf(); + erts_dsprintf(dsbufp, + "%T: %s: %s driver gone away without deselecting!\n", + port, + pnp->name ? pnp->name : "", + type); + erts_free_port_names(pnp); + erts_send_error_to_logger_nogl(dsbufp); +} + +ErtsPortNames * +erts_get_port_names(Eterm id) +{ + ErtsPortNames *pnp; + ASSERT(is_nil(id) || is_internal_port(id)); + + if (is_not_internal_port(id)) { + pnp = erts_alloc(ERTS_ALC_T_PORT_NAMES, sizeof(ErtsPortNames)); + pnp->name = NULL; + pnp->driver_name = NULL; + } + else { + Port* prt = &erts_port[internal_port_index(id)]; + int do_realloc = 1; + int len = -1; + size_t pnp_len = sizeof(ErtsPortNames); +#ifndef DEBUG + pnp_len += 100; /* In most cases 100 characters will be enough... */ +#endif + pnp = erts_alloc(ERTS_ALC_T_PORT_NAMES, pnp_len); + do { + int nlen; + char *name, *driver_name; + if (len > 0) { + erts_free(ERTS_ALC_T_PORT_NAMES, pnp); + pnp_len = sizeof(ErtsPortNames) + len; + pnp = erts_alloc(ERTS_ALC_T_PORT_NAMES, pnp_len); + } + erts_smp_port_state_lock(prt); + if (id != prt->id) { + len = nlen = 0; + name = driver_name = NULL; + } + else { + name = prt->name; + len = nlen = name ? sys_strlen(name) + 1 : 0; + driver_name = (prt->drv_ptr ? prt->drv_ptr->name : NULL); + len += driver_name ? sys_strlen(driver_name) + 1 : 0; + } + if (len <= pnp_len - sizeof(ErtsPortNames)) { + if (!name) + pnp->name = NULL; + else { + pnp->name = ((char *) pnp) + sizeof(ErtsPortNames); + sys_strcpy(pnp->name, name); + } + if (!driver_name) + pnp->driver_name = NULL; + else { + pnp->driver_name = (((char *) pnp) + + sizeof(ErtsPortNames) + + nlen); + sys_strcpy(pnp->driver_name, driver_name); + } + do_realloc = 0; + } + erts_smp_port_state_unlock(prt); + } while (do_realloc); + } + return pnp; +} + +void +erts_free_port_names(ErtsPortNames *pnp) +{ + erts_free(ERTS_ALC_T_PORT_NAMES, pnp); +} + +static void schedule_port_timeout(Port *p) +{ + /* + * Scheduling of port timeouts can be done without port locking, but + * since the task handle is stored in the port structure and the ptimer + * structure is protected by the port lock we require the port to be + * locked for now... + * + * TODO: Implement scheduling of port timeouts without locking + * the port. + * /Rickard + */ + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(p)); + (void) erts_port_task_schedule(p->id, + &p->timeout_task, + ERTS_PORT_TASK_TIMEOUT, + (ErlDrvEvent) -1, + NULL); +} + +ErlDrvTermData driver_mk_term_nil(void) +{ + return driver_term_nil; +} + +void driver_report_exit(int ix, int status) +{ + Port* prt = erts_drvport2port(ix); + Eterm* hp; + Eterm tuple; + Process *rp; + Eterm pid; + ErlHeapFragment *bp = NULL; + ErlOffHeap *ohp; + ErtsProcLocks rp_locks = 0; + + ERTS_SMP_CHK_NO_PROC_LOCKS; + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(prt)); + + pid = prt->connected; + ASSERT(is_internal_pid(pid)); + rp = erts_pid2proc_opt(NULL, 0, pid, 0, ERTS_P2P_FLG_SMP_INC_REFC); + if (!rp) + return; + + hp = erts_alloc_message_heap(3+3, &bp, &ohp, rp, &rp_locks); + + tuple = TUPLE2(hp, am_exit_status, make_small(status)); + hp += 3; + tuple = TUPLE2(hp, prt->id, tuple); + + erts_queue_message(rp, &rp_locks, bp, tuple, am_undefined); + + erts_smp_proc_unlock(rp, rp_locks); + erts_smp_proc_dec_refc(rp); +} + + +static ERTS_INLINE int +deliver_term_check_port(ErlDrvPort drvport) +{ + int res; + int ix = (int) drvport; + if (ix < 0 || erts_max_ports <= ix) + res = -1; /* invalid */ + else { + Port* prt = &erts_port[ix]; + erts_smp_port_state_lock(prt); + if (!(prt->status & ERTS_PORT_SFLGS_INVALID_LOOKUP)) + res = 1; /* ok */ + else if (prt->status & ERTS_PORT_SFLG_CLOSING) + res = 0; /* closing */ + else + res = -1; /* invalid (dead) */ + erts_smp_port_state_unlock(prt); + } + return res; +} + +#define ERTS_B2T_STATES_DEF_STATES_SZ 5 +#define ERTS_B2T_STATES_DEF_STATES_INC 100 + +struct b2t_states__ { + int len; + int ix; + int used; + ErtsBinary2TermState *state; + ErtsBinary2TermState def_states[ERTS_B2T_STATES_DEF_STATES_SZ]; +#ifdef DEBUG + byte **org_ext; + byte *def_org_ext[ERTS_B2T_STATES_DEF_STATES_SZ]; +#endif +}; + +static ERTS_INLINE void +init_b2t_states(struct b2t_states__ *b2tsp) +{ + b2tsp->len = ERTS_B2T_STATES_DEF_STATES_SZ; + b2tsp->ix = 0; + b2tsp->used = 0; + b2tsp->state = &b2tsp->def_states[0]; +#ifdef DEBUG + b2tsp->org_ext = &b2tsp->def_org_ext[0]; +#endif +} + +static ERTS_INLINE void +grow_b2t_states(struct b2t_states__ *b2tsp) +{ + if (b2tsp->state != &b2tsp->def_states[0]) { + b2tsp->len += ERTS_B2T_STATES_DEF_STATES_INC; + b2tsp->state = erts_realloc(ERTS_ALC_T_TMP, + b2tsp->state, + sizeof(ErtsBinary2TermState)*b2tsp->len); +#ifdef DEBUG + b2tsp->org_ext = erts_realloc(ERTS_ALC_T_TMP, + b2tsp->org_ext, + sizeof(char *)*b2tsp->len); +#endif + } + else { + ErtsBinary2TermState *new_states; + new_states = erts_alloc(ERTS_ALC_T_TMP, + (sizeof(ErtsBinary2TermState) + *ERTS_B2T_STATES_DEF_STATES_INC)); + sys_memcpy((void *) new_states, + (void *) b2tsp->state, + sizeof(ErtsBinary2TermState)*ERTS_B2T_STATES_DEF_STATES_SZ); + b2tsp->state = new_states; + b2tsp->len = ERTS_B2T_STATES_DEF_STATES_INC; +#ifdef DEBUG + { + byte **new_org_ext = erts_alloc(ERTS_ALC_T_TMP, + (sizeof(char *) + *ERTS_B2T_STATES_DEF_STATES_INC)); + sys_memcpy((void *) new_org_ext, + (void *) b2tsp->org_ext, + sizeof(char *)*ERTS_B2T_STATES_DEF_STATES_SZ); + b2tsp->org_ext = new_org_ext; + } +#endif + } +} + +static ERTS_INLINE void +cleanup_b2t_states(struct b2t_states__ *b2tsp) +{ + if (b2tsp->state != &b2tsp->def_states[0]) { + erts_free(ERTS_ALC_T_TMP, b2tsp->state); +#ifdef DEBUG + erts_free(ERTS_ALC_T_TMP, b2tsp->org_ext); +#endif + } +} + + +/* + * Generate an Erlang term from data in an array (representing a simple stack + * machine to build terms). + * Returns: + * -1 on error in input data + * 0 if the message was not delivered (bad to pid or closed port) + * 1 if the message was delivered successfully + */ + +static int +driver_deliver_term(ErlDrvPort port, + Eterm to, + ErlDrvTermData* data, + int len) +{ +#define ERTS_DDT_FAIL do { res = -1; goto done; } while (0) + Uint need = 0; + int depth = 0; + int res; + Eterm *hp = NULL, *hp_start = NULL, *hp_end = NULL; + ErlDrvTermData* ptr; + ErlDrvTermData* ptr_end; + DECLARE_ESTACK(stack); + Eterm mess = NIL; /* keeps compiler happy */ + Process* rp = NULL; + ErlHeapFragment *bp = NULL; + ErlOffHeap *ohp; + ErtsProcLocks rp_locks = 0; + struct b2t_states__ b2t; + + init_b2t_states(&b2t); + + /* + * We used to check port and process here. In the SMP enabled emulator, + * however, we don't want to that until we have verified the term. + */ + + /* + * Check ErlDrvTermData for consistency and calculate needed heap size + * and stack depth. + */ + ptr = data; + ptr_end = ptr + len; + + while (ptr < ptr_end) { + ErlDrvTermData tag = *ptr++; + +#define ERTS_DDT_CHK_ENOUGH_ARGS(NEED) \ + if (ptr+((NEED)-1) >= ptr_end) ERTS_DDT_FAIL; + + switch(tag) { + case ERL_DRV_NIL: /* no arguments */ + depth++; + break; + case ERL_DRV_ATOM: /* atom argument */ + ERTS_DDT_CHK_ENOUGH_ARGS(1); + if (is_not_atom(ptr[0])) ERTS_DDT_FAIL; + ptr++; + depth++; + break; + case ERL_DRV_INT: /* signed int argument */ + ERTS_DDT_CHK_ENOUGH_ARGS(1); + /* check for bignum */ + if (!IS_SSMALL((Sint)ptr[0])) + need += BIG_UINT_HEAP_SIZE; /* use small_to_big */ + ptr++; + depth++; + break; + case ERL_DRV_UINT: /* unsigned int argument */ + ERTS_DDT_CHK_ENOUGH_ARGS(1); + /* check for bignum */ + if (!IS_USMALL(0, (Uint)ptr[0])) + need += BIG_UINT_HEAP_SIZE; /* use small_to_big */ + ptr++; + depth++; + break; + case ERL_DRV_INT64: /* pointer to signed 64-bit int argument */ + ERTS_DDT_CHK_ENOUGH_ARGS(1); + erts_bld_sint64(NULL, &need, *((Sint64 *) ptr[0])); + ptr++; + depth++; + break; + case ERL_DRV_UINT64: /* pointer to unsigned 64-bit int argument */ + ERTS_DDT_CHK_ENOUGH_ARGS(1); + erts_bld_uint64(NULL, &need, *((Uint64 *) ptr[0])); + ptr++; + depth++; + break; + case ERL_DRV_PORT: /* port argument */ + ERTS_DDT_CHK_ENOUGH_ARGS(1); + if (is_not_internal_port(ptr[0])) ERTS_DDT_FAIL; + ptr++; + depth++; + break; + case ERL_DRV_BINARY: { /* ErlDrvBinary*, size, offs */ + ErlDrvBinary* b; + Uint size; + Uint offset; + ERTS_DDT_CHK_ENOUGH_ARGS(3); + b = (ErlDrvBinary*) ptr[0]; + size = ptr[1]; + offset = ptr[2]; + if (!b || size + offset > b->orig_size) + ERTS_DDT_FAIL; /* No binary or outside the binary */ + need += (size <= ERL_ONHEAP_BIN_LIMIT + ? heap_bin_size(size) + : PROC_BIN_SIZE); + ptr += 3; + depth++; + break; + } + case ERL_DRV_BUF2BINARY: { /* char*, size */ + byte *bufp; + Uint size; + ERTS_DDT_CHK_ENOUGH_ARGS(2); + bufp = (byte *) ptr[0]; + size = (Uint) ptr[1]; + if (!bufp && size > 0) ERTS_DDT_FAIL; + need += (size <= ERL_ONHEAP_BIN_LIMIT + ? heap_bin_size(size) + : PROC_BIN_SIZE); + ptr += 2; + depth++; + break; + } + case ERL_DRV_STRING: /* char*, length */ + ERTS_DDT_CHK_ENOUGH_ARGS(2); + if ((char *) ptr[0] == NULL || (int) ptr[1] < 0) ERTS_DDT_FAIL; + need += ptr[1] * 2; + ptr += 2; + depth++; + break; + case ERL_DRV_STRING_CONS: /* char*, length */ + ERTS_DDT_CHK_ENOUGH_ARGS(2); + if ((char *) ptr[0] == NULL || (int) ptr[1] < 0) ERTS_DDT_FAIL; + need += ptr[1] * 2; + if (depth < 1) ERTS_DDT_FAIL; + ptr += 2; + break; + case ERL_DRV_LIST: /* int */ + ERTS_DDT_CHK_ENOUGH_ARGS(1); + if ((int) ptr[0] <= 0) ERTS_DDT_FAIL; + need += (ptr[0]-1)*2; /* list cells */ + depth -= ptr[0]; + if (depth < 0) ERTS_DDT_FAIL; + ptr++; + depth++; + break; + case ERL_DRV_TUPLE: { /* int */ + ERTS_DDT_CHK_ENOUGH_ARGS(1); + if ((int) ptr[0] < 0) ERTS_DDT_FAIL; + need += ptr[0]+1; /* vector positions + arityval */ + depth -= ptr[0]; + if (depth < 0) ERTS_DDT_FAIL; + ptr++; + depth++; + break; + } + case ERL_DRV_PID: /* pid argument */ + ERTS_DDT_CHK_ENOUGH_ARGS(1); + if (is_not_internal_pid(ptr[0])) ERTS_DDT_FAIL; + ptr++; + depth++; + break; + case ERL_DRV_FLOAT: /* double * */ + ERTS_DDT_CHK_ENOUGH_ARGS(1); + need += FLOAT_SIZE_OBJECT; + ptr++; + depth++; + break; + case ERL_DRV_EXT2TERM: { /* char *ext, int size */ + byte* ext; + Sint size; + Sint hsz; + + ERTS_DDT_CHK_ENOUGH_ARGS(2); + ext = (byte *) ptr[0]; + size = (Sint) ptr[1]; + if (!ext || size <= 0) + ERTS_DDT_FAIL; + if (b2t.len <= b2t.ix) + grow_b2t_states(&b2t); +#ifdef DEBUG + b2t.org_ext[b2t.ix] = ext; +#endif + hsz = erts_binary2term_prepare(&b2t.state[b2t.ix++], ext, size); + if (hsz < 0) + ERTS_DDT_FAIL; /* Invalid data */ + need += hsz; + ptr += 2; + depth++; + break; + } + default: + ERTS_DDT_FAIL; + } +#undef ERTS_DDT_CHK_ENOUGH_ARGS + } + + if ((depth != 1) || (ptr != ptr_end)) + ERTS_DDT_FAIL; + + b2t.used = b2t.ix; + b2t.ix = 0; + + /* + * The term is OK. Go ahead and validate the port and process. + */ + res = deliver_term_check_port(port); + if (res <= 0) + goto done; + + rp = erts_pid2proc_opt(NULL, 0, to, rp_locks, ERTS_P2P_FLG_SMP_INC_REFC); + if (!rp) { + res = 0; + goto done; + } + + hp_start = hp = erts_alloc_message_heap(need, &bp, &ohp, rp, &rp_locks); + hp_end = hp + need; + + /* + * Interpret the instructions and build the term. + */ + ptr = data; + while (ptr < ptr_end) { + ErlDrvTermData tag = *ptr++; + + switch(tag) { + case ERL_DRV_NIL: /* no arguments */ + mess = NIL; + break; + + case ERL_DRV_ATOM: /* atom argument */ + mess = ptr[0]; + ptr++; + break; + + case ERL_DRV_INT: /* signed int argument */ + if (IS_SSMALL((Sint)ptr[0])) + mess = make_small((Sint)ptr[0]); + else { + mess = small_to_big((Sint)ptr[0], hp); + hp += BIG_UINT_HEAP_SIZE; + } + ptr++; + break; + + case ERL_DRV_UINT: /* unsigned int argument */ + if (IS_USMALL(0, (Uint)ptr[0])) + mess = make_small((Uint)ptr[0]); + else { + mess = uint_to_big((Uint)ptr[0], hp); + hp += BIG_UINT_HEAP_SIZE; + } + ptr++; + break; + + case ERL_DRV_INT64: /* pointer to unsigned 64-bit int argument */ + mess = erts_bld_sint64(&hp, NULL, *((Sint64 *) ptr[0])); + ptr++; + break; + + case ERL_DRV_UINT64: /* pointer to unsigned 64-bit int argument */ + mess = erts_bld_uint64(&hp, NULL, *((Uint64 *) ptr[0])); + ptr++; + break; + + case ERL_DRV_PORT: /* port argument */ + mess = ptr[0]; + ptr++; + break; + + case ERL_DRV_BINARY: { /* ErlDrvBinary*, size, offs */ + ErlDrvBinary* b = (ErlDrvBinary*) ptr[0]; + Uint size = ptr[1]; + Uint offset = ptr[2]; + + if (size <= ERL_ONHEAP_BIN_LIMIT) { + ErlHeapBin* hbp = (ErlHeapBin *) hp; + hp += heap_bin_size(size); + hbp->thing_word = header_heap_bin(size); + hbp->size = size; + if (size > 0) { + sys_memcpy((void *) hbp->data, (void *) (((byte*) b->orig_bytes) + offset), size); + } + mess = make_binary(hbp); + } + else { + ProcBin* pb = (ProcBin *) hp; + driver_binary_inc_refc(b); /* caller will free binary */ + pb->thing_word = HEADER_PROC_BIN; + pb->size = size; + pb->next = ohp->mso; + ohp->mso = pb; + pb->val = ErlDrvBinary2Binary(b); + pb->bytes = ((byte*) b->orig_bytes) + offset; + pb->flags = 0; + mess = make_binary(pb); + hp += PROC_BIN_SIZE; + ohp->overhead += pb->size / sizeof(Eterm); + } + ptr += 3; + break; + } + + case ERL_DRV_BUF2BINARY: { /* char*, size */ + byte *bufp = (byte *) ptr[0]; + Uint size = (Uint) ptr[1]; + if (size <= ERL_ONHEAP_BIN_LIMIT) { + ErlHeapBin* hbp = (ErlHeapBin *) hp; + hp += heap_bin_size(size); + hbp->thing_word = header_heap_bin(size); + hbp->size = size; + if (size > 0) { + ASSERT(bufp); + sys_memcpy((void *) hbp->data, (void *) bufp, size); + } + mess = make_binary(hbp); + } + else { + ProcBin* pbp; + Binary* bp = erts_bin_nrml_alloc(size); + ASSERT(bufp); + bp->flags = 0; + bp->orig_size = (long) size; + erts_refc_init(&bp->refc, 1); + sys_memcpy((void *) bp->orig_bytes, (void *) bufp, size); + pbp = (ProcBin *) hp; + hp += PROC_BIN_SIZE; + pbp->thing_word = HEADER_PROC_BIN; + pbp->size = size; + pbp->next = ohp->mso; + ohp->mso = pbp; + pbp->val = bp; + pbp->bytes = (byte*) bp->orig_bytes; + pbp->flags = 0; + ohp->overhead += (pbp->size / sizeof(Eterm)); + mess = make_binary(pbp); + } + ptr += 2; + break; + } + + case ERL_DRV_STRING: /* char*, length */ + mess = buf_to_intlist(&hp, (char*)ptr[0], ptr[1], NIL); + ptr += 2; + break; + + case ERL_DRV_STRING_CONS: /* char*, length */ + mess = ESTACK_POP(stack); + mess = buf_to_intlist(&hp, (char*)ptr[0], ptr[1], mess); + ptr += 2; + break; + + case ERL_DRV_LIST: { /* unsigned */ + Uint i = (int) ptr[0]; /* i > 0 */ + + mess = ESTACK_POP(stack); + i--; + while(i > 0) { + Eterm hd = ESTACK_POP(stack); + + mess = CONS(hp, hd, mess); + hp += 2; + i--; + } + ptr++; + break; + } + + case ERL_DRV_TUPLE: { /* int */ + int size = (int)ptr[0]; + Eterm* tp = hp; + + *tp = make_arityval(size); + mess = make_tuple(tp); + + tp += size; /* point at last element */ + hp = tp+1; /* advance "heap" pointer */ + + while(size--) { + *tp-- = ESTACK_POP(stack); + } + ptr++; + break; + } + + case ERL_DRV_PID: /* pid argument */ + mess = ptr[0]; + ptr++; + break; + + case ERL_DRV_FLOAT: { /* double * */ + FloatDef f; + + mess = make_float(hp); + f.fd = *((double *) ptr[0]); + PUT_DOUBLE(f, hp); + hp += FLOAT_SIZE_OBJECT; + ptr++; + break; + } + + case ERL_DRV_EXT2TERM: /* char *ext, int size */ + ASSERT(b2t.org_ext[b2t.ix] == (byte *) ptr[0]); + mess = erts_binary2term_create(&b2t.state[b2t.ix++], &hp, ohp); + if (mess == THE_NON_VALUE) + ERTS_DDT_FAIL; + ptr += 2; + break; + + } + ESTACK_PUSH(stack, mess); + } + + res = 1; + + done: + + if (res > 0) { + mess = ESTACK_POP(stack); /* get resulting value */ + if (bp) + bp = erts_resize_message_buffer(bp, hp - hp_start, &mess, 1); + else { + ASSERT(hp); + HRelease(rp, hp_end, hp); + } + /* send message */ + erts_queue_message(rp, &rp_locks, bp, mess, am_undefined); + } + else { + if (b2t.ix > b2t.used) + b2t.used = b2t.ix; + for (b2t.ix = 0; b2t.ix < b2t.used; b2t.ix++) + erts_binary2term_abort(&b2t.state[b2t.ix]); + if (bp) + free_message_buffer(bp); + else if (hp) { + HRelease(rp, hp_end, hp); + } + } +#ifdef ERTS_SMP + if (rp) { + if (rp_locks) + erts_smp_proc_unlock(rp, rp_locks); + erts_smp_proc_dec_refc(rp); + } +#endif + cleanup_b2t_states(&b2t); + DESTROY_ESTACK(stack); + return res; +#undef ERTS_DDT_FAIL +} + + +int +driver_output_term(ErlDrvPort ix, ErlDrvTermData* data, int len) +{ + Port* prt = erts_drvport2port(ix); + + ERTS_SMP_CHK_NO_PROC_LOCKS; + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(prt)); + + if (prt == NULL) + return -1; + return driver_deliver_term(ix, prt->connected, data, len); +} + + +int +driver_send_term(ErlDrvPort ix, ErlDrvTermData to, ErlDrvTermData* data, int len) +{ + return driver_deliver_term(ix, to, data, len); +} + + +/* + * Output a binary with hlen bytes from hbuf as list header + * and data is len length of bin starting from offset offs. + */ + +int driver_output_binary(ErlDrvPort ix, char* hbuf, int hlen, + ErlDrvBinary* bin, int offs, int len) +{ + Port* prt = erts_drvport2port(ix); + + ERTS_SMP_CHK_NO_PROC_LOCKS; + + if (prt == NULL) + return -1; + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(prt)); + if (prt->status & ERTS_PORT_SFLG_CLOSING) + return 0; + + prt->bytes_in += (hlen + len); + erts_smp_atomic_add(&erts_bytes_in, (long) (hlen + len)); + if (prt->status & ERTS_PORT_SFLG_DISTRIBUTION) { + return erts_net_message(prt, + prt->dist_entry, + (byte*) hbuf, hlen, + (byte*) (bin->orig_bytes+offs), len); + } + else + deliver_bin_message(prt, prt->connected, + hbuf, hlen, bin, offs, len); + return 0; +} + +/* driver_output2: +** Delivers hlen bytes from hbuf to the port owner as a list; +** after that, the port settings apply, buf is sent as binary or list. +** +** Example: if hlen = 3 then the port owner will receive the data +** [H1,H2,H3 | T] +*/ +int driver_output2(ErlDrvPort ix, char* hbuf, int hlen, char* buf, int len) +{ + Port* prt = erts_drvport2port(ix); + + ERTS_SMP_CHK_NO_PROC_LOCKS; + + if (prt == NULL) + return -1; + + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(prt)); + + if (prt->status & ERTS_PORT_SFLG_CLOSING) + return 0; + + prt->bytes_in += (hlen + len); + erts_smp_atomic_add(&erts_bytes_in, (long) (hlen + len)); + if (prt->status & ERTS_PORT_SFLG_DISTRIBUTION) { + if (len == 0) + return erts_net_message(prt, + prt->dist_entry, + NULL, 0, + (byte*) hbuf, hlen); + else + return erts_net_message(prt, + prt->dist_entry, + (byte*) hbuf, hlen, + (byte*) buf, len); + } + else if(prt->status & ERTS_PORT_SFLG_LINEBUF_IO) + deliver_linebuf_message(prt, prt->connected, hbuf, hlen, buf, len); + else + deliver_read_message(prt, prt->connected, hbuf, hlen, buf, len, 0); + return 0; +} + +/* Interface functions available to driver writers */ + +int driver_output(ErlDrvPort ix, char* buf, int len) +{ + ERTS_SMP_CHK_NO_PROC_LOCKS; + return driver_output2(ix, NULL, 0, buf, len); +} + +int driver_outputv(ErlDrvPort ix, char* hbuf, int hlen, ErlIOVec* vec, int skip) +{ + int n; + int len; + int size; + SysIOVec* iov; + ErlDrvBinary** binv; + Port* prt; + + ERTS_SMP_CHK_NO_PROC_LOCKS; + + size = vec->size - skip; /* Size of remaining bytes in vector */ + ASSERT(size >= 0); + if (size <= 0) + return driver_output2(ix, hbuf, hlen, NULL, 0); + ASSERT(hlen >= 0); /* debug only */ + if (hlen < 0) + hlen = 0; + + prt = erts_drvport2port(ix); + if (prt == NULL) + return -1; + + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(prt)); + + if (prt->status & ERTS_PORT_SFLG_CLOSING) + return 0; + + /* size > 0 ! */ + iov = vec->iov; + binv = vec->binv; + n = vec->vsize; + /* we use do here to strip iov_len=0 from beginning */ + do { + len = iov->iov_len; + if (len <= skip) { + skip -= len; + iov++; + binv++; + n--; + } else { + iov->iov_base += skip; + iov->iov_len -= skip; + skip = 0; + } + } while (skip > 0); + + /* XXX handle distribution !!! */ + prt->bytes_in += (hlen + size); + erts_smp_atomic_add(&erts_bytes_in, (long) (hlen + size)); + deliver_vec_message(prt, prt->connected, hbuf, hlen, binv, iov, n, size); + return 0; +} + +/* Copy bytes from a vector into a buffer +** input is a vector a buffer and a max length +** return bytes copied +*/ +int driver_vec_to_buf(vec, buf, len) +ErlIOVec* vec; +char* buf; +int len; +{ + SysIOVec* iov = vec->iov; + int n = vec->vsize; + int orig_len = len; + + while(n--) { + int ilen = iov->iov_len; + if (ilen < len) { + sys_memcpy(buf, iov->iov_base, ilen); + len -= ilen; + buf += ilen; + iov++; + } + else { + sys_memcpy(buf, iov->iov_base, len); + return orig_len; + } + } + return (orig_len - len); +} + + +/* + * - driver_alloc_binary() is thread safe (efile driver depend on it). + * - driver_realloc_binary(), and driver_free_binary() are *not* thread safe. + */ + +/* + * reference count on driver binaries... + */ + +long +driver_binary_get_refc(ErlDrvBinary *dbp) +{ + Binary* bp = ErlDrvBinary2Binary(dbp); + return erts_refc_read(&bp->refc, 1); +} + +long +driver_binary_inc_refc(ErlDrvBinary *dbp) +{ + Binary* bp = ErlDrvBinary2Binary(dbp); + return erts_refc_inctest(&bp->refc, 2); +} + +long +driver_binary_dec_refc(ErlDrvBinary *dbp) +{ + Binary* bp = ErlDrvBinary2Binary(dbp); + return erts_refc_dectest(&bp->refc, 1); +} + + +/* +** Allocation/Deallocation of binary objects +*/ + +ErlDrvBinary* +driver_alloc_binary(int size) +{ + Binary* bin; + + if (size < 0) + return NULL; + + bin = erts_bin_drv_alloc_fnf((Uint) size); + if (!bin) + return NULL; /* The driver write must take action */ + bin->flags = BIN_FLAG_DRV; + erts_refc_init(&bin->refc, 1); + bin->orig_size = (long) size; + return Binary2ErlDrvBinary(bin); +} + +/* Reallocate space hold by binary */ + +ErlDrvBinary* driver_realloc_binary(ErlDrvBinary* bin, int size) +{ + Binary* oldbin; + Binary* newbin; + + if (!bin || size < 0) { + erts_dsprintf_buf_t *dsbufp = erts_create_logger_dsbuf(); + erts_dsprintf(dsbufp, + "Bad use of driver_realloc_binary(%p, %d): " + "called with ", + bin, size); + if (!bin) { + erts_dsprintf(dsbufp, "NULL pointer as first argument"); + if (size < 0) + erts_dsprintf(dsbufp, ", and "); + } + if (size < 0) { + erts_dsprintf(dsbufp, "negative size as second argument"); + size = 0; + } + erts_send_warning_to_logger_nogl(dsbufp); + if (!bin) + return driver_alloc_binary(size); + } + + oldbin = ErlDrvBinary2Binary(bin); + newbin = (Binary *) erts_bin_realloc_fnf(oldbin, size); + if (!newbin) + return NULL; + + newbin->orig_size = size; + return Binary2ErlDrvBinary(newbin); +} + + +void driver_free_binary(dbin) +ErlDrvBinary* dbin; +{ + Binary *bin; + if (!dbin) { + erts_dsprintf_buf_t *dsbufp = erts_create_logger_dsbuf(); + erts_dsprintf(dsbufp, + "Bad use of driver_free_binary(%p): called with " + "NULL pointer as argument", dbin); + erts_send_warning_to_logger_nogl(dsbufp); + return; + } + + bin = ErlDrvBinary2Binary(dbin); + if (erts_refc_dectest(&bin->refc, 0) == 0) + erts_bin_free(bin); +} + + +/* + * Allocation/deallocation of memory for drivers + */ + +void *driver_alloc(size_t size) +{ + return erts_alloc_fnf(ERTS_ALC_T_DRV, (Uint) size); +} + +void *driver_realloc(void *ptr, size_t size) +{ + return erts_realloc_fnf(ERTS_ALC_T_DRV, ptr, (Uint) size); +} + +void driver_free(void *ptr) +{ + erts_free(ERTS_ALC_T_DRV, ptr); +} + +/* + * Port Data Lock + */ + +static void +pdl_init(void) +{ +} + +static ERTS_INLINE void +pdl_init_refc(ErlDrvPDL pdl) +{ + erts_atomic_init(&pdl->refc, 1); +} + +static ERTS_INLINE long +pdl_read_refc(ErlDrvPDL pdl) +{ + long refc = erts_atomic_read(&pdl->refc); + ERTS_LC_ASSERT(refc >= 0); + return refc; +} + +static ERTS_INLINE void +pdl_inc_refc(ErlDrvPDL pdl) +{ + erts_atomic_inc(&pdl->refc); + ERTS_LC_ASSERT(driver_pdl_get_refc(pdl) > 1); +} + +static ERTS_INLINE long +pdl_inctest_refc(ErlDrvPDL pdl) +{ + long refc = erts_atomic_inctest(&pdl->refc); + ERTS_LC_ASSERT(refc > 1); + return refc; +} + +#if 0 /* unused */ +static ERTS_INLINE void +pdl_dec_refc(ErlDrvPDL pdl) +{ + erts_atomic_dec(&pdl->refc); + ERTS_LC_ASSERT(driver_pdl_get_refc(pdl) > 0); +} +#endif + +static ERTS_INLINE long +pdl_dectest_refc(ErlDrvPDL pdl) +{ + long refc = erts_atomic_dectest(&pdl->refc); + ERTS_LC_ASSERT(refc >= 0); + return refc; +} + +static ERTS_INLINE void pdl_destroy(ErlDrvPDL pdl) +{ + ERTS_LC_ASSERT(driver_pdl_get_refc(pdl) == 0); + erts_mtx_destroy(&pdl->mtx); + erts_free(ERTS_ALC_T_PORT_DATA_LOCK, pdl); +} + +/* + * exported driver_pdl_* functions ... + */ + +ErlDrvPDL +driver_pdl_create(ErlDrvPort dp) +{ + ErlDrvPDL pdl; + Port *pp = erts_drvport2port(dp); + if (!pp || pp->port_data_lock) + return NULL; + pdl = erts_alloc(ERTS_ALC_T_PORT_DATA_LOCK, + sizeof(struct erl_drv_port_data_lock)); + erts_mtx_init(&pdl->mtx, "port_data_lock"); + pdl_init_refc(pdl); + pp->port_data_lock = pdl; +#ifdef HARDDEBUG + erts_fprintf(stderr, "driver_pdl_create(%T) -> 0x%08X\r\n",pp->id,(unsigned) pdl); +#endif + return pdl; +} + +void +driver_pdl_lock(ErlDrvPDL pdl) +{ +#ifdef HARDDEBUG + erts_fprintf(stderr, "driver_pdl_lock(0x%08X)\r\n",(unsigned) pdl); +#endif + pdl_inc_refc(pdl); + erts_mtx_lock(&pdl->mtx); +} + +void +driver_pdl_unlock(ErlDrvPDL pdl) +{ + long refc; +#ifdef HARDDEBUG + erts_fprintf(stderr, "driver_pdl_unlock(0x%08X)\r\n",(unsigned) pdl); +#endif + erts_mtx_unlock(&pdl->mtx); + refc = pdl_dectest_refc(pdl); + if (!refc) + pdl_destroy(pdl); +} + +long +driver_pdl_get_refc(ErlDrvPDL pdl) +{ + return pdl_read_refc(pdl); +} + +long +driver_pdl_inc_refc(ErlDrvPDL pdl) +{ + long refc = pdl_inctest_refc(pdl); +#ifdef HARDDEBUG + erts_fprintf(stderr, "driver_pdl_inc_refc(0x%08X) -> %ld\r\n",(unsigned) pdl, refc); +#endif + return refc; +} + +long +driver_pdl_dec_refc(ErlDrvPDL pdl) +{ + long refc = pdl_dectest_refc(pdl); +#ifdef HARDDEBUG + erts_fprintf(stderr, "driver_pdl_dec_refc(0x%08X) -> %ld\r\n",(unsigned) pdl, refc); +#endif + if (!refc) + pdl_destroy(pdl); + return refc; +} + +/* expand queue to hold n elements in tail or head */ +static int expandq(ErlIOQueue* q, int n, int tail) +/* tail: 0 if make room in head, make room in tail otherwise */ +{ + int h_sz; /* room before header */ + int t_sz; /* room after tail */ + int q_sz; /* occupied */ + int nvsz; + SysIOVec* niov; + ErlDrvBinary** nbinv; + + h_sz = q->v_head - q->v_start; + t_sz = q->v_end - q->v_tail; + q_sz = q->v_tail - q->v_head; + + if (tail && (n <= t_sz)) /* do we need to expand tail? */ + return 0; + else if (!tail && (n <= h_sz)) /* do we need to expand head? */ + return 0; + else if (n > (h_sz + t_sz)) { /* need to allocate */ + /* we may get little extra but it ok */ + nvsz = (q->v_end - q->v_start) + n; + + niov = erts_alloc_fnf(ERTS_ALC_T_IOQ, nvsz * sizeof(SysIOVec)); + if (!niov) + return -1; + nbinv = erts_alloc_fnf(ERTS_ALC_T_IOQ, nvsz * sizeof(ErlDrvBinary**)); + if (!nbinv) { + erts_free(ERTS_ALC_T_IOQ, (void *) niov); + return -1; + } + if (tail) { + sys_memcpy(niov, q->v_head, q_sz*sizeof(SysIOVec)); + if (q->v_start != q->v_small) + erts_free(ERTS_ALC_T_IOQ, (void *) q->v_start); + q->v_start = niov; + q->v_end = niov + nvsz; + q->v_head = q->v_start; + q->v_tail = q->v_head + q_sz; + + sys_memcpy(nbinv, q->b_head, q_sz*sizeof(ErlDrvBinary*)); + if (q->b_start != q->b_small) + erts_free(ERTS_ALC_T_IOQ, (void *) q->b_start); + q->b_start = nbinv; + q->b_end = nbinv + nvsz; + q->b_head = q->b_start; + q->b_tail = q->b_head + q_sz; + } + else { + sys_memcpy(niov+nvsz-q_sz, q->v_head, q_sz*sizeof(SysIOVec)); + if (q->v_start != q->v_small) + erts_free(ERTS_ALC_T_IOQ, (void *) q->v_start); + q->v_start = niov; + q->v_end = niov + nvsz; + q->v_tail = q->v_end; + q->v_head = q->v_tail - q_sz; + + sys_memcpy(nbinv+nvsz-q_sz, q->b_head, q_sz*sizeof(ErlDrvBinary*)); + if (q->b_start != q->b_small) + erts_free(ERTS_ALC_T_IOQ, (void *) q->b_start); + q->b_start = nbinv; + q->b_end = nbinv + nvsz; + q->b_tail = q->b_end; + q->b_head = q->b_tail - q_sz; + } + } + else if (tail) { /* move to beginning to make room in tail */ + sys_memmove(q->v_start, q->v_head, q_sz*sizeof(SysIOVec)); + q->v_head = q->v_start; + q->v_tail = q->v_head + q_sz; + sys_memmove(q->b_start, q->b_head, q_sz*sizeof(ErlDrvBinary*)); + q->b_head = q->b_start; + q->b_tail = q->b_head + q_sz; + } + else { /* move to end to make room */ + sys_memmove(q->v_end-q_sz, q->v_head, q_sz*sizeof(SysIOVec)); + q->v_tail = q->v_end; + q->v_head = q->v_tail-q_sz; + sys_memmove(q->b_end-q_sz, q->b_head, q_sz*sizeof(ErlDrvBinary*)); + q->b_tail = q->b_end; + q->b_head = q->b_tail-q_sz; + } + + return 0; +} + + + +/* Put elements from vec at q tail */ +int driver_enqv(ErlDrvPort ix, ErlIOVec* vec, int skip) +{ + int n; + int len; + int size; + SysIOVec* iov; + ErlDrvBinary** binv; + ErlDrvBinary* b; + ErlIOQueue* q = drvport2ioq(ix); + + if (q == NULL) + return -1; + + size = vec->size - skip; + ASSERT(size >= 0); /* debug only */ + if (size <= 0) + return 0; + + iov = vec->iov; + binv = vec->binv; + n = vec->vsize; + + /* we use do here to strip iov_len=0 from beginning */ + do { + len = iov->iov_len; + if (len <= skip) { + skip -= len; + iov++; + binv++; + n--; + } + else { + iov->iov_base += skip; + iov->iov_len -= skip; + skip = 0; + } + } while(skip > 0); + + if (q->v_tail + n >= q->v_end) + expandq(q, n, 1); + + /* Queue and reference all binaries (remove zero length items) */ + while(n--) { + if ((len = iov->iov_len) > 0) { + if ((b = *binv) == NULL) { /* speical case create binary ! */ + b = driver_alloc_binary(len); + sys_memcpy(b->orig_bytes, iov->iov_base, len); + *q->b_tail++ = b; + q->v_tail->iov_len = len; + q->v_tail->iov_base = b->orig_bytes; + q->v_tail++; + } + else { + driver_binary_inc_refc(b); + *q->b_tail++ = b; + *q->v_tail++ = *iov; + } + } + iov++; + binv++; + } + q->size += size; /* update total size in queue */ + return 0; +} + +/* Put elements from vec at q head */ +int driver_pushqv(ErlDrvPort ix, ErlIOVec* vec, int skip) +{ + int n; + int len; + int size; + SysIOVec* iov; + ErlDrvBinary** binv; + ErlDrvBinary* b; + ErlIOQueue* q = drvport2ioq(ix); + + if (q == NULL) + return -1; + + if ((size = vec->size - skip) <= 0) + return 0; + iov = vec->iov; + binv = vec->binv; + n = vec->vsize; + + /* we use do here to strip iov_len=0 from beginning */ + do { + len = iov->iov_len; + if (len <= skip) { + skip -= len; + iov++; + binv++; + n--; + } + else { + iov->iov_base += skip; + iov->iov_len -= skip; + skip = 0; + } + } while(skip > 0); + + if (q->v_head - n < q->v_start) + expandq(q, n, 0); + + /* Queue and reference all binaries (remove zero length items) */ + iov += (n-1); /* move to end */ + binv += (n-1); /* move to end */ + while(n--) { + if ((len = iov->iov_len) > 0) { + if ((b = *binv) == NULL) { /* speical case create binary ! */ + b = driver_alloc_binary(len); + sys_memcpy(b->orig_bytes, iov->iov_base, len); + *--q->b_head = b; + q->v_head--; + q->v_head->iov_len = len; + q->v_head->iov_base = b->orig_bytes; + } + else { + driver_binary_inc_refc(b); + *--q->b_head = b; + *--q->v_head = *iov; + } + } + iov--; + binv--; + } + q->size += size; /* update total size in queue */ + return 0; +} + + +/* +** Remove size bytes from queue head +** Return number of bytes that remain in queue +*/ +int driver_deq(ErlDrvPort ix, int size) +{ + ErlIOQueue* q = drvport2ioq(ix); + int len; + int sz; + + if ((q == NULL) || (sz = (q->size - size)) < 0) + return -1; + q->size = sz; + while (size > 0) { + ASSERT(q->v_head != q->v_tail); + + len = q->v_head->iov_len; + if (len <= size) { + size -= len; + driver_free_binary(*q->b_head); + *q->b_head++ = NULL; + q->v_head++; + } + else { + q->v_head->iov_base += size; + q->v_head->iov_len -= size; + size = 0; + } + } + + /* restart pointers (optimised for enq) */ + if (q->v_head == q->v_tail) { + q->v_head = q->v_tail = q->v_start; + q->b_head = q->b_tail = q->b_start; + } + return sz; +} + + +int driver_peekqv(ErlDrvPort ix, ErlIOVec *ev) { + ErlIOQueue *q = drvport2ioq(ix); + ASSERT(ev); + + if (! q) { + return -1; + } else { + if ((ev->vsize = q->v_tail - q->v_head) == 0) { + ev->size = 0; + ev->iov = NULL; + ev->binv = NULL; + } else { + ev->size = q->size; + ev->iov = q->v_head; + ev->binv = q->b_head; + } + return q->size; + } +} + +SysIOVec* driver_peekq(ErlDrvPort ix, int* vlenp) /* length of io-vector */ +{ + ErlIOQueue* q = drvport2ioq(ix); + + if (q == NULL) { + *vlenp = -1; + return NULL; + } + if ((*vlenp = (q->v_tail - q->v_head)) == 0) + return NULL; + return q->v_head; +} + + +int driver_sizeq(ErlDrvPort ix) +{ + ErlIOQueue* q = drvport2ioq(ix); + + if (q == NULL) + return -1; + return q->size; +} + + +/* Utils */ + +/* Enqueue a binary */ +int driver_enq_bin(ErlDrvPort ix, ErlDrvBinary* bin, int offs, int len) +{ + SysIOVec iov; + ErlIOVec ev; + + ASSERT(len >= 0); + if (len == 0) + return 0; + iov.iov_base = bin->orig_bytes + offs; + iov.iov_len = len; + ev.vsize = 1; + ev.size = len; + ev.iov = &iov; + ev.binv = &bin; + return driver_enqv(ix, &ev, 0); +} + +int driver_enq(ErlDrvPort ix, char* buffer, int len) +{ + int code; + ErlDrvBinary* bin; + + ASSERT(len >= 0); + if (len == 0) + return 0; + if ((bin = driver_alloc_binary(len)) == NULL) + return -1; + sys_memcpy(bin->orig_bytes, buffer, len); + code = driver_enq_bin(ix, bin, 0, len); + driver_free_binary(bin); /* dereference */ + return code; +} + +int driver_pushq_bin(ErlDrvPort ix, ErlDrvBinary* bin, int offs, int len) +{ + SysIOVec iov; + ErlIOVec ev; + + ASSERT(len >= 0); + if (len == 0) + return 0; + iov.iov_base = bin->orig_bytes + offs; + iov.iov_len = len; + ev.vsize = 1; + ev.size = len; + ev.iov = &iov; + ev.binv = &bin; + return driver_pushqv(ix, &ev, 0); +} + +int driver_pushq(ErlDrvPort ix, char* buffer, int len) +{ + int code; + ErlDrvBinary* bin; + + ASSERT(len >= 0); + if (len == 0) + return 0; + + if ((bin = driver_alloc_binary(len)) == NULL) + return -1; + sys_memcpy(bin->orig_bytes, buffer, len); + code = driver_pushq_bin(ix, bin, 0, len); + driver_free_binary(bin); /* dereference */ + return code; +} + +static ERTS_INLINE void +drv_cancel_timer(Port *prt) +{ +#ifdef ERTS_SMP + erts_cancel_smp_ptimer(prt->ptimer); +#else + erl_cancel_timer(&prt->tm); +#endif + if (erts_port_task_is_scheduled(&prt->timeout_task)) + erts_port_task_abort(prt->id, &prt->timeout_task); +} + +int driver_set_timer(ErlDrvPort ix, Uint t) +{ + Port* prt = erts_drvport2port(ix); + + ERTS_SMP_CHK_NO_PROC_LOCKS; + + if (prt == NULL) + return -1; + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(prt)); + if (prt->drv_ptr->timeout == NULL) + return -1; + drv_cancel_timer(prt); +#ifdef ERTS_SMP + erts_create_smp_ptimer(&prt->ptimer, + prt->id, + (ErlTimeoutProc) schedule_port_timeout, + t); +#else + erl_set_timer(&prt->tm, + (ErlTimeoutProc) schedule_port_timeout, + NULL, + prt, + t); +#endif + return 0; +} + +int driver_cancel_timer(ErlDrvPort ix) +{ + Port* prt = erts_drvport2port(ix); + if (prt == NULL) + return -1; + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(prt)); + drv_cancel_timer(prt); + return 0; +} + + +int +driver_read_timer(ErlDrvPort ix, unsigned long* t) +{ + Port* prt = erts_drvport2port(ix); + + ERTS_SMP_CHK_NO_PROC_LOCKS; + + if (prt == NULL) + return -1; + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(prt)); +#ifdef ERTS_SMP + *t = prt->ptimer ? time_left(&prt->ptimer->timer.tm) : 0; +#else + *t = time_left(&prt->tm); +#endif + return 0; +} + +int +driver_get_now(ErlDrvNowData *now_data) +{ + ERTS_SMP_CHK_NO_PROC_LOCKS; + + if (now_data == NULL) { + return -1; + } + get_now(&(now_data->megasecs),&(now_data->secs),&(now_data->microsecs)); + return 0; +} + +static void ref_to_driver_monitor(Eterm ref, ErlDrvMonitor *mon) +{ + RefThing *refp; + ASSERT(is_internal_ref(ref)); + ASSERT(sizeof(RefThing) <= sizeof(ErlDrvMonitor)); + refp = ref_thing_ptr(ref); + memset(mon,0,sizeof(ErlDrvMonitor)); + memcpy(mon,refp,sizeof(RefThing)); +} + +int driver_monitor_process(ErlDrvPort port, + ErlDrvTermData process, + ErlDrvMonitor *monitor) +{ + Port *prt = erts_drvport2port(port); + Process *rp; + Eterm ref; + Eterm buf[REF_THING_SIZE]; + if (prt->drv_ptr->process_exit == NULL) { + return -1; + } + rp = erts_pid2proc_opt(NULL, 0, + (Eterm) process, ERTS_PROC_LOCK_LINK, + ERTS_P2P_FLG_ALLOW_OTHER_X); + if (!rp) { + return 1; + } + ref = erts_make_ref_in_buffer(buf); + erts_add_monitor(&(prt->monitors), MON_ORIGIN, ref, rp->id, NIL); + erts_add_monitor(&(rp->monitors), MON_TARGET, ref, prt->id, NIL); + + erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_LINK); + ref_to_driver_monitor(ref,monitor); + return 0; +} + +int driver_demonitor_process(ErlDrvPort port, + const ErlDrvMonitor *monitor) +{ + Port *prt = erts_drvport2port(port); + Process *rp; + Eterm ref; + Eterm buf[REF_THING_SIZE]; + ErtsMonitor *mon; + Eterm to; + + memcpy(buf,monitor,sizeof(Eterm)*REF_THING_SIZE); + ref = make_internal_ref(buf); + mon = erts_lookup_monitor(prt->monitors, ref); + if (mon == NULL) { + return 1; + } + ASSERT(mon->type == MON_ORIGIN); + to = mon->pid; + ASSERT(is_internal_pid(to)); + rp = erts_pid2proc_opt(NULL, + 0, + to, + ERTS_PROC_LOCK_LINK, + ERTS_P2P_FLG_ALLOW_OTHER_X); + mon = erts_remove_monitor(&(prt->monitors), ref); + if (mon) { + erts_destroy_monitor(mon); + } + if (rp) { + ErtsMonitor *rmon; + rmon = erts_remove_monitor(&(rp->monitors), ref); + erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_LINK); + if (rmon != NULL) { + erts_destroy_monitor(rmon); + } + } + return 0; +} + +ErlDrvTermData driver_get_monitored_process(ErlDrvPort port, + const ErlDrvMonitor *monitor) +{ + Port *prt = erts_drvport2port(port); + Eterm ref; + Eterm buf[REF_THING_SIZE]; + ErtsMonitor *mon; + Eterm to; + + memcpy(buf,monitor,sizeof(Eterm)*REF_THING_SIZE); + ref = make_internal_ref(buf); + mon = erts_lookup_monitor(prt->monitors, ref); + if (mon == NULL) { + return driver_term_nil; + } + ASSERT(mon->type == MON_ORIGIN); + to = mon->pid; + ASSERT(is_internal_pid(to)); + return (ErlDrvTermData) to; +} + +int driver_compare_monitors(const ErlDrvMonitor *monitor1, + const ErlDrvMonitor *monitor2) +{ + return memcmp(monitor1,monitor2,sizeof(ErlDrvMonitor)); +} + +void erts_fire_port_monitor(Port *prt, Eterm ref) +{ + ErtsMonitor *rmon; + void (*callback)(ErlDrvData drv_data, ErlDrvMonitor *monitor); + ErlDrvMonitor drv_monitor; + int fpe_was_unmasked; + + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(prt)); + ASSERT(prt->drv_ptr != NULL); + + if (erts_lookup_monitor(prt->monitors,ref) == NULL) { + return; + } + callback = prt->drv_ptr->process_exit; + ASSERT(callback != NULL); + ref_to_driver_monitor(ref,&drv_monitor); + fpe_was_unmasked = erts_block_fpe(); + (*callback)((ErlDrvData) (prt->drv_data), &drv_monitor); + erts_unblock_fpe(fpe_was_unmasked); + /* remove monitor *after* callback */ + rmon = erts_remove_monitor(&(prt->monitors),ref); + if (rmon) { + erts_destroy_monitor(rmon); + } +} + + +static int +driver_failure_term(ErlDrvPort ix, Eterm term, int eof) +{ + Port* prt = erts_drvport2port(ix); + + ERTS_SMP_CHK_NO_PROC_LOCKS; + + if (prt == NULL) + return -1; + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(prt)); + if (eof) + flush_linebuf_messages(prt); + if (prt->status & ERTS_PORT_SFLG_CLOSING) { + terminate_port(prt); + } else if (eof && (prt->status & ERTS_PORT_SFLG_SOFT_EOF)) { + deliver_result(prt->id, prt->connected, am_eof); + } else { + /* XXX UGLY WORK AROUND, Let do_exit_port terminate the port */ + if (prt->port_data_lock) + driver_pdl_lock(prt->port_data_lock); + prt->ioq.size = 0; + if (prt->port_data_lock) + driver_pdl_unlock(prt->port_data_lock); + erts_do_exit_port(prt, prt->id, eof ? am_normal : term); + } + return 0; +} + + + +/* +** Do a (soft) exit. unlink the connected process before doing +** driver posix error or (normal) +*/ +int driver_exit(ErlDrvPort ix, int err) +{ + Port* prt = erts_drvport2port(ix); + Process* rp; + ErtsLink *lnk, *rlnk = NULL; + + ERTS_SMP_CHK_NO_PROC_LOCKS; + + if (prt == NULL) + return -1; + + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(prt)); + + rp = erts_pid2proc(NULL, 0, prt->connected, ERTS_PROC_LOCK_LINK); + if (rp) { + rlnk = erts_remove_link(&(rp->nlinks),prt->id); + } + + lnk = erts_remove_link(&(prt->nlinks),prt->connected); + +#ifdef ERTS_SMP + if (rp) + erts_smp_proc_unlock(rp, ERTS_PROC_LOCK_LINK); +#endif + + if (rlnk != NULL) { + erts_destroy_link(rlnk); + } + + if (lnk != NULL) { + erts_destroy_link(lnk); + } + + if (err == 0) + return driver_failure_term(ix, am_normal, 0); + else { + char* err_str = erl_errno_id(err); + Eterm am_err = am_atom_put(err_str, sys_strlen(err_str)); + return driver_failure_term(ix, am_err, 0); + } +} + + +int driver_failure(ErlDrvPort ix, int code) +{ + return driver_failure_term(ix, make_small(code), code == 0); +} + +int driver_failure_atom(ErlDrvPort ix, char* string) +{ + Eterm am = am_atom_put(string, strlen(string)); + return driver_failure_term(ix, am, 0); +} + +int driver_failure_posix(ErlDrvPort ix, int err) +{ + return driver_failure_atom(ix, erl_errno_id(err)); +} + +int driver_failure_eof(ErlDrvPort ix) +{ + return driver_failure_term(ix, NIL, 1); +} + + + +ErlDrvTermData driver_mk_atom(char* string) +{ + Eterm am = am_atom_put(string, sys_strlen(string)); + ERTS_SMP_CHK_NO_PROC_LOCKS; + return (ErlDrvTermData) am; +} + +ErlDrvTermData driver_mk_port(ErlDrvPort ix) +{ + Port* prt = erts_drvport2port(ix); + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(prt)); + return (ErlDrvTermData) prt->id; +} + +ErlDrvTermData driver_connected(ErlDrvPort ix) +{ + Port* prt = erts_drvport2port(ix); + ERTS_SMP_CHK_NO_PROC_LOCKS; + if (prt == NULL) + return NIL; + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(prt)); + return prt->connected; +} + +ErlDrvTermData driver_caller(ErlDrvPort ix) +{ + Port* prt = erts_drvport2port(ix); + ERTS_SMP_CHK_NO_PROC_LOCKS; + if (prt == NULL) + return NIL; + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(prt)); + return prt->caller; +} + +int driver_lock_driver(ErlDrvPort ix) +{ + Port* prt = erts_drvport2port(ix); + DE_Handle* dh; + + ERTS_SMP_CHK_NO_PROC_LOCKS; + + erts_smp_mtx_lock(&erts_driver_list_lock); + + if (prt == NULL) return -1; + + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(prt)); + if ((dh = (DE_Handle*)prt->drv_ptr->handle ) == NULL) { + erts_smp_mtx_unlock(&erts_driver_list_lock); + return -1; + } + erts_ddll_lock_driver(dh, prt->drv_ptr->name); + erts_smp_mtx_unlock(&erts_driver_list_lock); + return 0; +} + + +static int maybe_lock_driver_list(void) +{ + void *rec_lock; + rec_lock = erts_smp_tsd_get(driver_list_lock_status_key); + if (rec_lock == 0) { + erts_smp_mtx_lock(&erts_driver_list_lock); + return 1; + } + return 0; +} +static void maybe_unlock_driver_list(int doit) +{ + if (doit) { + erts_smp_mtx_unlock(&erts_driver_list_lock); + } +} +/* + These old interfaces are certainly not MT friendly. Hopefully they are only used internally, + but you never know, so they are kept for BC. As The sys ddll code has no notion + of locking, I use the driver list lock to mutex this from the code in erl_bif_ddll.c. + To allow dynamic code loading in the init functions of a driver, recursive locking is + handled as in add_driver_entry etc. + A TSD variable holds the last error for a thread, so that code like + ... + x = driver_dl_open(...); + if (x == NULL) + y = driver_dl_error(); + ... + works as long as execution happens in one driver callback even in an SMP emulator. + Writing code using these interfaces spanning several driver callbacks between loading/lookup + and error handling may give undesired results... +*/ +void *driver_dl_open(char * path) +{ + void *ptr; + int res; + int *last_error_p = erts_smp_tsd_get(driver_list_last_error_key); + int locked = maybe_lock_driver_list(); + if ((res = erts_sys_ddll_open(path, &ptr)) == 0) { + maybe_unlock_driver_list(locked); + return ptr; + } else { + if (!last_error_p) { + last_error_p = erts_alloc(ERTS_ALC_T_DDLL_ERRCODES, sizeof(int)); + erts_smp_tsd_set(driver_list_last_error_key,last_error_p); + } + *last_error_p = res; + maybe_unlock_driver_list(locked); + return NULL; + } +} + +void *driver_dl_sym(void * handle, char *func_name) +{ + void *ptr; + int res; + int *last_error_p = erts_smp_tsd_get(driver_list_lock_status_key); + int locked = maybe_lock_driver_list(); + if ((res = erts_sys_ddll_sym(handle, func_name, &ptr)) == 0) { + maybe_unlock_driver_list(locked); + return ptr; + } else { + if (!last_error_p) { + last_error_p = erts_alloc(ERTS_ALC_T_DDLL_ERRCODES, sizeof(int)); + erts_smp_tsd_set(driver_list_lock_status_key,last_error_p); + } + *last_error_p = res; + maybe_unlock_driver_list(locked); + return NULL; + } +} + +int driver_dl_close(void *handle) +{ + int res; + int locked = maybe_lock_driver_list(); + res = erts_sys_ddll_close(handle); + maybe_unlock_driver_list(locked); + return res; +} + +char *driver_dl_error(void) +{ + char *res; + int *last_error_p = erts_smp_tsd_get(driver_list_lock_status_key); + int locked = maybe_lock_driver_list(); + res = erts_ddll_error((last_error_p != NULL) ? (*last_error_p) : ERL_DE_ERROR_UNSPECIFIED); + maybe_unlock_driver_list(locked); + return res; +} + + +#define ERL_DRV_SYS_INFO_SIZE(LAST_FIELD) \ + (((size_t) &((ErlDrvSysInfo *) 0)->LAST_FIELD) \ + + sizeof(((ErlDrvSysInfo *) 0)->LAST_FIELD)) + +void +driver_system_info(ErlDrvSysInfo *sip, size_t si_size) +{ + /* + * When adding fields in the ErlDrvSysInfo struct + * remember to increment ERL_DRV_EXTENDED_MINOR_VERSION + */ + + /* + * 'smp_support' is the last field in the first version + * of ErlDrvSysInfo (introduced in driver version 1.0). + */ + if (!sip || si_size < ERL_DRV_SYS_INFO_SIZE(smp_support)) + erl_exit(1, + "driver_system_info(%p, %ld) called with invalid arguments\n", + sip, si_size); + + /* + * 'smp_support' is the last field in the first version + * of ErlDrvSysInfo (introduced in driver version 1.0). + */ + if (si_size >= ERL_DRV_SYS_INFO_SIZE(smp_support)) { + sip->driver_major_version = ERL_DRV_EXTENDED_MAJOR_VERSION; + sip->driver_minor_version = ERL_DRV_EXTENDED_MINOR_VERSION; + sip->erts_version = ERLANG_VERSION; + sip->otp_release = ERLANG_OTP_RELEASE; + sip->thread_support = +#ifdef USE_THREADS + 1 +#else + 0 +#endif + ; + sip->smp_support = +#ifdef ERTS_SMP + 1 +#else + 0 +#endif + ; + + } + + /* + * 'scheduler_threads' is the last field in the second version + * of ErlDrvSysInfo (introduced in driver version 1.1). + */ + if (si_size >= ERL_DRV_SYS_INFO_SIZE(scheduler_threads)) { + sip->async_threads = erts_async_max_threads; + sip->scheduler_threads = erts_no_schedulers; + } + +} + + +static ERTS_INLINE Port * +get_current_port(void) +{ + ErtsSchedulerData *esdp = erts_get_scheduler_data(); + ASSERT(esdp); + ASSERT(esdp->current_port); + return esdp->current_port; +} + +/* + * Default callbacks used if not supplied by driver. + */ + +static void +no_output_callback(ErlDrvData drv_data, char *buf, int len) +{ + +} + +static void +no_event_callback(ErlDrvData drv_data, ErlDrvEvent event, ErlDrvEventData event_data) +{ + Port *prt = get_current_port(); + report_missing_drv_callback(prt, "Event", "event()"); + driver_event((ErlDrvPort) internal_port_index(prt->id), event, NULL); +} + +static void +no_ready_input_callback(ErlDrvData drv_data, ErlDrvEvent event) +{ + Port *prt = get_current_port(); + report_missing_drv_callback(prt, "Input", "ready_input()"); + driver_select((ErlDrvPort) internal_port_index(prt->id), event, + (ERL_DRV_READ | ERL_DRV_USE_NO_CALLBACK), 0); +} + +static void +no_ready_output_callback(ErlDrvData drv_data, ErlDrvEvent event) +{ + Port *prt = get_current_port(); + report_missing_drv_callback(prt, "Output", "ready_output()"); + driver_select((ErlDrvPort) internal_port_index(prt->id), event, + (ERL_DRV_WRITE | ERL_DRV_USE_NO_CALLBACK), 0); +} + +static void +no_timeout_callback(ErlDrvData drv_data) +{ + +} + +static void +no_stop_select_callback(ErlDrvEvent event, void* private) +{ + erts_dsprintf_buf_t *dsbufp = erts_create_logger_dsbuf(); + erts_dsprintf(dsbufp, "Driver does not implement stop_select callback " + "(event=%ld, private=%p)!\n", (long)event, private); + erts_send_error_to_logger_nogl(dsbufp); +} + + +static int +init_driver(erts_driver_t *drv, ErlDrvEntry *de, DE_Handle *handle) +{ + drv->name = de->driver_name; + if (de->extended_marker == ERL_DRV_EXTENDED_MARKER) { + drv->version.major = de->major_version; + drv->version.minor = de->minor_version; + drv->flags = de->driver_flags; + } + else { + drv->version.major = 0; + drv->version.minor = 0; + drv->flags = 0; + } + drv->handle = handle; +#ifdef ERTS_SMP + if (drv->flags & ERL_DRV_FLAG_USE_PORT_LOCKING) + drv->lock = NULL; + else { + drv->lock = erts_alloc(ERTS_ALC_T_DRIVER_LOCK, + sizeof(erts_smp_mtx_t)); + erts_smp_mtx_init_x(drv->lock, + "driver_lock", +#if defined(ERTS_ENABLE_LOCK_CHECK) || defined(ERTS_ENABLE_LOCK_COUNT) + am_atom_put(drv->name, sys_strlen(drv->name)) +#else + NIL +#endif + ); + } +#endif + drv->entry = de; + + drv->start = de->start; + drv->stop = de->stop; + drv->finish = de->finish; + drv->flush = de->flush; + drv->output = de->output ? de->output : no_output_callback; + drv->outputv = de->outputv; + drv->control = de->control; + drv->call = de->call; + drv->event = de->event ? de->event : no_event_callback; + drv->ready_input = de->ready_input ? de->ready_input : no_ready_input_callback; + drv->ready_output = de->ready_output ? de->ready_output : no_ready_output_callback; + drv->timeout = de->timeout ? de->timeout : no_timeout_callback; + drv->ready_async = de->ready_async; + if (de->extended_marker == ERL_DRV_EXTENDED_MARKER) + drv->process_exit = de->process_exit; + else + drv->process_exit = NULL; + if (de->minor_version >= 3/*R13A*/ && de->stop_select) + drv->stop_select = de->stop_select; + else + drv->stop_select = no_stop_select_callback; + + if (!de->init) + return 0; + else { + int res; + int fpe_was_unmasked = erts_block_fpe(); + res = (*de->init)(); + erts_unblock_fpe(fpe_was_unmasked); + return res; + } +} + +void +erts_destroy_driver(erts_driver_t *drv) +{ +#ifdef ERTS_SMP + if (drv->lock) { + erts_smp_mtx_destroy(drv->lock); + erts_free(ERTS_ALC_T_DRIVER_LOCK, drv->lock); + } +#endif + erts_free(ERTS_ALC_T_DRIVER, drv); +} + +/* + * Functions for maintaining a list of driver_entry struct + * Exposed in the driver interface, and therefore possibly locking directly. + */ + +void add_driver_entry(ErlDrvEntry *drv){ + void *rec_lock; + rec_lock = erts_smp_tsd_get(driver_list_lock_status_key); + /* + * Ignore result of erts_add_driver_entry, the init is not + * allowed to fail when drivers are added by drivers. + */ + erts_add_driver_entry(drv, NULL, rec_lock != NULL); +} + +int erts_add_driver_entry(ErlDrvEntry *de, DE_Handle *handle, int driver_list_locked) +{ + erts_driver_t *dp = erts_alloc(ERTS_ALC_T_DRIVER, sizeof(erts_driver_t)); + int res; + + if (!driver_list_locked) { + erts_smp_mtx_lock(&erts_driver_list_lock); + } + + dp->next = driver_list; + dp->prev = NULL; + if (driver_list != NULL) { + driver_list->prev = dp; + } + driver_list = dp; + + if (!driver_list_locked) { + erts_smp_tsd_set(driver_list_lock_status_key, (void *) 1); + } + + res = init_driver(dp, de, handle); + + if (res != 0) { + /* + * Remove it all again... + */ + driver_list = dp->next; + if (driver_list != NULL) { + driver_list->prev = NULL; + } + erts_destroy_driver(dp); + } + + if (!driver_list_locked) { + erts_smp_tsd_set(driver_list_lock_status_key, NULL); + erts_smp_mtx_unlock(&erts_driver_list_lock); + } + return res; +} + +/* Not allowed for dynamic drivers */ +int remove_driver_entry(ErlDrvEntry *drv) +{ + erts_driver_t *dp; + void *rec_lock; + + rec_lock = erts_smp_tsd_get(driver_list_lock_status_key); + if (rec_lock == NULL) { + erts_smp_mtx_lock(&erts_driver_list_lock); + } + dp = driver_list; + while (dp && dp->entry != drv) + dp = dp->next; + if (dp) { + if (dp->handle) { + if (rec_lock == NULL) { + erts_smp_mtx_unlock(&erts_driver_list_lock); + } + return -1; + } + if (dp->prev == NULL) { + driver_list = dp->next; + } else { + dp->prev->next = dp->next; + } + if (dp->next != NULL) { + dp->next->prev = dp->prev; + } + erts_destroy_driver(dp); + if (rec_lock == NULL) { + erts_smp_mtx_unlock(&erts_driver_list_lock); + } + return 1; + } + if (rec_lock == NULL) { + erts_smp_mtx_unlock(&erts_driver_list_lock); + } + return 0; +} + +/* very useful function that can be used in entries that are not used + * so that not every driver writer must supply a personal version + */ +int null_func(void) +{ + return 0; +} + +int +erl_drv_putenv(char *key, char *value) +{ + return erts_write_env(key, value); +} + +int +erl_drv_getenv(char *key, char *value, size_t *value_size) +{ + return erts_sys_getenv(key, value, value_size); +} diff --git a/erts/emulator/beam/module.c b/erts/emulator/beam/module.c new file mode 100644 index 0000000000..57a43c89f4 --- /dev/null +++ b/erts/emulator/beam/module.c @@ -0,0 +1,134 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "module.h" + +#define MODULE_SIZE 50 +#define MODULE_LIMIT (64*1024) + +static IndexTable module_table; + +/* + * SMP note: We don't need to look accesses to the module table because + * there is one only scheduler thread when we update it. + */ + +#include "erl_smp.h" + +void module_info(int to, void *to_arg) +{ + index_info(to, to_arg, &module_table); +} + + +static HashValue module_hash(Module* x) +{ + return (HashValue) x->module; +} + + +static int module_cmp(Module* tmpl, Module* obj) +{ + return tmpl->module != obj->module; +} + + +static Module* module_alloc(Module* tmpl) +{ + Module* obj = (Module*) erts_alloc(ERTS_ALC_T_MODULE, sizeof(Module)); + + obj->module = tmpl->module; + obj->code = 0; + obj->old_code = 0; + obj->code_length = 0; + obj->old_code_length = 0; + obj->slot.index = -1; + obj->nif.handle = NULL; + obj->old_nif.handle = NULL; + obj->nif.entry = NULL; + obj->old_nif.entry = NULL; + obj->nif.data = NULL; + obj->old_nif.data = NULL; + return obj; +} + + +void init_module_table(void) +{ + HashFunctions f; + + f.hash = (H_FUN) module_hash; + f.cmp = (HCMP_FUN) module_cmp; + f.alloc = (HALLOC_FUN) module_alloc; + f.free = 0; + + erts_index_init(ERTS_ALC_T_MODULE_TABLE, &module_table, "module_code", + MODULE_SIZE, MODULE_LIMIT, f); +} + +Module* +erts_get_module(Eterm mod) +{ + Module e; + int index; + + ASSERT(is_atom(mod)); + e.module = atom_val(mod); + index = index_get(&module_table, (void*) &e); + if (index == -1) { + return NULL; + } else { + return (Module*) erts_index_lookup(&module_table, index); + } +} + +Module* +erts_put_module(Eterm mod) +{ + Module e; + int index; + + ASSERT(is_atom(mod)); + ERTS_SMP_LC_ASSERT(erts_initialized == 0 || erts_smp_is_system_blocked(0)); + e.module = atom_val(mod); + index = index_put(&module_table, (void*) &e); + return (Module*) erts_index_lookup(&module_table, index); +} + +Module *module_code(int i) +{ + return (Module*) erts_index_lookup(&module_table, i); +} + +int module_code_size(void) +{ + return module_table.entries; +} + +int module_table_sz(void) +{ + return index_table_sz(&module_table); +} diff --git a/erts/emulator/beam/module.h b/erts/emulator/beam/module.h new file mode 100644 index 0000000000..314be8e2ee --- /dev/null +++ b/erts/emulator/beam/module.h @@ -0,0 +1,56 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifndef __MODULE_H__ +#define __MODULE_H__ + +#ifndef __INDEX_H__ +#include "index.h" +#endif + +struct erl_module_nif { + void* handle; + struct enif_entry_t* entry; + void* data; +}; + +typedef struct erl_module { + IndexSlot slot; /* Must be located at top of struct! */ + int module; /* Atom index for module (not tagged). */ + + Eterm* code; + Eterm* old_code; + int code_length; /* Length of loaded code in bytes. */ + int old_code_length; /* Length of old loaded code in bytes */ + unsigned catches, old_catches; + struct erl_module_nif nif; + struct erl_module_nif old_nif; +} Module; + +Module* erts_get_module(Eterm mod); +Module* erts_put_module(Eterm mod); + +void init_module_table(void); +void module_info(int, void *); + +Module *module_code(int); +int module_code_size(void); +int module_table_sz(void); + +#endif diff --git a/erts/emulator/beam/ops.tab b/erts/emulator/beam/ops.tab new file mode 100644 index 0000000000..ce1df74f03 --- /dev/null +++ b/erts/emulator/beam/ops.tab @@ -0,0 +1,1430 @@ +# +# %CopyrightBegin% +# +# Copyright Ericsson AB 1997-2009. All Rights Reserved. +# +# The contents of this file are subject to the Erlang Public License, +# Version 1.1, (the "License"); you may not use this file except in +# compliance with the License. You should have received a copy of the +# Erlang Public License along with this software. If not, it can be +# retrieved online at http://www.erlang.org/. +# +# Software distributed under the License is distributed on an "AS IS" +# basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +# the License for the specific language governing rights and limitations +# under the License. +# +# %CopyrightEnd% +# + +# +# The instructions that follows are only known by the loader and the emulator. +# They can be changed without recompiling old Beam files. +# +# Instructions starting with a "i_" prefix are instructions produced by +# instruction transformations; thus, they never occur in BEAM files. +# + +# Special instruction used to generate an error message when +# trying to load a module compiled by the V1 compiler (R5 & R6). +# (Specially treated in beam_load.c.) + +too_old_compiler/0 +too_old_compiler + +# +# Obsolete instruction usage follow. (Nowdays we use f with +# a zero label instead of p.) +# + +is_list p S => too_old_compiler +is_nonempty_list p R => too_old_compiler +is_nil p R => too_old_compiler + +is_tuple p S => too_old_compiler +test_arity p S Arity => too_old_compiler + +is_integer p R => too_old_compiler +is_float p R => too_old_compiler +is_atom p R => too_old_compiler + +is_eq_exact p S1 S2 => too_old_compiler + +# In R9C and earlier, the loader used to insert special instructions inside +# the module_info/0,1 functions. (In R10B and later, the compiler inserts +# an explicit call to an undocumented BIF, so that no loader trickery is +# necessary.) Since the instructions don't work correctly in R12B, simply +# refuse to load the module. + +func_info M=a a==am_module_info A=u==0 | label L | move n r => too_old_compiler +func_info M=a a==am_module_info A=u==1 | label L | move n r => too_old_compiler + +# The undocumented and unsupported guard BIF is_constant/1 was removed +# in R13. The is_constant/2 operation is marked as obosolete in genop.tab, +# so the loader will automatically generate a too_old_compiler message +# it is used, but we need to handle the is_constant/1 BIF specially here. + +bif1 Fail u$func:erlang:is_constant/1 Src Dst => too_old_compiler + + +# +# All the other instructions. +# + +label L +i_func_info I a a I +int_code_end + +i_trace_breakpoint +i_mtrace_breakpoint +i_debug_breakpoint +i_count_breakpoint +i_return_to_trace +i_yield +i_global_cons +i_global_tuple +i_global_copy + +return + +%macro: allocate Allocate -pack +%macro: allocate_zero AllocateZero -pack +%macro: allocate_heap AllocateHeap -pack +%macro: allocate_heap_zero AllocateHeapZero -pack +%macro: test_heap TestHeap -pack + +allocate t t +allocate_heap I I I +deallocate I +init y +allocate_zero t t +allocate_heap_zero I I I + +trim N Remaining => i_trim N +i_trim I + +test_heap I I + +allocate_heap S u==0 R => allocate S R +allocate_heap_zero S u==0 R => allocate_zero S R + +init2 y y +init3 y y y +init Y1 | init Y2 | init Y3 => init3 Y1 Y2 Y3 +init Y1 | init Y2 => init2 Y1 Y2 +%macro: init2 Init2 -pack +%macro: init3 Init3 -pack + +# +# Warning: The put_string instruction is specially treated in the loader. +# Don't change the instruction format unless you change the loader too. +# +put_string I I d + +# Selecting values + +select_val S=q Fail=f Size=u Rest=* => const_select_val(S, Fail, Size, Rest) + +select_val S=s Fail=f Size=u Rest=* | use_jump_tab(Size, Rest) => \ + gen_jump_tab(S, Fail, Size, Rest) + +is_integer Fail=f S | select_val S=s Fail=f Size=u Rest=* | use_jump_tab(Size, Rest) => \ + gen_jump_tab(S, Fail, Size, Rest) + +select_val S=s Fail=f Size=u Rest=* | mixed_types(Size, Rest) => \ + gen_split_values(S, Fail, Size, Rest) + +is_integer Fail=f S | select_val S=s Fail=f Size=u Rest=* | \ + fixed_size_values(Size, Rest) => gen_select_val(S, Fail, Size, Rest) + +is_atom Fail=f S | select_val S=s Fail=f Size=u Rest=* | \ + fixed_size_values(Size, Rest) => gen_select_val(S, Fail, Size, Rest) + +select_val S=s Fail=f Size=u Rest=* | fixed_size_values(Size, Rest) => \ + gen_select_val(S, Fail, Size, Rest) + +select_val S=s Fail=f Size=u Rest=* | all_values_are_big(Size, Rest) => \ + gen_select_big(S, Fail, Size, Rest) + +is_tuple Fail=f S | select_tuple_arity S=s Fail=f Size=u Rest=* => \ + gen_select_tuple_arity(S, Fail, Size, Rest) + +select_tuple_arity S=s Fail=f Size=u Rest=* => \ + gen_select_tuple_arity(S, Fail, Size, Rest) + +i_select_val s f I +i_select_tuple_arity s f I +i_select_big s f +i_select_float s f I + +i_jump_on_val_zero s f I +i_jump_on_val s f I I + +%macro: get_list GetList -pack +get_list x x x +get_list x x y +get_list x x r +get_list x y x +get_list x y y +get_list x y r +get_list x r x +get_list x r y + +get_list y x x +get_list y x y +get_list y x r +get_list y y x +get_list y y y +get_list y y r +get_list y r x +get_list y r y + +get_list r x x +get_list r x y +get_list r x r +get_list r y x +get_list r y y +get_list r y r +get_list r r x +get_list r r y + +# Old-style catch. +catch y f +catch_end y + +# Try/catch. +try Y F => catch Y F +try_case Y => try_end Y +try_end y + +try_case_end Literal=q => move Literal x | try_case_end x +try_case_end s + +# Destructive set tuple element + +set_tuple_element Lit=q Tuple Pos => move Lit x | set_tuple_element x Tuple Pos +set_tuple_element s d P + +# Get tuple element + +%macro: i_get_tuple_element GetTupleElement -pack +i_get_tuple_element x P x +i_get_tuple_element r P x +i_get_tuple_element y P x +i_get_tuple_element x P r +i_get_tuple_element y P r + +%cold +i_get_tuple_element r P r +i_get_tuple_element x P y +i_get_tuple_element r P y +i_get_tuple_element y P y +%hot + +%macro: is_number IsNumber -fail_action +%cold +is_number f r +is_number f x +is_number f y +%hot +is_number Fail=f i => +is_number Fail=f na => jump Fail +is_number Fail Literal=q => move Literal x | is_number Fail x + +jump f + +case_end Literal=q => move Literal x | case_end x +badmatch Literal=q => move Literal x | badmatch x + +case_end s +badmatch s +if_end +raise s s + +# Internal now, but could be useful to make known to the compiler. +badarg j +system_limit j + +move R R => + +move X1=x Y1=y | move X2=x Y2=y => move2 X1 Y1 X2 Y2 +move Y1=y X1=x | move Y2=y X2=x => move2 Y1 X1 Y2 X2 + +%macro: move2 Move2 -pack +move2 x y x y +move2 y x y x + +%macro:move Move -pack -gen_dest +move x x +move x y +move x r +move y x +move y r +move r x +move r y +move c r +move c x +move c y +move n x +move n r +move y y + +%cold +move s d +%hot + +# Receive operations. + +loop_rec Fail Src | smp_mark_target_label(Fail) => i_loop_rec Fail Src + +label L | wait_timeout Fail Src | smp_already_locked(L) => label L | i_wait_timeout_locked Fail Src +wait_timeout Fail Src => i_wait_timeout Fail Src +i_wait_timeout Fail Src=aiq => gen_literal_timeout(Fail, Src) +i_wait_timeout_locked Fail Src=aiq => gen_literal_timeout_locked(Fail, Src) + +label L | wait Fail | smp_already_locked(L) => label L | wait_locked Fail +wait Fail | smp() => wait_unlocked Fail + +label L | timeout | smp_already_locked(L) => label L | timeout_locked + +remove_message +timeout +timeout_locked +i_loop_rec f r +loop_rec_end f +wait f +wait_locked f +wait_unlocked f +i_wait_timeout f I +i_wait_timeout f s +i_wait_timeout_locked f I +i_wait_timeout_locked f s +i_wait_error +i_wait_error_locked + +send + +# +# Comparisions. +# + +is_eq_exact Lbl=f R=rxy C=ian => i_is_eq_immed Lbl R C +is_eq Lbl=f R=rxy C=an => i_is_eq_immed Lbl R C + +is_ge Lbl S1 S2 => i_fetch S1 S2 | i_is_ge Lbl +is_lt Lbl S1 S2 => i_fetch S1 S2 | i_is_lt Lbl +is_eq Lbl S1 S2 => i_fetch S1 S2 | i_is_eq Lbl +is_ne Lbl S1 S2 => i_fetch S1 S2 | i_is_ne Lbl + +is_eq_exact Lbl=f S1 S2 => i_fetch S1 S2 | i_is_eq_exact Lbl +is_ne_exact Lbl S1 S2 => i_fetch S1 S2 | i_is_ne_exact Lbl + +i_is_lt f +i_is_ge f +i_is_eq f +i_is_ne f +i_is_eq_exact f +i_is_ne_exact f + +%macro: i_is_eq_immed EqualImmed -fail_action +i_is_eq_immed f r c +i_is_eq_immed f x c +i_is_eq_immed f y c + +# +# Putting things. +# + +put_tuple u==0 Dst => i_put_tuple_only u Dst +put_tuple Arity Dst | put V => i_put_tuple Arity V Dst + +i_put_tuple_only A d + +%macro: i_put_tuple PutTuple -pack +i_put_tuple A x x +i_put_tuple A y x +i_put_tuple A r x +i_put_tuple A n x +i_put_tuple A c x +i_put_tuple A x y +i_put_tuple A x r +i_put_tuple A y r +i_put_tuple A n r +i_put_tuple A c r + +%cold +i_put_tuple A r y +i_put_tuple A y y +i_put_tuple A c y +%hot + +%macro:put_list PutList -pack -gen_dest + +put_list x n x +put_list y n x +put_list x x x +put_list y x x +put_list c n x +put_list x x r +put_list y r r +put_list c n r + +put_list y y x +put_list x y x +put_list r x x +put_list r y x +put_list r x r +put_list y y r +put_list y r x +put_list r n x + +# put_list SrcReg Constant Dst +put_list r c r +put_list r c x +put_list r c y + +put_list x c r +put_list x c x +put_list x c y + +put_list y c r +put_list y c x +put_list y c y + +# put_list Constant SrcReg Dst +put_list c r r +put_list c r x +put_list c r y + +put_list c x r +put_list c x x +put_list c x y + +put_list c y r +put_list c y x +put_list c y y + +%cold +put_list x r r +put_list s s d +%hot + +%macro: put Put +put x +put r +put y +put c +put n + +%macro: i_fetch FetchArgs -pack +i_fetch c c +i_fetch c r +i_fetch c x +i_fetch c y +i_fetch r c +i_fetch r x +i_fetch r y +i_fetch x c +i_fetch x r +i_fetch x x +i_fetch x y +i_fetch y c +i_fetch y r +i_fetch y x +i_fetch y y + +%cold +i_fetch s s +%hot + +# +# Some more only used by the emulator +# + +normal_exit +continue_exit +apply_bif +call_nif +call_error_handler +error_action_code +call_traced_function +return_trace + +# +# Instruction transformations & folded instructions. +# + +# Note: There is no 'move_return y r', since there never are any y registers +# when we do move_return (if we have y registers, we must do move_deallocate_return). + +move S r | return => move_return S r + +%macro: move_return MoveReturn -nonext +move_return x r +move_return c r +move_return n r + +move S r | deallocate D | return => move_deallocate_return S r D + +%macro: move_deallocate_return MoveDeallocateReturn -nonext +move_deallocate_return x r P +move_deallocate_return y r P +move_deallocate_return c r P +move_deallocate_return n r P + +deallocate D | return => deallocate_return D + +%macro: deallocate_return DeallocateReturn -nonext +deallocate_return P + +test_heap Need u==1 | put_list Y=y r r => test_heap_1_put_list Need Y + +test_heap_1_put_list I y + +# Test tuple & arity (head) + +is_tuple Fail Literal=q => move Literal x | is_tuple Fail x +is_tuple Fail=f c => jump Fail +is_tuple Fail=f S=rxy | test_arity Fail=f S=rxy Arity => is_tuple_of_arity Fail S Arity + +%macro:is_tuple_of_arity IsTupleOfArity -fail_action + +is_tuple_of_arity f x A +is_tuple_of_arity f y A +is_tuple_of_arity f r A + +%macro: is_tuple IsTuple -fail_action +is_tuple f x +is_tuple f y +is_tuple f r + +test_arity Fail Literal=q Arity => move Literal x | test_arity Fail x Arity +test_arity Fail=f c Arity => jump Fail + +%macro: test_arity IsArity -fail_action +test_arity f x A +test_arity f y A +test_arity f r A + +is_tuple_of_arity Fail=f Reg Arity | get_tuple_element Reg P=u==0 Dst=xy => \ + is_tuple_of_arity Fail Reg Arity | extract_next_element Dst | original_reg Reg P + +test_arity Fail Reg Arity | get_tuple_element Reg P=u==0 Dst=xy => \ + test_arity Fail Reg Arity | extract_next_element Dst | original_reg Reg P + +original_reg Reg P1 | get_tuple_element Reg P2 Dst=xy | succ(P1, P2) => \ + extract_next_element Dst | original_reg Reg P2 + +get_tuple_element Reg P Dst => i_get_tuple_element Reg P Dst | original_reg Reg P + +original_reg Reg Pos => + +get_tuple_element Reg P Dst => i_get_tuple_element Reg P Dst + +original_reg/2 + +extract_next_element D1=xy | original_reg Reg P1 | get_tuple_element Reg P2 D2=xy | \ +succ(P1, P2) | succ(D1, D2) => \ + extract_next_element2 D1 | original_reg Reg P2 + +extract_next_element2 D1=xy | original_reg Reg P1 | get_tuple_element Reg P2 D2=xy | \ +succ(P1, P2) | succ2(D1, D2) => \ + extract_next_element3 D1 | original_reg Reg P2 + +#extract_next_element3 D1=xy | original_reg Reg P1 | get_tuple_element Reg P2 D2=xy | \ +#succ(P1, P2) | succ3(D1, D2) => \ +# extract_next_element4 D1 | original_reg Reg P2 + +%macro: extract_next_element ExtractNextElement -pack +extract_next_element x +extract_next_element y + +%macro: extract_next_element2 ExtractNextElement2 -pack +extract_next_element2 x +extract_next_element2 y + +%macro: extract_next_element3 ExtractNextElement3 -pack +extract_next_element3 x +extract_next_element3 y + +#%macro: extract_next_element4 ExtractNextElement4 -pack +#extract_next_element4 x +#extract_next_element4 y + +is_integer Fail=f i => +is_integer Fail=f an => jump Fail +is_integer Fail Literal=q => move Literal x | is_integer Fail x + +is_integer Fail=f S=rx | allocate Need Regs => is_integer_allocate Fail S Need Regs + +%macro: is_integer_allocate IsIntegerAllocate -fail_action +is_integer_allocate f x I I +is_integer_allocate f r I I + +%macro: is_integer IsInteger -fail_action +is_integer f x +is_integer f y +is_integer f r + +is_list Fail=f n => +is_list Fail Literal=q => move Literal x | is_list Fail x +is_list Fail=f c => jump Fail +%macro: is_list IsList -fail_action +is_list f r +is_list f x +%cold +is_list f y +%hot + +is_nonempty_list Fail=f S=rx | allocate Need Rs => is_nonempty_list_allocate Fail S Need Rs + +%macro:is_nonempty_list_allocate IsNonemptyListAllocate -fail_action +is_nonempty_list_allocate f x I I +is_nonempty_list_allocate f r I I + +is_nonempty_list F=f r | test_heap I1 I2 => is_non_empty_list_test_heap F r I1 I2 + +%macro: is_non_empty_list_test_heap IsNonemptyListTestHeap -fail_action +is_non_empty_list_test_heap f r I I + +%macro: is_nonempty_list IsNonemptyList -fail_action +is_nonempty_list f x +is_nonempty_list f y +is_nonempty_list f r + +%macro: is_atom IsAtom -fail_action +is_atom f x +is_atom f r +%cold +is_atom f y +%hot +is_atom Fail=f a => +is_atom Fail=f niq => jump Fail + +%macro: is_float IsFloat -fail_action +is_float f r +is_float f x +%cold +is_float f y +%hot +is_float Fail=f nai => jump Fail +is_float Fail Literal=q => move Literal x | is_float Fail x + +is_nil Fail=f n => +is_nil Fail=f qia => jump Fail + +%macro: is_nil IsNil -fail_action +is_nil f x +is_nil f y +is_nil f r + +is_binary Fail Literal=q => move Literal x | is_binary Fail x +is_binary Fail=f c => jump Fail +%macro: is_binary IsBinary -fail_action +is_binary f r +is_binary f x +%cold +is_binary f y +%hot + +# XXX Deprecated. +is_bitstr Fail Term => is_bitstring Fail Term + +is_bitstring Fail Literal=q => move Literal x | is_bitstring Fail x +is_bitstring Fail=f c => jump Fail +%macro: is_bitstring IsBitstring -fail_action +is_bitstring f r +is_bitstring f x +%cold +is_bitstring f y +%hot + +is_reference Fail=f cq => jump Fail +%macro: is_reference IsRef -fail_action +is_reference f r +is_reference f x +%cold +is_reference f y +%hot + +is_pid Fail=f cq => jump Fail +%macro: is_pid IsPid -fail_action +is_pid f r +is_pid f x +%cold +is_pid f y +%hot + +is_port Fail=f cq => jump Fail +%macro: is_port IsPort -fail_action +is_port f r +is_port f x +%cold +is_port f y +%hot + +is_boolean Fail=f a==am_true => +is_boolean Fail=f a==am_false => +is_boolean Fail=f ac => jump Fail + +%cold +%macro: is_boolean IsBoolean -fail_action +is_boolean f r +is_boolean f x +is_boolean f y +%hot + +is_function2 Fail=f acq Arity => jump Fail +is_function2 Fail=f Fun a => jump Fail +is_function2 Fail Fun Literal=q => move Literal x | is_function2 Fail Fun x + +is_function2 f s s +%macro: is_function2 IsFunction2 -fail_action + +# Allocating & initializing. +allocate Need Regs | init Y => allocate_init Need Regs Y +init Y1 | init Y2 => init2 Y1 Y2 + +%macro: allocate_init AllocateInit -pack +allocate_init t I y + +################################################################# +# External function and bif calls. +################################################################# + +# +# The BIFs erlang:check_process_code/2 must be called like a function, +# to ensure that c_p->i (program counter) is set correctly (an ordinary +# BIF call doesn't set it). +# + +call_ext u==2 Bif=u$bif:erlang:check_process_code/2 => i_call_ext Bif +call_ext_last u==2 Bif=u$bif:erlang:check_process_code/2 D => i_call_ext_last Bif D +call_ext_only u==2 Bif=u$bif:erlang:check_process_code/2 => i_call_ext_only Bif + +# +# The BIFs erlang:garbage_collect/0,1 must be called like functions, +# to allow them to invoke the garbage collector. (The stack pointer must +# be saved and p->arity must be zeroed, which is not done on ordinary BIF calls.) +# + +call_ext u==0 Bif=u$bif:erlang:garbage_collect/0 => i_call_ext Bif +call_ext_last u==0 Bif=u$bif:erlang:garbage_collect/0 D => i_call_ext_last Bif D +call_ext_only u==0 Bif=u$bif:erlang:garbage_collect/0 => i_call_ext_only Bif + +call_ext u==1 Bif=u$bif:erlang:garbage_collect/1 => i_call_ext Bif +call_ext_last u==1 Bif=u$bif:erlang:garbage_collect/1 D => i_call_ext_last Bif D +call_ext_only u==1 Bif=u$bif:erlang:garbage_collect/1 => i_call_ext_only Bif + +# +# put/2 and erase/1 must be able to do garbage collection, so we must call +# them like functions. +# + +call_ext u==2 Bif=u$bif:erlang:put/2 => i_call_ext Bif +call_ext_last u==2 Bif=u$bif:erlang:put/2 D => i_call_ext_last Bif D +call_ext_only u==2 Bif=u$bif:erlang:put/2 => i_call_ext_only Bif + +call_ext u==1 Bif=u$bif:erlang:erase/1 => i_call_ext Bif +call_ext_last u==1 Bif=u$bif:erlang:erase/1 D => i_call_ext_last Bif D +call_ext_only u==1 Bif=u$bif:erlang:erase/1 => i_call_ext_only Bif + +# +# The process_info/1,2 BIF should be called like a function, to force +# the emulator to set c_p->current before calling it (a BIF call doesn't +# set it). +# +# In addition, we force the use of a non-tail-recursive call. This will ensure +# that c_p->cp points into the function making the call. +# + +call_ext u==1 Bif=u$bif:erlang:process_info/1 => i_call_ext Bif +call_ext_last u==1 Bif=u$bif:erlang:process_info/1 D => i_call_ext Bif | deallocate_return D +call_ext_only Ar=u==1 Bif=u$bif:erlang:process_info/1 => allocate u Ar | i_call_ext Bif | deallocate_return u + +call_ext u==2 Bif=u$bif:erlang:process_info/2 => i_call_ext Bif +call_ext_last u==2 Bif=u$bif:erlang:process_info/2 D => i_call_ext Bif | deallocate_return D +call_ext_only Ar=u==2 Bif=u$bif:erlang:process_info/2 => allocate u Ar | i_call_ext Bif | deallocate_return u + +# +# load_nif/2 also needs to know calling function like process_info +# +call_ext u==2 Bif=u$bif:erlang:load_nif/2 => i_call_ext Bif +call_ext_last u==2 Bif=u$bif:erlang:load_nif/2 D => i_call_ext Bif | deallocate_return D +call_ext_only Ar=u==2 Bif=u$bif:erlang:load_nif/2 => allocate u Ar | i_call_ext Bif | deallocate_return u + + +# +# The apply/2 and apply/3 BIFs are instructions. +# + +call_ext u==2 u$func:erlang:apply/2 => i_apply_fun +call_ext_last u==2 u$func:erlang:apply/2 D => i_apply_fun_last D +call_ext_only u==2 u$func:erlang:apply/2 => i_apply_fun_only + +call_ext u==3 u$func:erlang:apply/3 => i_apply +call_ext_last u==3 u$func:erlang:apply/3 D => i_apply_last D +call_ext_only u==3 u$func:erlang:apply/3 => i_apply_only + +# +# The exit/1 and throw/1 BIFs never execute the instruction following them; +# thus there is no need to generate any return instruction. +# + +call_ext_last u==1 Bif=u$bif:erlang:exit/1 D => call_bif1 Bif +call_ext_last u==1 Bif=u$bif:erlang:throw/1 D => call_bif1 Bif + +call_ext_only u==1 Bif=u$bif:erlang:exit/1 => call_bif1 Bif +call_ext_only u==1 Bif=u$bif:erlang:throw/1 => call_bif1 Bif + +# +# The error/1 and error/2 BIFs never execute the instruction following them; +# thus there is no need to generate any return instruction. +# However, they generate stack backtraces, so if the call instruction +# is call_ext_only/2 instruction, we explicitly do an allocate/2 to store +# the continuation pointer on the stack. +# + +call_ext_last u==1 Bif=u$bif:erlang:error/1 D => call_bif1 Bif +call_ext_last u==2 Bif=u$bif:erlang:error/2 D => call_bif2 Bif + +call_ext_only Ar=u==1 Bif=u$bif:erlang:error/1 => \ + allocate u Ar | call_bif1 Bif +call_ext_only Ar=u==2 Bif=u$bif:erlang:error/2 => \ + allocate u Ar | call_bif2 Bif + +# +# The yield/0 BIF is an instruction +# + +call_ext u==0 u$func:erlang:yield/0 => i_yield +call_ext_last u==0 u$func:erlang:yield/0 D => i_yield | deallocate_return D +call_ext_only u==0 u$func:erlang:yield/0 => i_yield | return + +# +# The hibernate/3 BIF is an instruction. +# +call_ext u==3 u$func:erlang:hibernate/3 => i_hibernate +call_ext_last u==3 u$func:erlang:hibernate/3 D => i_hibernate +call_ext_only u==3 u$func:erlang:hibernate/3 => i_hibernate + +# +# Hybrid memory architecture need special cons and tuple instructions +# that allocate on the message area. These looks like BIFs in the BEAM code. +# + +call_ext u==2 u$func:hybrid:cons/2 => i_global_cons +call_ext_last u==2 u$func:hybrid:cons/2 D => i_global_cons | deallocate_return D +call_ext_only Ar=u==2 u$func:hybrid:cons/2 => i_global_cons | return + +call_ext u==1 u$func:hybrid:tuple/1 => i_global_tuple +call_ext_last u==1 u$func:hybrid:tuple/1 D => i_global_tuple | deallocate_return D +call_ext_only Ar=u==1 u$func:hybrid:tuple/1 => i_global_tuple | return + +call_ext u==1 u$func:hybrid:copy/1 => i_global_copy +call_ext_last u==1 u$func:hybrid:copy/1 D => i_global_copy | deallocate_return D +call_ext_only u==1 Ar=u$func:hybrid:copy/1 => i_global_copy | return + +# +# The general case for BIFs that have no special instructions. +# A BIF used in the tail must be followed by a return instruction. +# +# To make trapping and stack backtraces work correctly, we make sure that +# the continuation pointer is always stored on the stack. + +call_ext u==0 Bif=u$is_bif => call_bif0 Bif +call_ext u==1 Bif=u$is_bif => call_bif1 Bif +call_ext u==2 Bif=u$is_bif => call_bif2 Bif +call_ext u==3 Bif=$is_bif => call_bif3 Bif + +call_ext_last u==0 Bif=u$is_bif D => call_bif0 Bif | deallocate_return D +call_ext_last u==1 Bif=u$is_bif D => call_bif1 Bif | deallocate_return D +call_ext_last u==2 Bif=u$is_bif D => call_bif2 Bif | deallocate_return D +call_ext_last u==3 Bif=u$is_bif D => call_bif3 Bif | deallocate_return D + +call_ext_only Ar=u==0 Bif=u$is_bif => \ + allocate u Ar | call_bif0 Bif | deallocate_return u +call_ext_only Ar=u==1 Bif=u$is_bif => \ + allocate u Ar | call_bif1 Bif | deallocate_return u +call_ext_only Ar=u==2 Bif=u$is_bif => \ + allocate u Ar | call_bif2 Bif | deallocate_return u +call_ext_only Ar=u==3 Bif=u$is_bif => \ + allocate u Ar | call_bif3 Bif | deallocate_return u + +# +# Any remaining calls are calls to Erlang functions, not BIFs. +# We rename the instructions to internal names. This is necessary, +# to avoid an end-less loop, because we want to call a few BIFs +# with call instructions. +# + +move S=c r | call_ext Ar=u Func=u$is_not_bif => i_move_call_ext S r Func +move S=c r | call_ext_last Ar=u Func=u$is_not_bif D => i_move_call_ext_last Func D S r +move S=c r | call_ext_only Ar=u Func=u$is_not_bif => i_move_call_ext_only Func S r + +call_ext Ar=u Func => i_call_ext Func +call_ext_last Ar=u Func D => i_call_ext_last Func D +call_ext_only Ar=u Func => i_call_ext_only Func + +i_apply +i_apply_last P +i_apply_only + +i_apply_fun +i_apply_fun_last P +i_apply_fun_only + +i_hibernate + +call_bif0 e +call_bif1 e +call_bif2 e +call_bif3 e + +# +# Calls to non-building and guard BIFs. +# + +bif0 u$bif:erlang:self/0 Dst=d => self Dst +bif0 u$bif:erlang:node/0 Dst=d => node Dst + +bif1 Fail Bif=u$bif:erlang:get/1 Src=s Dst=d => i_get Src Dst + +bif2 Jump=j u$bif:erlang:element/2 S1=s S2=s Dst=d => gen_element(Jump, S1, S2, Dst) + +bif1 Fail Bif Literal=q Dst => move Literal x | bif1 Fail Bif x Dst +bif1 p Bif S1 Dst => bif1_body Bif S1 Dst + +bif1_body Bif Literal=q Dst => move Literal x | bif1_body Bif x Dst + +bif2 p Bif S1 S2 Dst => i_fetch S1 S2 | i_bif2_body Bif Dst +bif2 Fail=f Bif S1 S2 Dst => i_fetch S1 S2 | i_bif2 Fail Bif Dst + +i_get s d + +%macro: self Self +self r +self x +self y + +%macro: node Node +node r +node x +%cold +node y +%hot + +i_fast_element j I s d +i_element j s s d + +bif1 f b s d +bif1_body b s d +i_bif2 f b d +i_bif2_body b d + +# +# Internal calls. +# + +move S=c r | call Ar P=f => i_move_call S r P +move S=s r | call Ar P=f => move_call S r P + +i_move_call c r f + +%macro:move_call MoveCall -arg_f -size -nonext +move_call/3 + +move_call x r f +move_call y r f + +move S=c r | call_last Ar P=f D => i_move_call_last P D S r +move S r | call_last Ar P=f D => move_call_last S r P D + +i_move_call_last f P c r + +%macro:move_call_last MoveCallLast -arg_f -nonext + +move_call_last/4 +move_call_last x r f P +move_call_last y r f P + +move S=c r | call_only Ar P=f => i_move_call_only P S r +move S=x r | call_only Ar P=f => move_call_only S r P + +i_move_call_only f c r + +%macro:move_call_only MoveCallOnly -arg_f -nonext +move_call_only/3 + +move_call_only x r f + +call Ar Func => i_call Func +call_last Ar Func D => i_call_last Func D +call_only Ar Func => i_call_only Func + +i_call f +i_call_last f P +i_call_only f + +i_call_ext e +i_call_ext_last e P +i_call_ext_only e + +i_move_call_ext c r e +i_move_call_ext_last e P c r +i_move_call_ext_only e c r + +# Fun calls. + +call_fun Arity=u | deallocate D | return => i_call_fun_last Arity D +call_fun Arity=u => i_call_fun Arity + +i_call_fun I +i_call_fun_last I P + +make_fun2 OldIndex=u => gen_make_fun2(OldIndex) + +%macro: i_make_fun MakeFun -pack +%cold +i_make_fun I t +%hot + +%macro: is_function IsFunction -fail_action +is_function f x +is_function f y +is_function f r +is_function Fail=f c => jump Fail + +func_info M=a F=a A=u | label L => gen_func_info(M, F, A, L) + +# ================================================================ +# New bit syntax matching (R11B). +# ================================================================ + +%cold +bs_start_match2 Fail=f ica X Y D => jump Fail +bs_start_match2 Fail Bin X Y D => i_bs_start_match2 Bin Fail X Y D +i_bs_start_match2 r f I I d +i_bs_start_match2 x f I I d +i_bs_start_match2 y f I I d + +bs_save2 Reg Index => gen_bs_save(Reg, Index) +i_bs_save2 r I +i_bs_save2 x I + +bs_restore2 Reg Index => gen_bs_restore(Reg, Index) +i_bs_restore2 r I +i_bs_restore2 x I + +# Matching integers +bs_match_string Fail Ms Bits Val => i_bs_match_string Ms Fail Bits Val + +i_bs_match_string r f I I +i_bs_match_string x f I I + +# Fetching integers from binaries. +bs_get_integer2 Fail=f Ms=rx Live=u Sz=sq Unit=u Flags=u Dst=d => \ + gen_get_integer2(Fail, Ms, Live, Sz, Unit, Flags, Dst) + +i_bs_get_integer_small_imm r I f I d +i_bs_get_integer_small_imm x I f I d +i_bs_get_integer_imm r I I f I d +i_bs_get_integer_imm x I I f I d +i_bs_get_integer f I I d +i_bs_get_integer_8 r f d +i_bs_get_integer_8 x f d +i_bs_get_integer_16 r f d +i_bs_get_integer_16 x f d +i_bs_get_integer_32 r f I d +i_bs_get_integer_32 x f I d + +# Fetching binaries from binaries. +bs_get_binary2 Fail=f Ms=rx Live=u Sz=sq Unit=u Flags=u Dst=d => \ + gen_get_binary2(Fail, Ms, Live, Sz, Unit, Flags, Dst) + +%macro: i_bs_get_binary_imm2 BsGetBinaryImm_2 -fail_action -gen_dest +%macro: i_bs_get_binary2 BsGetBinary_2 -fail_action -gen_dest +%macro: i_bs_get_binary_all2 BsGetBinaryAll_2 -fail_action -gen_dest + +i_bs_get_binary_imm2 f r I I I d +i_bs_get_binary_imm2 f x I I I d +i_bs_get_binary2 f r I s I d +i_bs_get_binary2 f x I s I d +i_bs_get_binary_all2 f r I I d +i_bs_get_binary_all2 f x I I d +i_bs_get_binary_all_reuse r f I +i_bs_get_binary_all_reuse x f I + +# Fetching float from binaries. +bs_get_float2 Fail=f Ms=rx Live=u Sz=s Unit=u Flags=u Dst=d => \ + gen_get_float2(Fail, Ms, Live, Sz, Unit, Flags, Dst) + +bs_get_float2 Fail=f Ms=rx Live=u Sz=q Unit=u Flags=u Dst=d => jump Fail + +%macro: i_bs_get_float2 BsGetFloat2 -fail_action -gen_dest +i_bs_get_float2 f r I s I d +i_bs_get_float2 f x I s I d + +# Miscellanous + +bs_skip_bits2 Fail=f Ms=rx Sz=s Unit=u Flags=u => \ + gen_skip_bits2(Fail, Ms, Sz, Unit, Flags) +bs_skip_bits2 Fail=f Ms=rx Sz=q Unit=u Flags=u => \ + gen_skip_bits2(Fail, Ms, Sz, Unit, Flags) + +%macro: i_bs_skip_bits_imm2 BsSkipBitsImm2 -fail_action +i_bs_skip_bits_imm2 f r I +i_bs_skip_bits_imm2 f x I + +%macro: i_bs_skip_bits2 BsSkipBits2 -fail_action +i_bs_skip_bits2 f r x I +i_bs_skip_bits2 f r y I +i_bs_skip_bits2 f x x I +i_bs_skip_bits2 f x r I +i_bs_skip_bits2 f x y I + +%macro: i_bs_skip_bits_all2 BsSkipBitsAll2 -fail_action +i_bs_skip_bits_all2 f r I +i_bs_skip_bits_all2 f x I + +bs_test_tail2 Fail=f Ms=rx Bits=u==0 => bs_test_zero_tail2 Fail Ms +bs_test_tail2 Fail=f Ms=rx Bits=u => bs_test_tail_imm2 Fail Ms Bits +bs_test_zero_tail2 f r +bs_test_zero_tail2 f x +bs_test_tail_imm2 f r I +bs_test_tail_imm2 f x I + +bs_test_unit F Ms Unit=u==8 => bs_test_unit8 F Ms +bs_test_unit f r I +bs_test_unit f x I +bs_test_unit8 f r +bs_test_unit8 f x + +bs_context_to_binary r +bs_context_to_binary x +bs_context_to_binary y + +# +# Utf8/utf16/utf32 support. (R12B-5) +# +bs_get_utf8 Fail=f Ms=rx u u Dst=d => i_bs_get_utf8 Ms Fail Dst +i_bs_get_utf8 r f d +i_bs_get_utf8 x f d + +bs_skip_utf8 Fail=f Ms=rx u u => i_bs_get_utf8 Ms Fail x + +bs_get_utf16 Fail=f Ms=rx u Flags=u Dst=d => i_bs_get_utf16 Ms Fail Flags Dst +bs_skip_utf16 Fail=f Ms=rx u Flags=u => i_bs_get_utf16 Ms Fail Flags x + +i_bs_get_utf16 r f I d +i_bs_get_utf16 x f I d + +bs_get_utf32 Fail=f Ms=rx Live=u Flags=u Dst=d => \ + bs_get_integer2 Fail Ms Live i=32 u=1 Flags Dst | \ + i_fetch Dst Ms | \ + i_bs_validate_unicode_retract Fail +bs_skip_utf32 Fail=f Ms=rx Live=u Flags=u => \ + bs_get_integer2 Fail Ms Live i=32 u=1 Flags x | \ + i_fetch x Ms | \ + i_bs_validate_unicode_retract Fail + +i_bs_validate_unicode_retract j +%hot + +# +# Constructing binaries +# +%cold + +bs_init2 Fail Sz Words Regs Flags Dst | binary_too_big(Sz) => system_limit Fail + +bs_init2 Fail Sz=u Words=u==0 Regs Flags Dst | should_gen_heap_bin(Sz) => \ + i_bs_init_heap_bin Sz Regs Dst +bs_init2 Fail Sz=u Words=u==0 Regs Flags Dst => i_bs_init Sz Regs Dst + +bs_init2 Fail Sz=u Words Regs Flags Dst | should_gen_heap_bin(Sz) => \ + i_bs_init_heap_bin_heap Sz Words Regs Dst +bs_init2 Fail Sz=u Words Regs Flags Dst => \ + i_bs_init_heap Sz Words Regs Dst + +bs_init2 Fail Sz Words=u==0 Regs Flags Dst => \ + i_bs_init_fail Sz Fail Regs Dst +bs_init2 Fail Sz Words Regs Flags Dst => \ + i_fetch Sz r | i_bs_init_fail_heap Words Fail Regs Dst + +i_bs_init_fail r j I d +i_bs_init_fail x j I d +i_bs_init_fail y j I d + +i_bs_init_fail_heap I j I d + +i_bs_init I I d +i_bs_init_heap_bin I I d + +i_bs_init_heap I I I d +i_bs_init_heap_bin_heap I I I d + + +bs_init_bits Fail Sz Words Regs Flags Dst | binary_too_big_bits(Sz) => system_limit Fail + +bs_init_bits Fail Sz=u Words=u==0 Regs Flags Dst => i_bs_init_bits Sz Regs Dst +bs_init_bits Fail Sz=u Words Regs Flags Dst => i_bs_init_bits_heap Sz Words Regs Dst + +bs_init_bits Fail Sz Words=u==0 Regs Flags Dst => \ + i_bs_init_bits_fail Sz Fail Regs Dst +bs_init_bits Fail Sz Words Regs Flags Dst => \ + i_fetch Sz r | i_bs_init_bits_fail_heap Words Fail Regs Dst + +i_bs_init_bits_fail r j I d +i_bs_init_bits_fail x j I d +i_bs_init_bits_fail y j I d + +i_bs_init_bits_fail_heap I j I d + +i_bs_init_bits I I d +i_bs_init_bits_heap I I I d + +bs_bits_to_bytes Fail Src Dst => i_bs_bits_to_bytes Src Fail Dst + +i_bs_bits_to_bytes r j d +i_bs_bits_to_bytes x j d +i_bs_bits_to_bytes y j d + +bs_add Fail S1=i==0 S2 Unit=u==1 D => move S2 D +bs_add Fail S1 S2 Unit D => i_fetch S1 S2 | i_bs_add Fail Unit D + +i_bs_add j I d + +bs_append Fail Size Extra Live Unit Bin Flags Dst => \ + i_fetch Size Bin | i_bs_append Fail Extra Live Unit Dst + +bs_private_append Fail Size Unit Bin Flags Dst => \ + i_fetch Size Bin | i_bs_private_append Fail Unit Dst + +bs_init_writable + +i_bs_append j I I I d +i_bs_private_append j I d + +# +# Storing integers into binaries. +# + +bs_put_integer Fail=j Sz=s Unit=u Flags=u Literal=q => \ + move Literal x | bs_put_integer Fail Sz Unit Flags x +bs_put_integer Fail=j Sz=sq Unit=u Flags=u Src=s => \ + gen_put_integer(Fail, Sz, Unit, Flags, Src) + +%macro: i_new_bs_put_integer NewBsPutInteger +%macro: i_new_bs_put_integer_imm NewBsPutIntegerImm + +i_new_bs_put_integer j s I s +i_new_bs_put_integer_imm j I I s + +# +# Utf8/utf16/utf32 support. (R12B-5) +# + +bs_utf8_size Fail Literal=q Dst=d => \ + move Literal x | bs_utf8_size Fail x Dst +bs_utf8_size j Src=s Dst=d => i_bs_utf8_size Src Dst + +i_bs_utf8_size s d + +bs_utf16_size Fail Literal=q Dst=d => \ + move Literal x | bs_utf16_size Fail x Dst +bs_utf16_size j Src=s Dst=d => i_bs_utf16_size Src Dst + +i_bs_utf16_size s d + +bs_put_utf8 Fail=j Flags=u Literal=q => \ + move Literal x | bs_put_utf8 Fail Flags x +bs_put_utf8 Fail=j u Src=s => i_bs_put_utf8 Fail Src + +i_bs_put_utf8 j s + +bs_put_utf16 Fail=j Flags=u Literal=q => \ + move Literal x | bs_put_utf16 Fail Flags x +bs_put_utf16 Fail=j Flags=u Src=s => i_bs_put_utf16 Fail Flags Src + +i_bs_put_utf16 j I s + +bs_put_utf32 Fail=j Flags=u Literal=q => \ + move Literal x | bs_put_utf32 Fail Flags x +bs_put_utf32 Fail=j Flags=u Src=s => \ + i_bs_validate_unicode Fail Src | bs_put_integer Fail i=32 u=1 Flags Src + +i_bs_validate_unicode j s + +# +# Storing floats into binaries. +# +bs_put_float Fail Sz=q Unit Flags Val => badarg Fail + +bs_put_float Fail=j Sz Unit=u Flags=u Literal=q => \ + move Literal x | bs_put_float Fail Sz Unit Flags x + +bs_put_float Fail=j Sz=s Unit=u Flags=u Src=s => \ + gen_put_float(Fail, Sz, Unit, Flags, Src) + +%macro: i_new_bs_put_float NewBsPutFloat +%macro: i_new_bs_put_float_imm NewBsPutFloatImm + +i_new_bs_put_float j s I s +i_new_bs_put_float_imm j I I s + +# +# Storing binaries into binaries. +# + +bs_put_binary Fail Sz Unit Flags Literal=q => \ + move Literal x | bs_put_binary Fail Sz Unit Flags x +bs_put_binary Fail=j Sz=s Unit=u Flags=u Src=s => \ + gen_put_binary(Fail, Sz, Unit, Flags, Src) + +%macro: i_new_bs_put_binary NewBsPutBinary +i_new_bs_put_binary j s I s + +%macro: i_new_bs_put_binary_imm NewBsPutBinaryImm +i_new_bs_put_binary_imm j I s + +%macro: i_new_bs_put_binary_all NewBsPutBinaryAll +i_new_bs_put_binary_all j s I + +# +# Warning: The i_bs_put_string and i_new_bs_put_string instructions +# are specially treated in the loader. +# Don't change the instruction format unless you change the loader too. +# + +bs_put_string I I + +%hot + +# +# New floating point instructions (R8). +# + +fadd p FR1 FR2 FR3 => i_fadd FR1 FR2 FR3 +fsub p FR1 FR2 FR3 => i_fsub FR1 FR2 FR3 +fmul p FR1 FR2 FR3 => i_fmul FR1 FR2 FR3 +fdiv p FR1 FR2 FR3 => i_fdiv FR1 FR2 FR3 +fnegate p FR1 FR2 => i_fnegate FR1 FR2 + +fconv Int=iq Dst=l => move Int x | fconv x Dst + +fmove q l +fmove d l +fconv d l + +i_fadd l l l +i_fsub l l l +i_fmul l l l +i_fdiv l l l +i_fnegate l l + +fclearerror | no_fpe_signals() => +fcheckerror p | no_fpe_signals() => +fcheckerror p => i_fcheckerror + +i_fcheckerror +fclearerror + +fmove FR=l Dst=d | new_float_allocation() => fmove_new FR Dst + +# The new instruction for moving a float out of a floating point register. +# (No allocation.) +fmove_new l d + +# +# New apply instructions in R10B. +# + +apply I +apply_last I P + +# +# New GCing arithmetic instructions. +# + +gc_bif2 Fail I u$bif:erlang:splus/2 S1 S2 Dst=d => i_fetch S1 S2 | i_plus Fail I Dst +gc_bif2 Fail I u$bif:erlang:sminus/2 S1 S2 Dst=d => i_fetch S1 S2 | i_minus Fail I Dst +gc_bif2 Fail I u$bif:erlang:stimes/2 S1 S2 Dst=d => i_fetch S1 S2 | i_times Fail I Dst +gc_bif2 Fail I u$bif:erlang:div/2 S1 S2 Dst=d => i_fetch S1 S2 | i_m_div Fail I Dst + +gc_bif2 Fail I u$bif:erlang:intdiv/2 S1 S2 Dst=d => i_fetch S1 S2 | i_int_div Fail I Dst +gc_bif2 Fail I u$bif:erlang:rem/2 S1 S2 Dst=d => i_fetch S1 S2 | i_rem Fail I Dst + +gc_bif2 Fail I u$bif:erlang:bsl/2 S1 S2 Dst=d => i_fetch S1 S2 | i_bsl Fail I Dst +gc_bif2 Fail I u$bif:erlang:bsr/2 S1 S2 Dst=d => i_fetch S1 S2 | i_bsr Fail I Dst + +gc_bif2 Fail I u$bif:erlang:band/2 S1 S2 Dst=d => i_fetch S1 S2 | i_band Fail I Dst +gc_bif2 Fail I u$bif:erlang:bor/2 S1 S2 Dst=d => i_fetch S1 S2 | i_bor Fail I Dst +gc_bif2 Fail I u$bif:erlang:bxor/2 S1 S2 Dst=d => i_fetch S1 S2 | i_bxor Fail I Dst + +gc_bif1 Fail I u$bif:erlang:bnot/1 Src Dst=d => i_int_bnot Fail Src I Dst + +gc_bif1 Fail I u$bif:erlang:sminus/1 Src Dst=d => i_fetch i Src | i_minus Fail I Dst +gc_bif1 Fail I u$bif:erlang:splus/1 Src Dst=d => i_fetch i Src | i_plus Fail I Dst + +i_plus j I d +i_minus j I d +i_times j I d +i_m_div j I d +i_int_div j I d +i_rem j I d + +i_bsl j I d +i_bsr j I d + +i_band j I d +i_bor j I d +i_bxor j I d + +i_int_bnot j s I d + +# +# Old guard BIFs that creates heap fragments are no longer allowed. +# +bif1 Fail u$bif:erlang:length/1 s d => too_old_compiler +bif1 Fail u$bif:erlang:size/1 s d => too_old_compiler +bif1 Fail u$bif:erlang:abs/1 s d => too_old_compiler +bif1 Fail u$bif:erlang:float/1 s d => too_old_compiler +bif1 Fail u$bif:erlang:round/1 s d => too_old_compiler +bif1 Fail u$bif:erlang:trunc/1 s d => too_old_compiler + +# +# Guard BIFs. +# +gc_bif1 Fail I Bif=u$bif:erlang:length/1 Src Dst=d => \ + gen_guard_bif(Fail, I, Bif, Src, Dst) + +gc_bif1 Fail I Bif=u$bif:erlang:size/1 Src Dst=d => \ + gen_guard_bif(Fail, I, Bif, Src, Dst) + +gc_bif1 Fail I Bif=u$bif:erlang:bit_size/1 Src Dst=d => \ + gen_guard_bif(Fail, I, Bif, Src, Dst) + +gc_bif1 Fail I Bif=u$bif:erlang:byte_size/1 Src Dst=d => \ + gen_guard_bif(Fail, I, Bif, Src, Dst) + +gc_bif1 Fail I Bif=u$bif:erlang:abs/1 Src Dst=d => \ + gen_guard_bif(Fail, I, Bif, Src, Dst) + +gc_bif1 Fail I Bif=u$bif:erlang:float/1 Src Dst=d => \ + gen_guard_bif(Fail, I, Bif, Src, Dst) + +gc_bif1 Fail I Bif=u$bif:erlang:round/1 Src Dst=d => \ + gen_guard_bif(Fail, I, Bif, Src, Dst) + +gc_bif1 Fail I Bif=u$bif:erlang:trunc/1 Src Dst=d => \ + gen_guard_bif(Fail, I, Bif, Src, Dst) + +i_gc_bif1 Fail Bif V=q Live D => move V x | i_gc_bif1 Fail Bif x Live D + +i_gc_bif1 j I s I d + +# +# R13B03 +# +on_load diff --git a/erts/emulator/beam/packet_parser.c b/erts/emulator/beam/packet_parser.c new file mode 100644 index 0000000000..8c8029d450 --- /dev/null +++ b/erts/emulator/beam/packet_parser.c @@ -0,0 +1,847 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2008-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* A protocol decoder. Simple packet length extraction as well as packet + * body parsing with protocol specific callback interfaces (http and ssl). + * + * Code ripped out from inet_drv.c to also be used by BIF decode_packet. + */ +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "packet_parser.h" + +#include +#include "sys.h" + +/* #define INET_DRV_DEBUG 1 */ +#ifdef INET_DRV_DEBUG +# define DEBUG 1 +# undef DEBUGF +# define DEBUGF(X) printf X +#endif + +#define get_int24(s) ((((unsigned char*) (s))[0] << 16) | \ + (((unsigned char*) (s))[1] << 8) | \ + (((unsigned char*) (s))[2])) + +#define get_little_int32(s) ((((unsigned char*) (s))[3] << 24) | \ + (((unsigned char*) (s))[2] << 16) | \ + (((unsigned char*) (s))[1] << 8) | \ + (((unsigned char*) (s))[0])) + +#define put_int24(s, x) ((((unsigned char*)(s))[0] = ((x) >> 16) & 0xff), \ + (((unsigned char*)(s))[1] = ((x) >> 8) & 0xff), \ + (((unsigned char*)(s))[2] = (x) & 0xff)) + + +#if !defined(__WIN32__) && !defined(HAVE_STRNCASECMP) +#define STRNCASECMP my_strncasecmp + +static int my_strncasecmp(const char *s1, const char *s2, size_t n) +{ + int i; + + for (i=0;i 32) && ((x) < 128)) ? tspecial[(x)] : 1) + +#define hash_update(h,c) do { \ + unsigned long __g; \ + (h) = ((h) << 4) + (c); \ + if ((__g = (h) & 0xf0000000)) { \ + (h) ^= (__g >> 24); \ + (h) ^= __g; \ + } \ + } while(0) + +static void http_hash_insert(const char* name, http_atom_t* entry, + http_atom_t** hash, int hsize) +{ + unsigned long h = 0; + const unsigned char* ptr = (const unsigned char*) name; + int ix; + int len = 0; + + while (*ptr != '\0') { + hash_update(h, *ptr); + ptr++; + len++; + } + ix = h % hsize; + + entry->next = hash[ix]; + entry->h = h; + entry->name = name; + entry->len = len; + entry->atom = driver_mk_atom((char*)name); + + hash[ix] = entry; +} + + +static int http_init(void) +{ + int i; + unsigned char* ptr; + + for (i = 0; i < 33; i++) + tspecial[i] = 1; + for (i = 33; i < 127; i++) + tspecial[i] = 0; + for (ptr = (unsigned char*)"()<>@,;:\\\"/[]?={} \t"; *ptr != '\0'; ptr++) + tspecial[*ptr] = 1; + + for (i = 0; i < HTTP_HDR_HASH_SIZE; i++) + http_hdr_hash[i] = NULL; + for (i = 0; http_hdr_strings[i] != NULL; i++) { + ASSERT(strlen(http_hdr_strings[i]) <= HTTP_MAX_NAME_LEN); + http_hdr_table[i].index = i; + http_hash_insert(http_hdr_strings[i], + &http_hdr_table[i], + http_hdr_hash, HTTP_HDR_HASH_SIZE); + } + + for (i = 0; i < HTTP_METH_HASH_SIZE; i++) + http_meth_hash[i] = NULL; + for (i = 0; http_meth_strings[i] != NULL; i++) { + http_meth_table[i].index = i; + http_hash_insert(http_meth_strings[i], + &http_meth_table[i], + http_meth_hash, HTTP_METH_HASH_SIZE); + } + return 0; +} + + +#define CDR_MAGIC "GIOP" + +struct cdr_head { + unsigned char magic[4]; /* 4 bytes must be 'GIOP' */ + unsigned char major; /* major version */ + unsigned char minor; /* minor version */ + unsigned char flags; /* bit 0: 0 == big endian, 1 == little endian + bit 1: 1 == more fragments follow */ + unsigned char message_type; /* message type ... */ + unsigned char message_size[4]; /* size in (flags bit 0 byte order) */ +}; + +#define TPKT_VRSN 3 + +struct tpkt_head { + unsigned char vrsn; /* contains TPKT_VRSN */ + unsigned char reserved; + unsigned char packet_length[2]; /* size incl header, big-endian (?) */ +}; + +void packet_parser_init() +{ + static int done = 0; + if (!done) { + done = 1; + http_init(); + } +} + +/* Return > 0 Total packet length.in bytes + * = 0 Length unknown, need more data. + * < 0 Error, invalid format. + */ +int packet_get_length(enum PacketParseType htype, + const char* ptr, unsigned n, /* Bytes read so far */ + unsigned max_plen, /* Max packet length, 0=no limit */ + unsigned trunc_len, /* Truncate (lines) if longer, 0=no limit */ + int* statep) /* Protocol specific state */ +{ + unsigned hlen, plen; + + switch (htype) { + case TCP_PB_RAW: + if (n == 0) goto more; + else { + DEBUGF((" => nothing remain packet=%d\r\n", n)); + return n; + } + + case TCP_PB_1: + /* TCP_PB_1: [L0 | Data] */ + hlen = 1; + if (n < hlen) goto more; + plen = get_int8(ptr); + goto remain; + + case TCP_PB_2: + /* TCP_PB_2: [L1,L0 | Data] */ + hlen = 2; + if (n < hlen) goto more; + plen = get_int16(ptr); + goto remain; + + case TCP_PB_4: + /* TCP_PB_4: [L3,L2,L1,L0 | Data] */ + hlen = 4; + if (n < hlen) goto more; + plen = get_int32(ptr); + goto remain; + + case TCP_PB_RM: + /* TCP_PB_RM: [L3,L2,L1,L0 | Data] + ** where MSB (bit) is used to signal end of record + */ + hlen = 4; + if (n < hlen) goto more; + plen = get_int32(ptr) & 0x7fffffff; + goto remain; + + case TCP_PB_LINE_LF: { + /* TCP_PB_LINE_LF: [Data ... \n] */ + const char* ptr2; + if ((ptr2 = memchr(ptr, '\n', n)) == NULL) { + if (n >= trunc_len && trunc_len!=0) { /* buffer full */ + DEBUGF((" => line buffer full (no NL)=%d\r\n", n)); + return trunc_len; + } + goto more; + } + else { + int len = (ptr2 - ptr) + 1; /* including newline */ + if (len > trunc_len && trunc_len!=0) { + DEBUGF((" => truncated line=%d\r\n", trunc_len)); + return trunc_len; + } + DEBUGF((" => nothing remain packet=%d\r\n", len)); + return len; + } + } + + case TCP_PB_ASN1: { + /* TCP_PB_ASN1: handles long (4 bytes) or short length format */ + const char* tptr = ptr; + int length; + int nn = n; + + if (n < 2) goto more; + nn--; + if ((*tptr++ & 0x1f) == 0x1f) { /* Long tag format */ + while (nn && ((*tptr & 0x80) == 0x80)) { + tptr++; + nn--; + } + if (nn < 2) goto more; + tptr++; + nn--; + } + + /* tptr now point to length field and nn characters remain */ + length = *tptr & 0x7f; + if ((*tptr & 0x80) == 0x80) { /* Long length format */ + tptr++; + nn--; + if (nn < length) goto more; + switch (length) { + case 0: plen = 0; break; + case 1: plen = get_int8(tptr); tptr += 1; break; + case 2: plen = get_int16(tptr); tptr += 2; break; + case 3: plen = get_int24(tptr); tptr += 3; break; + case 4: plen = get_int32(tptr); tptr += 4; break; + default: goto error; /* error */ + } + } + else { + tptr++; + plen = length; + } + hlen = (tptr-ptr); + goto remain; + } + + case TCP_PB_CDR: { + const struct cdr_head* hp; + hlen = sizeof(struct cdr_head); + if (n < hlen) goto more; + hp = (struct cdr_head*) ptr; + if (sys_memcmp(hp->magic, CDR_MAGIC, 4) != 0) + goto error; + if (hp->flags & 0x01) /* Byte ordering flag */ + plen = get_little_int32(hp->message_size); + else + plen = get_int32(hp->message_size); + goto remain; + } + + case TCP_PB_FCGI: { + const struct fcgi_head* hp; + hlen = sizeof(struct fcgi_head); + if (n < hlen) goto more; + hp = (struct fcgi_head*) ptr; + if (hp->version != FCGI_VERSION_1) + goto error; + plen = ((hp->contentLengthB1 << 8) | hp->contentLengthB0) + + hp->paddingLength; + goto remain; + } + case TCP_PB_HTTPH: + case TCP_PB_HTTPH_BIN: + *statep = !0; + case TCP_PB_HTTP: + case TCP_PB_HTTP_BIN: + /* TCP_PB_HTTP: data \r\n(SP data\r\n)* */ + plen = n; + if (((plen == 1) && NL(ptr)) || ((plen == 2) && CRNL(ptr))) + goto done; + else { + const char* ptr1 = ptr; + int len = plen; + + while (1) { + const char* ptr2 = memchr(ptr1, '\n', len); + + if (ptr2 == NULL) { + if (n >= trunc_len && trunc_len!=0) { /* buffer full */ + plen = trunc_len; + goto done; + } + goto more; + } + else { + plen = (ptr2 - ptr) + 1; + + if (*statep == 0) + goto done; + + if (plen < n) { + if (SP(ptr2+1) && plen>2) { + /* header field value continue on next line */ + ptr1 = ptr2+1; + len = n - plen; + } + else + goto done; + } + else + goto more; + } + } + } + case TCP_PB_TPKT: { + const struct tpkt_head* hp; + hlen = sizeof(struct tpkt_head); + if (n < hlen) + goto more; + hp = (struct tpkt_head*) ptr; + if (hp->vrsn == TPKT_VRSN) { + plen = get_int16(hp->packet_length) - hlen; + if (plen < 0) + goto error; + } + else + goto error; + goto remain; + } + + case TCP_PB_SSL_TLS: + hlen = 5; + if (n < hlen) goto more; + if ((ptr[0] & 0x80) && ptr[2] == 1) { + /* Ssl-v2 Client hello <<1:1, Len:15, 1:8, Version:16>> */ + plen = (get_int16(&ptr[0]) & 0x7fff) - 3; + } + else { + /* <> */ + plen = get_int16(&ptr[3]); + } + goto remain; + + default: + DEBUGF((" => case error\r\n")); + return -1; + } + +more: + return 0; + +remain: + { + int tlen = hlen + plen; + if ((max_plen != 0 && plen > max_plen) + || tlen < (int)hlen) { /* wrap-around protection */ + return -1; + } + return tlen; + } + +done: + return plen; + +error: + return -1; +} + + +static http_atom_t* http_hash_lookup(const char* name, int len, + unsigned long h, + http_atom_t** hash, int hsize) +{ + int ix = h % hsize; + http_atom_t* ap = hash[ix]; + + while (ap != NULL) { + if ((ap->h == h) && (ap->len == len) && + (strncmp(ap->name, name, len) == 0)) + return ap; + ap = ap->next; + } + return NULL; +} + +static void +http_parse_absoluteURI(PacketHttpURI* uri, const char* uri_ptr, int uri_len) +{ + const char* p; + + if ((p = memchr(uri_ptr, '/', uri_len)) == NULL) { + /* host [":" port] */ + uri->s2_ptr = "/"; + uri->s2_len = 1; + } + else { + int n = (p - uri_ptr); + uri->s2_ptr = p; + uri->s2_len = uri_len - n; + uri_len = n; + } + + uri->s1_ptr = uri_ptr; + uri->port = 0; /* undefined */ + /* host[:port] */ + if ((p = memchr(uri_ptr, ':', uri_len)) == NULL) { + uri->s1_len = uri_len; + } + else { + int n = (p - uri_ptr); + int port = 0; + uri->s1_len = n; + n = uri_len - (n+1); + p++; + while(n && isdigit((int) *p)) { + port = port*10 + (*p - '0'); + n--; + p++; + } + if (n==0 && port!=0) + uri->port = port; + } +} + +/* +** Handle URI syntax: +** +** Request-URI = "*" | absoluteURI | abs_path +** absoluteURI = scheme ":" *( uchar | reserved ) +** net_path = "//" net_loc [ abs_path ] +** abs_path = "/" rel_path +** rel_path = [ path ] [ ";" params ] [ "?" query ] +** path = fsegment *( "/" segment ) +** fsegment = 1*pchar +** segment = *pchar +** params = param *( ";" param ) +** param = *( pchar | "/" ) +** query = *( uchar | reserved ) +** +** http_URL = "http:" "//" host [ ":" port ] [ abs_path ] +** +** host = +** port = *DIGIT +** +** {absoluteURI, , , , } +** when = http | https +** {scheme, , } +** wheb is something else then http or https +** {abs_path, } +** +** (unknown form) +** +*/ +static void http_parse_uri(PacketHttpURI* uri, const char* uri_ptr, int uri_len) +{ + if ((uri_len == 1) && (uri_ptr[0] == '*')) + uri->type = URI_STAR; + else if ((uri_len <= 1) || (uri_ptr[0] == '/')) { + uri->type = URI_ABS_PATH; + uri->s1_ptr = uri_ptr; + uri->s1_len = uri_len; + } + else if ((uri_len>=7) && (STRNCASECMP(uri_ptr, "http://", 7) == 0)) { + uri_len -= 7; + uri_ptr += 7; + uri->type = URI_HTTP; + http_parse_absoluteURI(uri, uri_ptr, uri_len); + } + else if ((uri_len>=8) && (STRNCASECMP(uri_ptr, "https://", 8) == 0)) { + uri_len -= 8; + uri_ptr += 8; + uri->type = URI_HTTPS; + http_parse_absoluteURI(uri, uri_ptr, uri_len); + } + else { + char* ptr; + if ((ptr = memchr(uri_ptr, ':', uri_len)) == NULL) { + uri->type = URI_STRING; + uri->s1_ptr = uri_ptr; + uri->s1_len = uri_len; + } + else { + int slen = ptr - uri_ptr; + uri->type = URI_SCHEME; + uri->s1_ptr = uri_ptr; + uri->s1_len = slen; + uri->s2_ptr = uri_ptr + (slen+1); + uri->s2_len = uri_len - (slen+1); + } + } +} + +/* +** parse http message: +** http_eoh - end of headers +** {http_header, Key, Value} - Key = atom() | string() +** {http_request, Method,Url,Version} +** {http_response, Version, Status, Message} +** {http_error, Error-Line} +*/ +int packet_parse_http(const char* buf, int len, int* statep, + PacketCallbacks* pcb, void* arg) +{ + const char* ptr = buf; + const char* p0; + int n = len; + + /* remove trailing CRNL (accept NL as well) */ + if ((n >= 2) && (buf[n-2] == '\r')) + n -= 2; + else if ((n >= 1) && (buf[n-1] == '\n')) + n -= 1; + + if (*statep == 0) { + /* start-line = Request-Line | Status-Line */ + + if (n >= 5 && (strncmp(buf, "HTTP/", 5) == 0)) { + int major = 0; + int minor = 0; + int status = 0; + /* Status-Line = HTTP-Version SP + * Status-Code SP Reason-Phrase + * CRNL + * HTTP-Version = "HTTP" "/" 1*DIGIT "." 1*DIGIT + */ + ptr += 5; + n -= 5; + p0 = ptr; + while (n && isdigit((int) *ptr)) { + major = 10*major + (*ptr - '0'); + ptr++; + n--; + } + if (ptr==p0 || !n || (*ptr != '.')) + return -1; + ptr++; + n--; + p0 = ptr; + while (n && isdigit((int) *ptr)) { + minor = 10*minor + (*ptr - '0'); + ptr++; + n--; + } + if (ptr==p0) return -1; + p0 = ptr; + while (n && SP(ptr)) { + ptr++; n--; + } + if (ptr==p0) return -1; + + while (n && isdigit((int) *ptr)) { + status = 10*status + (*ptr - '0'); + ptr++; + n--; + } + p0 = ptr; + while (n && SP(ptr)) { + ptr++; n--; + } + if (ptr==p0) return -1; + + /* NOTE: the syntax allows empty reason phrases */ + (*statep) = !0; + + return pcb->http_response(arg, major, minor, status, + ptr, n); + } + else { + /* Request-Line = Method SP Request-URI SP HTTP-Version CRLF */ + http_atom_t* meth; + const char* meth_ptr = buf; + int meth_len; + PacketHttpURI uri; + const char* uri_ptr; + int uri_len; + int major = 0; + int minor = 0; + unsigned long h = 0; + + while (n && !is_tspecial((unsigned char)*ptr)) { + hash_update(h, (int)*ptr); + ptr++; + n--; + } + meth_len = ptr - meth_ptr; + if (n == 0 || meth_len == 0 || !SP(ptr)) return -1; + + meth = http_hash_lookup(meth_ptr, meth_len, h, + http_meth_hash, HTTP_METH_HASH_SIZE); + + while (n && SP(ptr)) { + ptr++; n--; + } + uri_ptr = ptr; + while (n && !SP(ptr)) { + ptr++; n--; + } + if ((uri_len = (ptr - uri_ptr)) == 0) + return -1; + while (n && SP(ptr)) { + ptr++; n--; + } + if (n == 0) { + (*statep) = !0; + http_parse_uri(&uri, uri_ptr, uri_len); + return pcb->http_request(arg, meth, meth_ptr, meth_len, + &uri, 0, 9); + } + if (n < 8) + return -1; + if (strncmp(ptr, "HTTP/", 5) != 0) + return -1; + ptr += 5; + n -= 5; + + p0 = ptr; + while (n && isdigit((int) *ptr)) { + major = 10*major + (*ptr - '0'); + ptr++; + n--; + } + if (ptr==p0 || !n || (*ptr != '.')) + return -1; + ptr++; + n--; + p0 = ptr; + while (n && isdigit((int) *ptr)) { + minor = 10*minor + (*ptr - '0'); + ptr++; + n--; + } + if (ptr==p0) return -1; + + (*statep) = !0; + http_parse_uri(&uri, uri_ptr, uri_len); + return pcb->http_request(arg, meth, meth_ptr, meth_len, + &uri, major, minor); + } + } + else { + int up = 1; /* make next char uppercase */ + http_atom_t* name; + char name_buf[HTTP_MAX_NAME_LEN]; + const char* name_ptr = name_buf; + int name_len; + unsigned long h; + + if (n == 0) { + /* end of headers */ + *statep = 0; /* reset state (for next request) */ + return pcb->http_eoh(arg); + } + h = 0; + name_len = 0; + while (!is_tspecial((unsigned char)*ptr)) { + if (name_len < HTTP_MAX_NAME_LEN) { + int c = *ptr; + if (up) { + if (islower(c)) { + c = toupper(c); + } + up = 0; + } + else { + if (isupper(c)) + c = tolower(c); + else if (c == '-') + up = 1; + } + name_buf[name_len] = c; + hash_update(h, c); + } + name_len++; + ptr++; + if (--n == 0) return -1; + } + while (n && SP(ptr)) { /* Skip white space before ':' */ + ptr++; n--; + } + if (*ptr != ':') { + return -1; + } + if (name_len <= HTTP_MAX_NAME_LEN) { + name = http_hash_lookup(name_buf, name_len, h, + http_hdr_hash, HTTP_HDR_HASH_SIZE); + } + else { + /* Is it ok to return original name without case adjustments? */ + name_ptr = buf; + name = NULL; + } + ptr++; + n--; + /* Skip white space after ':' */ + while (n && SP(ptr)) { + ptr++; n--; + } + return pcb->http_header(arg, name, name_ptr, name_len, + ptr, n); + } + return -1; +} + +int packet_parse_ssl(const char* buf, int len, + PacketCallbacks* pcb, void* arg) +{ + /* Check for ssl-v2 client hello */ + if ((buf[0] & 0x80) && buf[2] == 1) { + unsigned major = (unsigned char) buf[3]; + unsigned minor = (unsigned char) buf[4]; + char prefix[4]; + /* <<1:8,Length:24,Data/binary>> */ + prefix[0] = 1; + put_int24(&prefix[1],len-3); + return pcb->ssl_tls(arg, 22, major, minor, buf+3, len-3, prefix, sizeof(prefix)); + } + else { + /* ContentType (1 byte), ProtocolVersion (2 bytes), Length (2 bytes big-endian) */ + unsigned type = (unsigned char) buf[0]; + unsigned major = (unsigned char) buf[1]; + unsigned minor = (unsigned char) buf[2]; + return pcb->ssl_tls(arg, type, major, minor, buf+5, len-5, NULL, 0); + } +} + diff --git a/erts/emulator/beam/packet_parser.h b/erts/emulator/beam/packet_parser.h new file mode 100644 index 0000000000..1c3a9aa3da --- /dev/null +++ b/erts/emulator/beam/packet_parser.h @@ -0,0 +1,181 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2008-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* A protocol decoder. Simple packet length extraction as well as packet + * body parsing with protocol specific callback interfaces (http and ssl). + */ +#ifndef __PACKET_PARSER_H__ +#define __PACKET_PARSER_H__ + +#include +#include "sys.h" + + +/* INET_LOPT_PACKET options */ +enum PacketParseType { + TCP_PB_RAW = 0, + TCP_PB_1 = 1, + TCP_PB_2 = 2, + TCP_PB_4 = 3, + TCP_PB_ASN1 = 4, + TCP_PB_RM = 5, + TCP_PB_CDR = 6, + TCP_PB_FCGI = 7, + TCP_PB_LINE_LF = 8, + TCP_PB_TPKT = 9, + TCP_PB_HTTP = 10, + TCP_PB_HTTPH = 11, + TCP_PB_SSL_TLS = 12, + TCP_PB_HTTP_BIN = 13, + TCP_PB_HTTPH_BIN = 14 +}; + +typedef struct http_atom { + struct http_atom* next; /* next in bucket */ + unsigned long h; /* stored hash value */ + const char* name; + int len; + int index; /* index in table + bit-pos */ + ErlDrvTermData atom; /* erlang atom rep */ +} http_atom_t; + +typedef struct { + enum { + URI_STAR, /* '*' */ + URI_STRING, /* "string(s1)" */ + URI_ABS_PATH,/* {abs_path, "path(s1)"} */ + URI_SCHEME, /* {scheme, "scheme(s1)", "string(s2)"} */ + URI_HTTP, /* {absoluteURI, http, "host(s1)", Port, "path(s2)"} */ + URI_HTTPS /* {absoluteURI, https, ... */ + } type; + const char* s1_ptr; + int s1_len; + const char* s2_ptr; + int s2_len; + int port; /* 0=undefined */ +}PacketHttpURI; + +typedef int HttpResponseMessageFn(void* arg, int major, int minor, int status, + const char* phrase, int phrase_len); +typedef int HttpRequestMessageFn(void* arg, const http_atom_t* meth, const char* meth_ptr, + int meth_len, const PacketHttpURI*, int major, int minor); +typedef int HttpEohMessageFn(void *arg); +typedef int HttpHeaderMessageFn(void* arg, const http_atom_t* name, const char* name_ptr, + int name_len, const char* value_ptr, int value_len); +typedef int HttpErrorMessageFn(void* arg, const char* buf, int len); +typedef int SslTlsFn(void* arg, unsigned type, unsigned major, unsigned minor, + const char* data, int len, const char* prefix, int plen); + +typedef struct { + HttpResponseMessageFn* http_response; + HttpRequestMessageFn* http_request; + HttpEohMessageFn* http_eoh; + HttpHeaderMessageFn* http_header; + HttpErrorMessageFn* http_error; + SslTlsFn* ssl_tls; +}PacketCallbacks; + + +/* Called once at emulator start + */ +void packet_parser_init(void); + +/* Returns > 0 Total packet length. + * = 0 Length unknown, need more data. + * < 0 Error, invalid format. + */ +int packet_get_length(enum PacketParseType htype, + const char* ptr, unsigned n, /* Bytes read so far */ + unsigned max_plen, /* Packet max length, 0=no limit */ + unsigned trunc_len, /* Truncate (lines) if longer, 0=no limit */ + int* statep); /* Internal protocol state */ + +ERTS_GLB_INLINE +void packet_get_body(enum PacketParseType htype, + const char** bufp, /* In: Packet header, Out: Packet body */ + int* lenp); /* In: Packet length, Out: Body length */ + +/* Returns 1 = Packet parsed and handled by callbacks. +** 0 = No parsing support for this packet type +** -1 = Error +*/ +ERTS_GLB_INLINE +int packet_parse(enum PacketParseType htype, + const char* buf, int len, /* Total packet */ + int* statep, PacketCallbacks* pcb, void* arg); + + + +/* Internals for the inlines below: */ + +#define FCGI_VERSION_1 1 +struct fcgi_head { + unsigned char version; + unsigned char type; + unsigned char requestIdB1; + unsigned char requestIdB0; + unsigned char contentLengthB1; + unsigned char contentLengthB0; + unsigned char paddingLength; + unsigned char reserved; + /* char data[] */ + /* char padding[paddingLength] */ +}; +int packet_parse_http(const char*, int, int*, PacketCallbacks*, void*); +int packet_parse_ssl(const char*, int, PacketCallbacks*, void*); + + +#if ERTS_GLB_INLINE_INCL_FUNC_DEF +ERTS_GLB_INLINE +void packet_get_body(enum PacketParseType htype, const char** bufp, int* lenp) +{ + switch (htype) { + case TCP_PB_1: *bufp += 1; *lenp -= 1; break; + case TCP_PB_2: *bufp += 2; *lenp -= 2; break; + case TCP_PB_4: *bufp += 4; *lenp -= 4; break; + case TCP_PB_FCGI: + *lenp -= ((struct fcgi_head*)*bufp)->paddingLength; + break; + default: + ;/* Return other packets "as is" */ + } +} + +ERTS_GLB_INLINE +int packet_parse(enum PacketParseType htype, const char* buf, int len, + int* statep, PacketCallbacks* pcb, void* arg) +{ + switch (htype) { + case TCP_PB_HTTP: + case TCP_PB_HTTPH: + case TCP_PB_HTTP_BIN: + case TCP_PB_HTTPH_BIN: + if (packet_parse_http(buf, len, statep, pcb, arg) < 0) + pcb->http_error(arg, buf, len); + return 1; + case TCP_PB_SSL_TLS: + return packet_parse_ssl(buf, len, pcb, arg); + default:; + } + return 0; +} +#endif /* ERTS_GLB_INLINE_INCL_FUNC_DEF */ + +#endif /* !__PACKET_PARSER_H__ */ + diff --git a/erts/emulator/beam/register.c b/erts/emulator/beam/register.c new file mode 100644 index 0000000000..7ba097382a --- /dev/null +++ b/erts/emulator/beam/register.c @@ -0,0 +1,655 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* + * Manage registered processes. + */ +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "hash.h" +#include "atom.h" +#include "register.h" + +static Hash process_reg; + +#define PREG_HASH_SIZE 10 + +#define REG_HASH(term) ((HashValue) atom_val(term)) + +static erts_smp_rwmtx_t regtab_rwmtx; + +#define reg_lock_init() erts_smp_rwmtx_init(®tab_rwmtx, \ + "reg_tab") +#define reg_try_read_lock() erts_smp_rwmtx_tryrlock(®tab_rwmtx) +#define reg_try_write_lock() erts_smp_rwmtx_tryrwlock(®tab_rwmtx) +#define reg_read_lock() erts_smp_rwmtx_rlock(®tab_rwmtx) +#define reg_write_lock() erts_smp_rwmtx_rwlock(®tab_rwmtx) +#define reg_read_unlock() erts_smp_rwmtx_runlock(®tab_rwmtx) +#define reg_write_unlock() erts_smp_rwmtx_rwunlock(®tab_rwmtx) + +#ifdef ERTS_SMP +static ERTS_INLINE void +reg_safe_read_lock(Process *c_p, ErtsProcLocks *c_p_locks) +{ + if (*c_p_locks) { + ASSERT(c_p); + ASSERT(c_p_locks); + ASSERT(*c_p_locks); + + if (reg_try_read_lock() != EBUSY) { +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_proc_lc_might_unlock(c_p, *c_p_locks); +#endif + return; + } + + /* Release process locks in order to avoid deadlock */ + erts_smp_proc_unlock(c_p, *c_p_locks); + *c_p_locks = 0; + } + + reg_read_lock(); +} + +static ERTS_INLINE void +reg_safe_write_lock(Process *c_p, ErtsProcLocks *c_p_locks) +{ + if (*c_p_locks) { + ASSERT(c_p); + ASSERT(c_p_locks); + ASSERT(*c_p_locks); + + if (reg_try_write_lock() != EBUSY) { +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_proc_lc_might_unlock(c_p, *c_p_locks); +#endif + return; + } + + /* Release process locks in order to avoid deadlock */ + erts_smp_proc_unlock(c_p, *c_p_locks); + *c_p_locks = 0; + } + + reg_write_lock(); +} + +static ERTS_INLINE int +is_proc_alive(Process *p) +{ + int res; + erts_pix_lock_t *pixlck = ERTS_PID2PIXLOCK(p->id); + erts_pix_lock(pixlck); + res = !p->is_exiting; + erts_pix_unlock(pixlck); + return res; +} + +#endif + +void register_info(int to, void *to_arg) +{ + int lock = !ERTS_IS_CRASH_DUMPING; + if (lock) + reg_read_lock(); + hash_info(to, to_arg, &process_reg); + if (lock) + reg_read_unlock(); +} + +static HashValue reg_hash(RegProc* obj) +{ + return REG_HASH(obj->name); +} + +static int reg_cmp(RegProc *tmpl, RegProc *obj) { + return tmpl->name != obj->name; +} + +static RegProc* reg_alloc(RegProc *tmpl) +{ + RegProc* obj = (RegProc*) erts_alloc(ERTS_ALC_T_REG_PROC, sizeof(RegProc)); + if (!obj) { + erl_exit(1, "Can't allocate %d bytes of memory\n", sizeof(RegProc)); + } + obj->name = tmpl->name; + obj->p = tmpl->p; + obj->pt = tmpl->pt; + return obj; +} + +static void reg_free(RegProc *obj) +{ + erts_free(ERTS_ALC_T_REG_PROC, (void*) obj); +} + +void init_register_table(void) +{ + HashFunctions f; + + reg_lock_init(); + + f.hash = (H_FUN) reg_hash; + f.cmp = (HCMP_FUN) reg_cmp; + f.alloc = (HALLOC_FUN) reg_alloc; + f.free = (HFREE_FUN) reg_free; + + hash_init(ERTS_ALC_T_REG_TABLE, &process_reg, "process_reg", + PREG_HASH_SIZE, f); +} + +/* + * Register a process or port (can't be registered twice). + * Returns 0 if name, process or port is already registered. + * + * When smp support is enabled: + * * Assumes that main lock is locked (and only main lock) + * on c_p. + * + */ +int erts_register_name(Process *c_p, Eterm name, Eterm id) +{ + int res = 0; + Process *proc = NULL; + Port *port = NULL; + RegProc r, *rp; + ERTS_SMP_CHK_HAVE_ONLY_MAIN_PROC_LOCK(c_p); + + if (is_not_atom(name) || name == am_undefined) + return res; + + if (c_p->id == id) /* A very common case I think... */ + proc = c_p; + else { + if (is_not_internal_pid(id) && is_not_internal_port(id)) + return res; + erts_smp_proc_unlock(c_p, ERTS_PROC_LOCK_MAIN); + if (is_internal_port(id)) { + port = erts_id2port(id, NULL, 0); + if (!port) + goto done; + } + } + +#ifdef ERTS_SMP + { + ErtsProcLocks proc_locks = proc ? ERTS_PROC_LOCK_MAIN : 0; + reg_safe_write_lock(proc, &proc_locks); + + if (proc && !proc_locks) + erts_smp_proc_lock(c_p, ERTS_PROC_LOCK_MAIN); + } +#endif + + if (is_internal_pid(id)) { + if (!proc) + proc = erts_pid2proc(NULL, 0, id, ERTS_PROC_LOCK_MAIN); + r.p = proc; + if (!proc) + goto done; + if (proc->reg) + goto done; + r.pt = NULL; + } + else { + ASSERT(!INVALID_PORT(port, id)); + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(port)); + r.pt = port; + if (r.pt->reg) + goto done; + r.p = NULL; + } + + r.name = name; + + rp = (RegProc*) hash_put(&process_reg, (void*) &r); + if (proc && rp->p == proc) { + if (IS_TRACED_FL(proc, F_TRACE_PROCS)) { + trace_proc(c_p, proc, am_register, name); + } + proc->reg = rp; + } + else if (port && rp->pt == port) { + if (IS_TRACED_FL(port, F_TRACE_PORTS)) { + trace_port(port, am_register, name); + } + port->reg = rp; + } + + if ((rp->p && rp->p->id == id) || (rp->pt && rp->pt->id == id)) { + res = 1; + } + + done: + reg_write_unlock(); + if (port) + erts_smp_port_unlock(port); + if (c_p != proc) { + if (proc) + erts_smp_proc_unlock(proc, ERTS_PROC_LOCK_MAIN); + erts_smp_proc_lock(c_p, ERTS_PROC_LOCK_MAIN); + } + return res; +} + +/* + * + * When smp support is enabled: + * * Assumes that main lock is locked (and only main lock) + * on c_p. + * + * * am_undefined is returned if c_p became exiting. + */ + +Eterm +erts_whereis_name_to_id(Process *c_p, Eterm name) +{ + Eterm res = am_undefined; + HashValue hval; + int ix; + HashBucket* b; +#ifdef ERTS_SMP + ErtsProcLocks c_p_locks = c_p ? ERTS_PROC_LOCK_MAIN : 0; + + ERTS_SMP_CHK_HAVE_ONLY_MAIN_PROC_LOCK(c_p); + reg_safe_read_lock(c_p, &c_p_locks); + if (c_p && !c_p_locks) + erts_smp_proc_lock(c_p, ERTS_PROC_LOCK_MAIN); +#endif + + hval = REG_HASH(name); + ix = hval % process_reg.size; + b = process_reg.bucket[ix]; + + /* + * Note: We have inlined the code from hash.c for speed. + */ + + while (b) { + RegProc* rp = (RegProc *) b; + if (rp->name == name) { + /* + * SMP NOTE: No need to lock registered entity since it cannot + * be removed without acquiring write reg lock and id on entity + * is read only. + */ + if (rp->p) + res = rp->p->id; + else if (rp->pt) + res = rp->pt->id; + break; + } + b = b->next; + } + + reg_read_unlock(); + + ASSERT(is_internal_pid(res) || is_internal_port(res) || res==am_undefined); + + return res; +} + + +void +erts_whereis_name(Process *c_p, + ErtsProcLocks c_p_locks, + Eterm name, + Process** proc, + ErtsProcLocks need_locks, + int flags, + Port** port) +{ + RegProc* rp = NULL; + HashValue hval; + int ix; + HashBucket* b; +#ifdef ERTS_SMP + ErtsProcLocks current_c_p_locks; + Port *pending_port = NULL; + + if (!c_p) + c_p_locks = 0; + current_c_p_locks = c_p_locks; + + restart: + + reg_safe_read_lock(c_p, ¤t_c_p_locks); + + /* Locked locks: + * - port lock on pending_port if pending_port != NULL + * - read reg lock + * - current_c_p_locks (either c_p_locks or 0) on c_p + */ +#endif + + hval = REG_HASH(name); + ix = hval % process_reg.size; + b = process_reg.bucket[ix]; + + /* + * Note: We have inlined the code from hash.c for speed. + */ + + while (b) { + if (((RegProc *) b)->name == name) { + rp = (RegProc *) b; + break; + } + b = b->next; + } + + if (proc) { + if (!rp) + *proc = NULL; + else { +#ifdef ERTS_SMP + if (!rp->p) + *proc = NULL; + else { + if (need_locks) { + erts_proc_safelock(c_p, + current_c_p_locks, + c_p_locks, + rp->p, + 0, + need_locks); + current_c_p_locks = c_p_locks; + } + if ((flags & ERTS_P2P_FLG_ALLOW_OTHER_X) || is_proc_alive(rp->p)) + *proc = rp->p; + else { + if (need_locks) + erts_smp_proc_unlock(rp->p, need_locks); + *proc = NULL; + } + if (*proc && (flags & ERTS_P2P_FLG_SMP_INC_REFC)) + erts_smp_proc_inc_refc(rp->p); + } +#else + if (rp->p + && ((flags & ERTS_P2P_FLG_ALLOW_OTHER_X) + || rp->p->status != P_EXITING)) + *proc = rp->p; + else + *proc = NULL; +#endif + } + } + + if (port) { + if (!rp || !rp->pt) + *port = NULL; + else { +#ifdef ERTS_SMP + if (pending_port == rp->pt) + pending_port = NULL; + else { + if (pending_port) { + /* Ahh! Registered port changed while reg lock + was unlocked... */ + erts_smp_port_unlock(pending_port); + pending_port = NULL; + } + + if (erts_smp_port_trylock(rp->pt) == EBUSY) { + Eterm id = rp->pt->id; /* id read only... */ + /* Unlock all locks, acquire port lock, and restart... */ + if (current_c_p_locks) { + erts_smp_proc_unlock(c_p, current_c_p_locks); + current_c_p_locks = 0; + } + reg_read_unlock(); + pending_port = erts_id2port(id, NULL, 0); + goto restart; + } + } +#endif + *port = rp->pt; + ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(*port)); + } + } + +#ifdef ERTS_SMP + if (c_p && !current_c_p_locks) + erts_smp_proc_lock(c_p, c_p_locks); + if (pending_port) + erts_smp_port_unlock(pending_port); +#endif + + reg_read_unlock(); +} + +Process * +erts_whereis_process(Process *c_p, + ErtsProcLocks c_p_locks, + Eterm name, + ErtsProcLocks need_locks, + int flags) +{ + Process *proc; + erts_whereis_name(c_p, c_p_locks, name, &proc, need_locks, flags, NULL); + return proc; +} + + +/* + * Unregister a name + * Return 0 if not registered + * Otherwise returns 1 + * + */ +int erts_unregister_name(Process *c_p, + ErtsProcLocks c_p_locks, + Port *c_prt, + Eterm name) +{ + int res = 0; + RegProc r, *rp; + Port *port = c_prt; +#ifdef ERTS_SMP + ErtsProcLocks current_c_p_locks; + + /* + * SMP note: If 'c_prt != NULL' and 'c_prt->reg->name == name', + * we are *not* allowed to temporarily release the lock + * on c_prt. + */ + + if (!c_p) + c_p_locks = 0; + current_c_p_locks = c_p_locks; + + restart: + + reg_safe_write_lock(c_p, ¤t_c_p_locks); +#endif + + r.name = name; + if (is_non_value(name)) { + /* Unregister current process name */ + ASSERT(c_p); + if (c_p->reg) + r.name = c_p->reg->name; + else { + /* Name got unregistered while main lock was released */ + res = 0; + goto done; + } + } + + if ((rp = (RegProc*) hash_get(&process_reg, (void*) &r)) != NULL) { + if (rp->pt) { +#ifdef ERTS_SMP + if (port != rp->pt) { + if (port) { + ERTS_SMP_LC_ASSERT(port != c_prt); + erts_smp_port_unlock(port); + port = NULL; + } + + if (erts_smp_port_trylock(rp->pt) == EBUSY) { + Eterm id = rp->pt->id; /* id read only... */ + /* Unlock all locks, acquire port lock, and restart... */ + if (current_c_p_locks) { + erts_smp_proc_unlock(c_p, current_c_p_locks); + current_c_p_locks = 0; + } + reg_write_unlock(); + port = erts_id2port(id, NULL, 0); + goto restart; + } + port = rp->pt; + } +#endif + ERTS_SMP_LC_ASSERT(rp->pt == port && erts_lc_is_port_locked(port)); + rp->pt->reg = NULL; + + if (IS_TRACED_FL(port, F_TRACE_PORTS)) { + trace_port(port, am_unregister, r.name); + } + + } else if (rp->p) { + Process* p = rp->p; +#ifdef ERTS_SMP + erts_proc_safelock(c_p, + current_c_p_locks, + c_p_locks, + rp->p, + 0, + ERTS_PROC_LOCK_MAIN); + current_c_p_locks = c_p_locks; +#endif + p->reg = NULL; +#ifdef ERTS_SMP + if (rp->p != c_p) + erts_smp_proc_unlock(rp->p, ERTS_PROC_LOCK_MAIN); +#endif + if (IS_TRACED_FL(p, F_TRACE_PROCS)) { + trace_proc(c_p, p, am_unregister, r.name); + } + } + hash_erase(&process_reg, (void*) &r); + res = 1; + } + + done: + + reg_write_unlock(); + if (c_prt != port) { + if (port) + erts_smp_port_unlock(port); + if (c_prt) + erts_smp_port_lock(c_prt); + } +#ifdef ERTS_SMP + if (c_p && !current_c_p_locks) + erts_smp_proc_lock(c_p, c_p_locks); +#endif + return res; +} + +int process_reg_size(void) +{ + int size; + int lock = !ERTS_IS_CRASH_DUMPING; + if (lock) + reg_read_lock(); + size = process_reg.size; + if (lock) + reg_read_unlock(); + return size; +} + +int process_reg_sz(void) +{ + int sz; + int lock = !ERTS_IS_CRASH_DUMPING; + if (lock) + reg_read_lock(); + sz = hash_table_sz(&process_reg); + if (lock) + reg_read_unlock(); + return sz; +} + +/**********************************************************************/ + +#include "bif.h" + +/* return a list of the registered processes */ + +BIF_RETTYPE registered_0(BIF_ALIST_0) +{ + int i; + Eterm res; + Uint need; + Eterm* hp; + HashBucket **bucket; +#ifdef ERTS_SMP + ErtsProcLocks proc_locks = ERTS_PROC_LOCK_MAIN; + + ERTS_SMP_CHK_HAVE_ONLY_MAIN_PROC_LOCK(BIF_P); + reg_safe_read_lock(BIF_P, &proc_locks); + if (!proc_locks) + erts_smp_proc_lock(BIF_P, ERTS_PROC_LOCK_MAIN); +#endif + + bucket = process_reg.bucket; + + /* work out how much heap we need & maybe garb, by scanning through + the registered process table */ + need = 0; + for (i = 0; i < process_reg.size; i++) { + HashBucket *b = bucket[i]; + while (b != NULL) { + need += 2; + b = b->next; + } + } + + if (need == 0) { + reg_read_unlock(); + BIF_RET(NIL); + } + + hp = HAlloc(BIF_P, need); + + /* scan through again and make the list */ + res = NIL; + + for (i = 0; i < process_reg.size; i++) { + HashBucket *b = bucket[i]; + while (b != NULL) { + RegProc *reg = (RegProc *) b; + + res = CONS(hp, reg->name, res); + hp += 2; + b = b->next; + } + } + + reg_read_unlock(); + + BIF_RET(res); +} diff --git a/erts/emulator/beam/register.h b/erts/emulator/beam/register.h new file mode 100644 index 0000000000..97bab3ab71 --- /dev/null +++ b/erts/emulator/beam/register.h @@ -0,0 +1,66 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* +** Registered processes +*/ + +#ifndef __REGPROC_H__ +#define __REGPROC_H__ + +#ifndef __SYS_H__ +#include "sys.h" +#endif + +#ifndef __HASH_H__ +#include "hash.h" +#endif + +#ifndef __PROCESS_H__ +#include "erl_process.h" +#endif + +struct port; + +typedef struct reg_proc +{ + HashBucket bucket; /* MUST BE LOCATED AT TOP OF STRUCT!!! */ + Process *p; /* The process registerd (only one of this and + 'pt' is non-NULL */ + struct port *pt; /* The port registered */ + Eterm name; /* Atom name */ +} RegProc; + +int process_reg_size(void); +int process_reg_sz(void); +void init_register_table(void); +void register_info(int, void *); +int erts_register_name(Process *, Eterm, Eterm); +Eterm erts_whereis_name_to_id(Process *, Eterm); +void erts_whereis_name(Process *, ErtsProcLocks, + Eterm, Process**, ErtsProcLocks, int, + struct port**); +Process *erts_whereis_process(Process *, + ErtsProcLocks, + Eterm, + ErtsProcLocks, + int); +int erts_unregister_name(Process *, ErtsProcLocks, struct port *, Eterm); + +#endif diff --git a/erts/emulator/beam/safe_hash.c b/erts/emulator/beam/safe_hash.c new file mode 100644 index 0000000000..21d6ce9304 --- /dev/null +++ b/erts/emulator/beam/safe_hash.c @@ -0,0 +1,276 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2008-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* +** General thread safe hash table. Simular interface as hash.h +** +** Author: Sverker Eriksson +*/ +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "safe_hash.h" + +/* Currently only used by erl_check_io on Windows */ +#ifndef ERTS_SYS_CONTINOUS_FD_NUMBERS + + +static ERTS_INLINE void set_size(SafeHash* h, int size) +{ + ASSERT(size % SAFE_HASH_LOCK_CNT == 0); + /* This important property allows us to lock the right mutex + ** without reading the table size (that can change without the lock) */ + + h->size_mask = size - 1; + ASSERT((size & h->size_mask) == 0); + /* An even power of 2 is just for fast bit masking */ + + h->grow_limit = size; /* grow table at 100% load */ +} + +static ERTS_INLINE int align_up_pow2(int val) +{ + int x = val & (val-1); + if (x==0) return val ? val : 1; + do { + val = x; + x &= x - 1; + }while (x); + return val << 1; +} + +/* +** Rehash all objects +*/ +static void rehash(SafeHash* h, int grow_limit) +{ + if (erts_smp_atomic_xchg(&h->is_rehashing, 1) != 0) { + return; /* already in progress */ + } + if (h->grow_limit == grow_limit) { + int i, size, bytes; + SafeHashBucket** new_tab; + SafeHashBucket** old_tab = h->tab; + int old_size = h->size_mask + 1; + + size = old_size * 2; /* double table size */ + bytes = size * sizeof(SafeHashBucket*); + new_tab = (SafeHashBucket **) erts_alloc(h->type, bytes); + sys_memzero(new_tab, bytes); + + for (i=0; ilock_vec[i].mtx); + } + + h->tab = new_tab; + set_size(h, size); + + for (i = 0; i < old_size; i++) { + SafeHashBucket* b = old_tab[i]; + while (b != NULL) { + SafeHashBucket* b_next = b->next; + int ix = b->hvalue & h->size_mask; + b->next = new_tab[ix]; + new_tab[ix] = b; + b = b_next; + } + } + + for (i=0; ilock_vec[i].mtx); + } + erts_free(h->type, (void *) old_tab); + } + /*else already done */ + erts_smp_atomic_set(&h->is_rehashing, 0); +} + + +/* +** Get info about hash +*/ +void safe_hash_get_info(SafeHashInfo *hi, SafeHash *h) +{ + int size; + int i, lock_ix; + int max_depth = 0; + int objects = 0; + + for (lock_ix=0; lock_ixlock_vec[lock_ix].mtx); + size = h->size_mask + 1; + for (i = lock_ix; i < size; i += SAFE_HASH_LOCK_CNT) { + int depth = 0; + SafeHashBucket* b = h->tab[i]; + while (b != NULL) { + objects++; + depth++; + b = b->next; + } + if (depth > max_depth) + max_depth = depth; + } + erts_smp_mtx_unlock(&h->lock_vec[lock_ix].mtx); + } + + hi->name = h->name; + hi->size = size; + hi->objs = objects; + hi->depth = max_depth; +} + +/* +** Returns size of table in bytes. Stored objects not included. +**/ +int safe_hash_table_sz(SafeHash *h) +{ + int i, size; + for(i=0; h->name[i]; i++); + i++; + erts_smp_mtx_lock(&h->lock_vec[0].mtx); /* any lock will do to read size */ + size = h->size_mask + 1; + erts_smp_mtx_unlock(&h->lock_vec[0].mtx); + return sizeof(SafeHash) + size*sizeof(SafeHashBucket*) + i; +} + +/* +** Init a pre allocated or static hash structure +** and allocate buckets. NOT SAFE +*/ +SafeHash* safe_hash_init(ErtsAlcType_t type, SafeHash* h, char* name, int size, SafeHashFunctions fun) +{ + int i, bytes; + + size = align_up_pow2(size); + bytes = size * sizeof(SafeHashBucket*); + h->type = type; + h->tab = (SafeHashBucket**) erts_alloc(h->type, bytes); + sys_memzero(h->tab, bytes); + h->name = name; + h->fun = fun; + set_size(h,size); + erts_smp_atomic_init(&h->is_rehashing, 0); + erts_smp_atomic_init(&h->nitems, 0); + for (i=0; ilock_vec[i].mtx,"safe_hash"); + } + return h; +} + + +/* +** Find an object in the hash table +*/ +void* safe_hash_get(SafeHash* h, void* tmpl) +{ + SafeHashValue hval = h->fun.hash(tmpl); + SafeHashBucket* b; + erts_smp_mtx_t* lock = &h->lock_vec[hval % SAFE_HASH_LOCK_CNT].mtx; + erts_smp_mtx_lock(lock); + b = h->tab[hval & h->size_mask]; + + while(b != NULL) { + if ((b->hvalue == hval) && (h->fun.cmp(tmpl, (void*)b) == 0)) + break; + b = b->next; + } + erts_smp_mtx_unlock(lock); + return (void*) b; +} + +/* +** Find or insert an object in the hash table +*/ +void* safe_hash_put(SafeHash* h, void* tmpl) +{ + int grow_limit; + SafeHashValue hval = h->fun.hash(tmpl); + SafeHashBucket* b; + SafeHashBucket** head; + erts_smp_mtx_t* lock = &h->lock_vec[hval % SAFE_HASH_LOCK_CNT].mtx; + erts_smp_mtx_lock(lock); + head = &h->tab[hval & h->size_mask]; + b = *head; + while(b != NULL) { + if ((b->hvalue == hval) && (h->fun.cmp(tmpl, (void*)b) == 0)) { + erts_smp_mtx_unlock(lock); + return b; + } + b = b->next; + } + + b = (SafeHashBucket*) h->fun.alloc(tmpl); + b->hvalue = hval; + b->next = *head; + *head = b; + grow_limit = h->grow_limit; + erts_smp_mtx_unlock(lock); + if (erts_smp_atomic_inctest(&h->nitems) > grow_limit) { + rehash(h, grow_limit); + } + return (void*) b; +} + +/* +** Erase hash entry return template if erased +** return 0 if not erased +*/ +void* safe_hash_erase(SafeHash* h, void* tmpl) +{ + SafeHashValue hval = h->fun.hash(tmpl); + SafeHashBucket* b; + SafeHashBucket** prevp; + erts_smp_mtx_t* lock = &h->lock_vec[hval % SAFE_HASH_LOCK_CNT].mtx; + erts_smp_mtx_lock(lock); + prevp = &h->tab[hval & h->size_mask]; + b = *prevp; + while(b != NULL) { + if ((b->hvalue == hval) && (h->fun.cmp(tmpl, (void*)b) == 0)) { + *prevp = b->next; + erts_smp_mtx_unlock(lock); + erts_smp_atomic_dec(&h->nitems); + h->fun.free((void*)b); + return tmpl; + } + prevp = &b->next; + b = b->next; + } + erts_smp_mtx_unlock(lock); + return NULL; +} + +/* +** Call 'func(obj,func_arg2)' for all objects in table. NOT SAFE!!! +*/ +void safe_hash_for_each(SafeHash* h, void (*func)(void *, void *), void *func_arg2) +{ + int i; + + for (i = 0; i <= h->size_mask; i++) { + SafeHashBucket* b = h->tab[i]; + while (b != NULL) { + (*func)((void *) b, func_arg2); + b = b->next; + } + } +} + +#endif /* !ERTS_SYS_CONTINOUS_FD_NUMBERS */ + diff --git a/erts/emulator/beam/safe_hash.h b/erts/emulator/beam/safe_hash.h new file mode 100644 index 0000000000..c691126ef9 --- /dev/null +++ b/erts/emulator/beam/safe_hash.h @@ -0,0 +1,104 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2008-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* +** General thread safe hash table. Simular interface as hash.h +** +** Author: Sverker Eriksson +*/ +#ifndef __SAFE_HASH_H__ +#define __SAFE_HASH_H__ + + +#ifndef __SYS_H__ +#include "sys.h" +#endif + +#include "erl_alloc.h" + + +typedef unsigned long SafeHashValue; + +typedef int (*SHCMP_FUN)(void*, void*); +typedef SafeHashValue (*SH_FUN)(void*); +typedef void* (*SHALLOC_FUN)(void*); +typedef void (*SHFREE_FUN)(void*); + +/* +** This bucket must be placed in top of +** every object that uses hashing!!! +** (Object*) == (Object*) &bucket +*/ +typedef struct safe_hashbucket +{ + struct safe_hashbucket* next; /* Next bucket */ + SafeHashValue hvalue; /* Store hash value for get, rehash */ +} SafeHashBucket; + +typedef struct safe_hashfunctions +{ + SH_FUN hash; + SHCMP_FUN cmp; + SHALLOC_FUN alloc; + SHFREE_FUN free; +} SafeHashFunctions; + +typedef struct { + char *name; + int size; + int used; + int objs; + int depth; +} SafeHashInfo; + +#define SAFE_HASH_LOCK_CNT 16 +typedef struct +{ + SafeHashFunctions fun; /* (C) Function block */ + ErtsAlcType_t type; /* (C) */ + char* name; /* (C) Table name (static, for debugging) */ + int size_mask; /* (RW) Number of slots - 1 */ + SafeHashBucket** tab; /* (RW) Vector of bucket pointers (objects) */ + int grow_limit; /* (RW) Threshold for growing table */ + erts_smp_atomic_t nitems; /* (A) Number of items in table */ + erts_smp_atomic_t is_rehashing; /* (A) Table rehashing in progress */ + + union { + erts_smp_mtx_t mtx; + byte __cache_line__[64]; + }lock_vec[SAFE_HASH_LOCK_CNT]; + + /* C: Constants initialized once */ + /* RW: One lock (or is_rehashing) to read and _all_ locks to write */ + /* A: Lockless atomics */ +} SafeHash; + +SafeHash* safe_hash_init(ErtsAlcType_t, SafeHash*, char*, int, SafeHashFunctions); + +void safe_hash_get_info(SafeHashInfo*, SafeHash*); +int safe_hash_table_sz(SafeHash *); + +void* safe_hash_get(SafeHash*, void*); +void* safe_hash_put(SafeHash*, void*); +void* safe_hash_erase(SafeHash*, void*); + +void safe_hash_for_each(SafeHash*, void (*func)(void *, void *), void *); + +#endif /* __SAFE_HASH_H__ */ + diff --git a/erts/emulator/beam/sys.h b/erts/emulator/beam/sys.h new file mode 100644 index 0000000000..71cb6a36cc --- /dev/null +++ b/erts/emulator/beam/sys.h @@ -0,0 +1,1257 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifndef __SYS_H__ +#define __SYS_H__ + +#if defined(VALGRIND) && !defined(NO_FPE_SIGNALS) +# define NO_FPE_SIGNALS +#endif + +/* Never use elib-malloc when purify-memory-tracing */ +#if defined(PURIFY) +#undef ENABLE_ELIB_MALLOC +#undef ELIB_HEAP_SBRK +#undef ELIB_ALLOC_IS_CLIB +#endif + + +/* xxxP __VXWORKS__ */ +#ifdef VXWORKS +#include +#endif + +#ifdef DISABLE_CHILD_WAITER_THREAD +#undef ENABLE_CHILD_WAITER_THREAD +#endif + +#if defined(ERTS_SMP) && !defined(DISABLE_CHILD_WAITER_THREAD) +#undef ENABLE_CHILD_WAITER_THREAD +#define ENABLE_CHILD_WAITER_THREAD 1 +#endif + +/* The ERTS_TIMER_TREAD #define must be visible to the + erl_${OS}_sys.h #include files: it controls whether + certain optional facilities should be defined or not. */ +#if defined(ERTS_SMP) && 0 +#define ERTS_TIMER_THREAD +#endif + +#if defined (__WIN32__) +# include "erl_win_sys.h" +#elif defined (VXWORKS) +# include "erl_vxworks_sys.h" +#elif defined (_OSE_) +# include "erl_ose_sys.h" +#else +# include "erl_unix_sys.h" +#ifndef UNIX +# define UNIX 1 +#endif +#endif + +#include "erl_misc_utils.h" + +/* + * To allow building of Universal Binaries for Mac OS X, + * we must not depend on the endian detected by the configure script. + */ +#if defined(__APPLE__) +# if defined(__BIG_ENDIAN__) && !defined(WORDS_BIGENDIAN) +# define WORDS_BIGENDIAN 1 +# elif !defined(__BIG_ENDIAN__) && defined(WORDS_BIGENDIAN) +# undef WORDS_BIGENDIAN +# endif +#endif + +/* + * Make sure we have a type for FD's (used by erl_check_io) + */ + +#ifndef ERTS_SYS_FD_TYPE +typedef int ErtsSysFdType; +#else +typedef ERTS_SYS_FD_TYPE ErtsSysFdType; +#endif + +#ifdef ERTS_INLINE +# ifndef ERTS_CAN_INLINE +# define ERTS_CAN_INLINE 1 +# endif +#else +# if defined(__GNUC__) +# define ERTS_CAN_INLINE 1 +# define ERTS_INLINE __inline__ +# elif defined(__WIN32__) +# define ERTS_CAN_INLINE 1 +# define ERTS_INLINE __inline +# else +# define ERTS_CAN_INLINE 0 +# define ERTS_INLINE +# endif +#endif + +#ifdef __GNUC__ +# if __GNUC__ < 3 && (__GNUC__ != 2 || __GNUC_MINOR__ < 96) +# define ERTS_LIKELY(BOOL) (BOOL) +# define ERTS_UNLIKELY(BOOL) (BOOL) +# else +# define ERTS_LIKELY(BOOL) __builtin_expect((BOOL), !0) +# define ERTS_UNLIKELY(BOOL) __builtin_expect((BOOL), 0) +# endif +#else +# define ERTS_LIKELY(BOOL) (BOOL) +# define ERTS_UNLIKELY(BOOL) (BOOL) +#endif + +#if defined(DEBUG) || defined(ERTS_ENABLE_LOCK_CHECK) +# undef ERTS_CAN_INLINE +# define ERTS_CAN_INLINE 0 +# undef ERTS_INLINE +# define ERTS_INLINE +#endif + +#if ERTS_CAN_INLINE +#define ERTS_GLB_INLINE static ERTS_INLINE +#else +#define ERTS_GLB_INLINE +#endif + +#if ERTS_CAN_INLINE || defined(ERTS_DO_INCL_GLB_INLINE_FUNC_DEF) +# define ERTS_GLB_INLINE_INCL_FUNC_DEF 1 +#else +# define ERTS_GLB_INLINE_INCL_FUNC_DEF 0 +#endif + +#ifndef ERTS_EXIT_AFTER_DUMP +# define ERTS_EXIT_AFTER_DUMP exit +#endif + +#ifdef DEBUG +# define ASSERT(e) \ + if (e) { \ + ; \ + } else { \ + erl_assert_error(#e, __FILE__, __LINE__); \ + } +# define ASSERT_EXPR(e) \ + ((void) ((e) ? 1 : (erl_assert_error(#e, __FILE__, __LINE__), 0))) +void erl_assert_error(char* expr, char* file, int line); +#else +# define ASSERT(e) +# define ASSERT_EXPR(e) ((void) 1) +#endif + +/* + * Microsoft C/C++: We certainly want to use stdarg.h and prototypes. + * But MSC doesn't define __STDC__, unless we compile with the -Za + * flag (strict ANSI C, no Microsoft extension). Compiling with -Za + * doesn't work: some Microsoft headers fail to compile... + * + * Solution: Test if __STDC__ or _MSC_VER is defined. + * + * Note: Simply defining __STDC__ doesn't work, as some Microsoft + * headers will fail to compile! + */ + +#include + +#if defined(__STDC__) || defined(_MSC_VER) +# define EXTERN_FUNCTION(t, f, x) extern t f x +# define FUNCTION(t, f, x) t f x +# define _DOTS_ ... +# define _VOID_ void +#elif defined(__cplusplus) +# define EXTERN_FUNCTION(f, x) extern "C" { f x } +# define FUNCTION(t, f, x) t f x +# define _DOTS_ ... +# define _VOID_ void +#else +# define EXTERN_FUNCTION(t, f, x) extern t f (/*x*/) +# define FUNCTION(t, f, x) t f (/*x*/) +# define _DOTS_ +# define _VOID_ +#endif + +/* This isn't sys-dependent, but putting it here benefits sys.c and drivers + - allow use of 'const' regardless of compiler */ + +#if !defined(__STDC__) && !defined(_MSC_VER) +# define const +#endif + +#ifdef VXWORKS +/* Replace VxWorks' printf with a real one that does fprintf(stdout, ...) */ +EXTERN_FUNCTION(int, real_printf, (const char *fmt, ...)); +# define printf real_printf +#endif + +/* In VC++, noreturn is a declspec that has to be before the types, + * but in GNUC it is an att ribute to be placed between return type + * and function name, hence __decl_noreturn __noreturn + */ +#if __GNUC__ +# define __decl_noreturn +# define __noreturn __attribute__((noreturn)) +# undef __deprecated +# if __GNUC__ >= 3 +# define __deprecated __attribute__((deprecated)) +# else +# define __deprecated +# endif +#else +# if defined(__WIN32__) && defined(_MSC_VER) +# define __noreturn +# define __decl_noreturn __declspec(noreturn) +# else +# define __noreturn +# define __decl_noreturn +# endif +# define __deprecated +#endif + +/* +** Data types: +** +** Eterm: A tagged erlang term (possibly 64 bits) +** UInt: An unsigned integer exactly as large as an Eterm. +** SInt: A signed integer exactly as large as an eterm and therefor large +** enough to hold the return value of the signed_val() macro. +** Uint32: An unsigned integer of 32 bits exactly +** Sint32: A signed integer of 32 bits exactly +** Uint16: An unsigned integer of 16 bits exactly +** Sint16: A signed integer of 16 bits exactly. +*/ + +#if SIZEOF_VOID_P == 8 +#undef ARCH_32 +#define ARCH_64 +#elif SIZEOF_VOID_P == 4 +#define ARCH_32 +#undef ARCH_64 +#else +#error Neither 32 nor 64 bit architecture +#endif + +#if SIZEOF_VOID_P != SIZEOF_SIZE_T +#error sizeof(void*) != sizeof(size_t) +#endif + +#if SIZEOF_VOID_P == SIZEOF_LONG +typedef unsigned long Eterm; +typedef unsigned long Uint; +typedef long Sint; +#define ERTS_SIZEOF_ETERM SIZEOF_LONG +#elif SIZEOF_VOID_P == SIZEOF_INT +typedef unsigned int Eterm; +typedef unsigned int Uint; +typedef int Sint; +#define ERTS_SIZEOF_ETERM SIZEOF_INT +#else +#error Found no appropriate type to use for 'Eterm', 'Uint' and 'Sint' +#endif + +#ifndef HAVE_INT64 +#if SIZEOF_LONG == 8 +#define HAVE_INT64 1 +typedef unsigned long Uint64; +typedef long Sint64; +#elif SIZEOF_LONG_LONG == 8 +#define HAVE_INT64 1 +typedef unsigned long long Uint64; +typedef long long Sint64; +#else +#define HAVE_INT64 0 +#endif +#endif + +#if SIZEOF_LONG == 4 +typedef unsigned long Uint32; +typedef long Sint32; +#elif SIZEOF_INT == 4 +typedef unsigned int Uint32; +typedef int Sint32; +#else +#error Found no appropriate type to use for 'Uint32' and 'Sint32' +#endif + +#if SIZEOF_INT == 2 +typedef unsigned int Uint16; +typedef int Sint16; +#elif SIZEOF_SHORT == 2 +typedef unsigned short Uint16; +typedef short Sint16; +#else +#error Found no appropriate type to use for 'Uint16' and 'Sint16' +#endif + +#if CHAR_BIT == 8 +typedef unsigned char byte; +#else +#error Found no appropriate type to use for 'byte' +#endif + +#if defined(ARCH_64) && !HAVE_INT64 +#error 64-bit architecture, but no appropriate type to use for Uint64 and Sint64 found +#endif + +#if defined(ARCH_64) +# define ERTS_WORD_ALIGN_PAD_SZ(X) \ + (((size_t) 8) - (((size_t) (X)) & ((size_t) 7))) +#elif defined(ARCH_32) +# define ERTS_WORD_ALIGN_PAD_SZ(X) \ + (((size_t) 4) - (((size_t) (X)) & ((size_t) 3))) +#else +#error "Not supported..." +#endif + +#include "erl_lock_check.h" +#include "erl_smp.h" + +#ifdef ERTS_WANT_BREAK_HANDLING +# ifdef ERTS_SMP +extern erts_smp_atomic_t erts_break_requested; +# define ERTS_BREAK_REQUESTED ((int) erts_smp_atomic_read(&erts_break_requested)) +# else +extern volatile int erts_break_requested; +# define ERTS_BREAK_REQUESTED erts_break_requested +# endif +void erts_do_break_handling(void); +#endif + +#ifdef ERTS_WANT_GOT_SIGUSR1 +# ifndef UNIX +# define ERTS_GOT_SIGUSR1 0 +# else +# ifdef ERTS_SMP +extern erts_smp_atomic_t erts_got_sigusr1; +# define ERTS_GOT_SIGUSR1 ((int) erts_smp_atomic_read(&erts_got_sigusr1)) +# else +extern volatile int erts_got_sigusr1; +# define ERTS_GOT_SIGUSR1 erts_got_sigusr1 +# endif +# endif +#endif + +#ifdef ERTS_SMP +extern erts_smp_atomic_t erts_writing_erl_crash_dump; +#define ERTS_IS_CRASH_DUMPING \ + ((int) erts_smp_atomic_read(&erts_writing_erl_crash_dump)) +#else +extern volatile int erts_writing_erl_crash_dump; +#define ERTS_IS_CRASH_DUMPING erts_writing_erl_crash_dump +#endif + +/* Deal with memcpy() vs bcopy() etc. We want to use the mem*() functions, + but be able to fall back on bcopy() etc on systems that don't have + mem*(), but this doesn't work to well with memset()/bzero() - thus the + memzero() macro. +*/ + +/* xxxP */ +#if defined(USE_BCOPY) +# define memcpy(a, b, c) bcopy((b), (a), (c)) +# define memcmp(a, b, c) bcmp((a), (b), (c)) +# define memzero(buf, len) bzero((buf), (len)) +#else +# define memzero(buf, len) memset((buf), '\0', (len)) +#endif + +/* Stuff that is useful for port programs, drivers, etc */ + +#ifdef ISC32 /* Too much for the Makefile... */ +# define signal sigset +# define NO_ASINH +# define NO_ACOSH +# define NO_ATANH +# define NO_FTRUNCATE +# define SIG_SIGHOLD +# define _POSIX_SOURCE +# define _XOPEN_SOURCE +#endif + +#ifdef QNX /* Too much for the Makefile... */ +# define SYS_SELECT_H +# define NO_ERF +# define NO_ERFC +/* This definition doesn't take NaN into account, but matherr() gets those */ +# define finite(x) (fabs(x) != HUGE_VAL) +# define USE_MATHERR +# define HAVE_FINITE +#endif + + +#ifdef WANT_NONBLOCKING /* must define this to pull in fcntl.h/ioctl.h */ + +/* This is really a mess... We used to use fcntl O_NDELAY, but that seems + to only work on SunOS 4 - in particular, on SysV-based systems + (including Solaris 2), it does set non-blocking mode, but causes + read() to return 0!! fcntl O_NONBLOCK is specified by POSIX, and + seems to work on most systems, with the notable exception of AIX, + where the old ioctl FIONBIO is the *only* one that will set a *socket* + in non-blocking mode - and ioctl FIONBIO on AIX *doesn't* work for + pipes or ttys (O_NONBLOCK does)!!! For now, we'll use FIONBIO for AIX. */ + +# ifdef _OSE_ +static const int zero_value = 0, one_value = 1; +# define SET_BLOCKING(fd) ioctl((fd), FIONBIO, (char*)&zero_value) +# define SET_NONBLOCKING(fd) ioctl((fd), FIONBIO, (char*)&one_value) +# define ERRNO_BLOCK EWOULDBLOCK +# else + +# ifdef __WIN32__ + +static unsigned long zero_value = 0, one_value = 1; +# define SET_BLOCKING(fd) { if (ioctlsocket((fd), FIONBIO, &zero_value) != 0) fprintf(stderr, "Error setting socket to non-blocking: %d\n", WSAGetLastError()); } +# define SET_NONBLOCKING(fd) ioctlsocket((fd), FIONBIO, &one_value) + +# else +# ifdef VXWORKS +# include /* xxxP added for O_WRONLY etc ... macro:s ... */ +# include +static const int zero_value = 0, one_value = 1; +# define SET_BLOCKING(fd) ioctl((fd), FIONBIO, (int)&zero_value) +# define SET_NONBLOCKING(fd) ioctl((fd), FIONBIO, (int)&one_value) +# define ERRNO_BLOCK EWOULDBLOCK + +# else +# ifdef NB_FIONBIO /* Old BSD */ +# include + static const int zero_value = 0, one_value = 1; +# define SET_BLOCKING(fd) ioctl((fd), FIONBIO, &zero_value) +# define SET_NONBLOCKING(fd) ioctl((fd), FIONBIO, &one_value) +# define ERRNO_BLOCK EWOULDBLOCK +# else /* !NB_FIONBIO */ +# include +# ifdef NB_O_NDELAY /* Nothing needs this? */ +# define NB_FLAG O_NDELAY +# ifndef ERRNO_BLOCK /* allow override (e.g. EAGAIN) via Makefile */ +# define ERRNO_BLOCK EWOULDBLOCK +# endif +# else /* !NB_O_NDELAY */ /* The True Way - POSIX!:-) */ +# define NB_FLAG O_NONBLOCK +# define ERRNO_BLOCK EAGAIN +# endif /* !NB_O_NDELAY */ +# define SET_BLOCKING(fd) fcntl((fd), F_SETFL, \ + fcntl((fd), F_GETFL, 0) & ~NB_FLAG) +# define SET_NONBLOCKING(fd) fcntl((fd), F_SETFL, \ + fcntl((fd), F_GETFL, 0) | NB_FLAG) +# endif /* !NB_FIONBIO */ +# endif /* _WXWORKS_ */ +# endif /* !__WIN32__ */ +# endif /* _OSE_ */ +#endif /* WANT_NONBLOCKING */ + +extern erts_cpu_info_t *erts_cpuinfo; /* erl_init.c */ + +__decl_noreturn void __noreturn erl_exit(int n, char*, ...); + +/* Some special erl_exit() codes: */ +#define ERTS_INTR_EXIT INT_MIN /* called from signal handler */ +#define ERTS_ABORT_EXIT (INT_MIN + 1) /* no crash dump; only abort() */ +#define ERTS_DUMP_EXIT (127) /* crash dump; then exit() */ + + +#ifndef ERTS_SMP +int check_async_ready(void); +#ifdef USE_THREADS +void sys_async_ready(int hndl); +int erts_register_async_ready_callback(void (*funcp)(void)); +#endif +#endif + +Eterm erts_check_io_info(void *p); + +/* Size of misc memory allocated from system dependent code */ +Uint erts_sys_misc_mem_sz(void); + +/* print stuff is declared here instead of in global.h, so sys stuff won't + have to include global.h */ +#include "erl_printf.h" + +/* Io constants to erts_print and erts_putc */ +#define ERTS_PRINT_STDERR (2) +#define ERTS_PRINT_STDOUT (1) +#define ERTS_PRINT_INVALID (0) /* Don't want to use 0 since CBUF was 0 */ +#define ERTS_PRINT_FILE (-1) +#define ERTS_PRINT_SBUF (-2) +#define ERTS_PRINT_SNBUF (-3) +#define ERTS_PRINT_DSBUF (-4) + +#define ERTS_PRINT_MIN ERTS_PRINT_DSBUF + +typedef struct { + char *buf; + size_t size; +} erts_print_sn_buf; + +int erts_print(int to, void *arg, char *format, ...); /* in utils.c */ +int erts_putc(int to, void *arg, char); /* in utils.c */ + +/* logger stuff is declared here instead of in global.h, so sys files + won't have to include global.h */ + +erts_dsprintf_buf_t *erts_create_logger_dsbuf(void); +int erts_send_info_to_logger(Eterm, erts_dsprintf_buf_t *); +int erts_send_warning_to_logger(Eterm, erts_dsprintf_buf_t *); +int erts_send_error_to_logger(Eterm, erts_dsprintf_buf_t *); +int erts_send_info_to_logger_str(Eterm, char *); +int erts_send_warning_to_logger_str(Eterm, char *); +int erts_send_error_to_logger_str(Eterm, char *); +int erts_send_info_to_logger_nogl(erts_dsprintf_buf_t *); +int erts_send_warning_to_logger_nogl(erts_dsprintf_buf_t *); +int erts_send_error_to_logger_nogl(erts_dsprintf_buf_t *); +int erts_send_info_to_logger_str_nogl(char *); +int erts_send_warning_to_logger_str_nogl(char *); +int erts_send_error_to_logger_str_nogl(char *); + +typedef struct preload { + char *name; /* Name of module */ + int size; /* Size of code */ + unsigned char* code; /* Code pointer */ +} Preload; + + +/* + * This structure contains options to all built in drivers. + * None of the drivers use all of the fields. + */ + +/* OSE: Want process_type and priority in here as well! Needs updates in erl_bif_ports.c! */ + +typedef struct _SysDriverOpts { + int ifd; /* Input file descriptor (fd driver). */ + int ofd; /* Outputfile descriptor (fd driver). */ + int packet_bytes; /* Number of bytes in packet header. */ + int read_write; /* Read and write bits. */ + int use_stdio; /* Use standard I/O: TRUE or FALSE. */ + int redir_stderr; /* Redirect stderr to stdout: TRUE/FALSE. */ + int hide_window; /* Hide this windows (Windows). */ + int exit_status; /* Report exit status of subprocess. */ + int overlapped_io; /* Only has effect on windows NT et al */ + char *envir; /* Environment of the port process, */ + /* in Windows format. */ + char **argv; /* Argument vector in Unix'ish format. */ + char *wd; /* Working directory. */ + unsigned spawn_type; /* Bitfield of ERTS_SPAWN_DRIVER | + ERTS_SPAWN_EXTERNAL | both*/ + +#ifdef _OSE_ + enum PROCESS_TYPE process_type; + OSPRIORITY priority; +#endif /* _OSE_ */ + +} SysDriverOpts; + +extern char *erts_default_arg0; + +extern char os_type[]; + +extern int sys_init_time(void); +#if defined(ERTS_TIMER_THREAD) +#define erts_deliver_time() +#else +extern void erts_deliver_time(void); +#endif +extern void erts_time_remaining(SysTimeval *); +extern int erts_init_time_sup(void); +extern void erts_sys_init_float(void); +extern void erts_thread_init_float(void); +extern void erts_thread_disable_fpe(void); + +ERTS_GLB_INLINE int erts_block_fpe(void); +ERTS_GLB_INLINE void erts_unblock_fpe(int); + +#if ERTS_GLB_INLINE_INCL_FUNC_DEF + +ERTS_GLB_INLINE int erts_block_fpe(void) +{ + return erts_sys_block_fpe(); +} + +ERTS_GLB_INLINE void erts_unblock_fpe(int unmasked) +{ + erts_sys_unblock_fpe(unmasked); +} + +#endif /* #if ERTS_GLB_INLINE_INCL_FUNC_DEF */ + + +/* Dynamic library/driver loading */ +typedef struct { + char* str; +}ErtsSysDdllError; +#define ERTS_SYS_DDLL_ERROR_INIT {NULL} +extern void erts_sys_ddll_free_error(ErtsSysDdllError*); +extern void erl_sys_ddll_init(void); /* to initialize mutexes etc */ +extern int erts_sys_ddll_open2(char *path, void **handle, ErtsSysDdllError*); +#define erts_sys_ddll_open(P,H) erts_sys_ddll_open2(P,H,NULL) +extern int erts_sys_ddll_open_noext(char *path, void **handle, ErtsSysDdllError*); +extern int erts_sys_ddll_load_driver_init(void *handle, void **function); +extern int erts_sys_ddll_load_nif_init(void *handle, void **function,ErtsSysDdllError*); +extern int erts_sys_ddll_close2(void *handle, ErtsSysDdllError*); +#define erts_sys_ddll_close(H) erts_sys_ddll_close2(H,NULL) +extern void *erts_sys_ddll_call_init(void *function); +extern void *erts_sys_ddll_call_nif_init(void *function); +extern int erts_sys_ddll_sym2(void *handle, char *name, void **function, ErtsSysDdllError*); +#define erts_sys_ddll_sym(H,N,F) erts_sys_ddll_sym2(H,N,F,NULL) +extern char *erts_sys_ddll_error(int code); + + + +/* + * System interfaces for startup/sae code (functions found in respective sys.c) + */ + + +#ifdef ERTS_SMP +void erts_sys_schedule_interrupt(int set); +void erts_sys_schedule_interrupt_timed(int set, long msec); +void erts_sys_main_thread(void); +#else +#define erts_sys_schedule_interrupt(Set) +#endif + +extern void erts_sys_prepare_crash_dump(void); +extern void erts_sys_pre_init(void); +extern void erl_sys_init(void); +extern void erl_sys_args(int *argc, char **argv); +extern void erl_sys_schedule(int); +#ifdef _OSE_ +extern void erl_sys_init_final(void); +#else +void sys_tty_reset(void); +#endif + +EXTERN_FUNCTION(int, sys_max_files, (_VOID_)); +void sys_init_io(void); +Preload* sys_preloaded(void); +EXTERN_FUNCTION(unsigned char*, sys_preload_begin, (Preload*)); +EXTERN_FUNCTION(void, sys_preload_end, (Preload*)); +EXTERN_FUNCTION(int, sys_get_key, (int)); +void elapsed_time_both(unsigned long *ms_user, unsigned long *ms_sys, + unsigned long *ms_user_diff, unsigned long *ms_sys_diff); +void wall_clock_elapsed_time_both(unsigned long *ms_total, + unsigned long *ms_diff); +void get_time(int *hour, int *minute, int *second); +void get_date(int *year, int *month, int *day); +void get_localtime(int *year, int *month, int *day, + int *hour, int *minute, int *second); +void get_universaltime(int *year, int *month, int *day, + int *hour, int *minute, int *second); +int univ_to_local(Sint *year, Sint *month, Sint *day, + Sint *hour, Sint *minute, Sint *second); +int local_to_univ(Sint *year, Sint *month, Sint *day, + Sint *hour, Sint *minute, Sint *second, int isdst); +void get_now(Uint*, Uint*, Uint*); +void get_sys_now(Uint*, Uint*, Uint*); +EXTERN_FUNCTION(void, set_break_quit, (void (*)(void), void (*)(void))); + +void os_flavor(char*, unsigned); +void os_version(int*, int*, int*); +void init_getenv_state(GETENV_STATE *); +char * getenv_string(GETENV_STATE *); +void fini_getenv_state(GETENV_STATE *); + +/* xxxP */ +void init_sys_float(void); +int sys_chars_to_double(char*, double*); +int sys_double_to_chars(double, char*); +void sys_get_pid(char *); + +/* erts_sys_putenv() returns, 0 on success and a value != 0 on failure. */ +int erts_sys_putenv(char *key_value, int sep_ix); +/* erts_sys_getenv() returns 0 on success (length of value string in + *size), a value > 0 if value buffer is too small (*size is set to needed + size), and a value < 0 on failure. */ +int erts_sys_getenv(char *key, char *value, size_t *size); + +/* Easier to use, but not as efficient, environment functions */ +char *erts_read_env(char *key); +void erts_free_read_env(void *value); +int erts_write_env(char *key, char *value); + +/* utils.c */ + +/* Options to sys_alloc_opt */ +#define SYS_ALLOC_OPT_TRIM_THRESHOLD 0 +#define SYS_ALLOC_OPT_TOP_PAD 1 +#define SYS_ALLOC_OPT_MMAP_THRESHOLD 2 +#define SYS_ALLOC_OPT_MMAP_MAX 3 + +/* Default values to sys_alloc_opt options */ +#define ERTS_DEFAULT_TRIM_THRESHOLD (128 * 1024) +#define ERTS_DEFAULT_TOP_PAD 0 +#define ERTS_DEFAULT_MMAP_THRESHOLD (128 * 1024) +#define ERTS_DEFAULT_MMAP_MAX 64 + +EXTERN_FUNCTION(int, sys_alloc_opt, (int, int)); + +typedef struct { + Sint trim_threshold; + Sint top_pad; + Sint mmap_threshold; + Sint mmap_max; +} SysAllocStat; + +EXTERN_FUNCTION(void, sys_alloc_stat, (SysAllocStat *)); + +/* Block the whole system... */ + +#define ERTS_BS_FLG_ALLOW_GC (((Uint32) 1) << 0) +#define ERTS_BS_FLG_ALLOW_IO (((Uint32) 1) << 1) + +/* Activities... */ +typedef enum { + ERTS_ACTIVITY_UNDEFINED, /* Undefined activity */ + ERTS_ACTIVITY_WAIT, /* Waiting */ + ERTS_ACTIVITY_GC, /* Garbage collecting */ + ERTS_ACTIVITY_IO /* I/O including message passing to erl procs */ +} erts_activity_t; + +#ifdef ERTS_SMP + +typedef enum { + ERTS_ACT_ERR_LEAVE_WAIT_UNLOCKED, + ERTS_ACT_ERR_LEAVE_UNKNOWN_ACTIVITY, + ERTS_ACT_ERR_ENTER_UNKNOWN_ACTIVITY +} erts_activity_error_t; + +typedef struct { + erts_smp_atomic_t do_block; + struct { + erts_smp_atomic_t wait; + erts_smp_atomic_t gc; + erts_smp_atomic_t io; + } in_activity; +} erts_system_block_state_t; + +extern erts_system_block_state_t erts_system_block_state; + +int erts_is_system_blocked(erts_activity_t allowed_activities); +void erts_block_me(void (*prepare)(void *), void (*resume)(void *), void *arg); +void erts_register_blockable_thread(void); +void erts_unregister_blockable_thread(void); +void erts_note_activity_begin(erts_activity_t activity); +void +erts_check_block(erts_activity_t old_activity, + erts_activity_t new_activity, + int locked, + void (*prepare)(void *), + void (*resume)(void *), + void *arg); +void erts_block_system(Uint32 allowed_activities); +int erts_emergency_block_system(long timeout, Uint32 allowed_activities); +void erts_release_system(void); +void erts_system_block_init(void); +void erts_set_activity_error(erts_activity_error_t, char *, int); +#ifdef ERTS_ENABLE_LOCK_CHECK +void erts_lc_activity_change_begin(void); +void erts_lc_activity_change_end(void); +int erts_lc_is_blocking(void); +#define ERTS_LC_IS_BLOCKING \ + (erts_smp_pending_system_block() && erts_lc_is_blocking()) +#endif +#endif + +#define erts_smp_activity_begin(NACT, PRP, RSM, ARG) \ + erts_smp_set_activity(ERTS_ACTIVITY_UNDEFINED, \ + (NACT), \ + 0, \ + (PRP), \ + (RSM), \ + (ARG), \ + __FILE__, \ + __LINE__) +#define erts_smp_activity_change(OACT, NACT, PRP, RSM, ARG) \ + erts_smp_set_activity((OACT), \ + (NACT), \ + 0, \ + (PRP), \ + (RSM), \ + (ARG), \ + __FILE__, \ + __LINE__) +#define erts_smp_activity_end(OACT, PRP, RSM, ARG) \ + erts_smp_set_activity((OACT), \ + ERTS_ACTIVITY_UNDEFINED, \ + 0, \ + (PRP), \ + (RSM), \ + (ARG), \ + __FILE__, \ + __LINE__) + +#define erts_smp_locked_activity_begin(NACT) \ + erts_smp_set_activity(ERTS_ACTIVITY_UNDEFINED, \ + (NACT), \ + 1, \ + NULL, \ + NULL, \ + NULL, \ + __FILE__, \ + __LINE__) +#define erts_smp_locked_activity_change(OACT, NACT) \ + erts_smp_set_activity((OACT), \ + (NACT), \ + 1, \ + NULL, \ + NULL, \ + NULL, \ + __FILE__, \ + __LINE__) +#define erts_smp_locked_activity_end(OACT) \ + erts_smp_set_activity((OACT), \ + ERTS_ACTIVITY_UNDEFINED, \ + 1, \ + NULL, \ + NULL, \ + NULL, \ + __FILE__, \ + __LINE__) + + +ERTS_GLB_INLINE int erts_smp_is_system_blocked(erts_activity_t allowed_activities); +ERTS_GLB_INLINE void erts_smp_block_system(Uint32 allowed_activities); +ERTS_GLB_INLINE int erts_smp_emergency_block_system(long timeout, + Uint32 allowed_activities); +ERTS_GLB_INLINE void erts_smp_release_system(void); +ERTS_GLB_INLINE int erts_smp_pending_system_block(void); +ERTS_GLB_INLINE void erts_smp_chk_system_block(void (*prepare)(void *), + void (*resume)(void *), + void *arg); +ERTS_GLB_INLINE void +erts_smp_set_activity(erts_activity_t old_activity, + erts_activity_t new_activity, + int locked, + void (*prepare)(void *), + void (*resume)(void *), + void *arg, + char *file, + int line); + +#if ERTS_GLB_INLINE_INCL_FUNC_DEF + + +ERTS_GLB_INLINE int +erts_smp_is_system_blocked(erts_activity_t allowed_activities) +{ +#ifdef ERTS_SMP + return erts_is_system_blocked(allowed_activities); +#else + return 1; +#endif +} + +ERTS_GLB_INLINE void +erts_smp_block_system(Uint32 allowed_activities) +{ +#ifdef ERTS_SMP + erts_block_system(allowed_activities); +#endif +} + +ERTS_GLB_INLINE int +erts_smp_emergency_block_system(long timeout, Uint32 allowed_activities) +{ +#ifdef ERTS_SMP + return erts_emergency_block_system(timeout, allowed_activities); +#else + return 0; +#endif +} + +ERTS_GLB_INLINE void +erts_smp_release_system(void) +{ +#ifdef ERTS_SMP + erts_release_system(); +#endif +} + +ERTS_GLB_INLINE int +erts_smp_pending_system_block(void) +{ +#ifdef ERTS_SMP + return erts_smp_atomic_read(&erts_system_block_state.do_block); +#else + return 0; +#endif +} + + +ERTS_GLB_INLINE void +erts_smp_chk_system_block(void (*prepare)(void *), + void (*resume)(void *), + void *arg) +{ +#ifdef ERTS_SMP + if (erts_smp_pending_system_block()) + erts_block_me(prepare, resume, arg); +#endif +} + +ERTS_GLB_INLINE void +erts_smp_set_activity(erts_activity_t old_activity, + erts_activity_t new_activity, + int locked, + void (*prepare)(void *), + void (*resume)(void *), + void *arg, + char *file, + int line) +{ +#ifdef ERTS_SMP +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_activity_change_begin(); +#endif + switch (old_activity) { + case ERTS_ACTIVITY_UNDEFINED: + break; + case ERTS_ACTIVITY_WAIT: + erts_smp_atomic_dec(&erts_system_block_state.in_activity.wait); + if (locked) { + /* You are not allowed to leave activity waiting + * without supplying the possibility to block + * unlocked. + */ + erts_set_activity_error(ERTS_ACT_ERR_LEAVE_WAIT_UNLOCKED, + file, line); + } + break; + case ERTS_ACTIVITY_GC: + erts_smp_atomic_dec(&erts_system_block_state.in_activity.gc); + break; + case ERTS_ACTIVITY_IO: + erts_smp_atomic_dec(&erts_system_block_state.in_activity.io); + break; + default: + erts_set_activity_error(ERTS_ACT_ERR_LEAVE_UNKNOWN_ACTIVITY, + file, line); + break; + } + + /* We are not allowed to block when going to activity waiting... */ + if (new_activity != ERTS_ACTIVITY_WAIT && erts_smp_pending_system_block()) + erts_check_block(old_activity,new_activity,locked,prepare,resume,arg); + + switch (new_activity) { + case ERTS_ACTIVITY_UNDEFINED: + break; + case ERTS_ACTIVITY_WAIT: + erts_smp_atomic_inc(&erts_system_block_state.in_activity.wait); + break; + case ERTS_ACTIVITY_GC: + erts_smp_atomic_inc(&erts_system_block_state.in_activity.gc); + break; + case ERTS_ACTIVITY_IO: + erts_smp_atomic_inc(&erts_system_block_state.in_activity.io); + break; + default: + erts_set_activity_error(ERTS_ACT_ERR_ENTER_UNKNOWN_ACTIVITY, + file, line); + break; + } + + switch (new_activity) { + case ERTS_ACTIVITY_WAIT: + case ERTS_ACTIVITY_GC: + case ERTS_ACTIVITY_IO: + if (erts_smp_pending_system_block()) + erts_note_activity_begin(new_activity); + break; + default: + break; + } + +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_activity_change_end(); +#endif + +#endif +} + +#endif /* #if ERTS_GLB_INLINE_INCL_FUNC_DEF */ + +#if defined(DEBUG) || defined(ERTS_ENABLE_LOCK_CHECK) +#undef ERTS_REFC_DEBUG +#define ERTS_REFC_DEBUG +#endif + +typedef erts_smp_atomic_t erts_refc_t; + +ERTS_GLB_INLINE void erts_refc_init(erts_refc_t *refcp, long val); +ERTS_GLB_INLINE void erts_refc_inc(erts_refc_t *refcp, long min_val); +ERTS_GLB_INLINE long erts_refc_inctest(erts_refc_t *refcp, long min_val); +ERTS_GLB_INLINE void erts_refc_dec(erts_refc_t *refcp, long min_val); +ERTS_GLB_INLINE long erts_refc_dectest(erts_refc_t *refcp, long min_val); +ERTS_GLB_INLINE void erts_refc_add(erts_refc_t *refcp, long diff, long min_val); +ERTS_GLB_INLINE long erts_refc_read(erts_refc_t *refcp, long min_val); + +#if ERTS_GLB_INLINE_INCL_FUNC_DEF + +ERTS_GLB_INLINE void +erts_refc_init(erts_refc_t *refcp, long val) +{ + erts_smp_atomic_init((erts_smp_atomic_t *) refcp, val); +} + +ERTS_GLB_INLINE void +erts_refc_inc(erts_refc_t *refcp, long min_val) +{ +#ifdef ERTS_REFC_DEBUG + long val = erts_smp_atomic_inctest((erts_smp_atomic_t *) refcp); + if (val < min_val) + erl_exit(ERTS_ABORT_EXIT, + "erts_refc_inc(): Bad refc found (refc=%ld < %ld)!\n", + val, min_val); +#else + erts_smp_atomic_inc((erts_smp_atomic_t *) refcp); +#endif +} + +ERTS_GLB_INLINE long +erts_refc_inctest(erts_refc_t *refcp, long min_val) +{ + long val = erts_smp_atomic_inctest((erts_smp_atomic_t *) refcp); +#ifdef ERTS_REFC_DEBUG + if (val < min_val) + erl_exit(ERTS_ABORT_EXIT, + "erts_refc_inctest(): Bad refc found (refc=%ld < %ld)!\n", + val, min_val); +#endif + return val; +} + +ERTS_GLB_INLINE void +erts_refc_dec(erts_refc_t *refcp, long min_val) +{ +#ifdef ERTS_REFC_DEBUG + long val = erts_smp_atomic_dectest((erts_smp_atomic_t *) refcp); + if (val < min_val) + erl_exit(ERTS_ABORT_EXIT, + "erts_refc_dec(): Bad refc found (refc=%ld < %ld)!\n", + val, min_val); +#else + erts_smp_atomic_dec((erts_smp_atomic_t *) refcp); +#endif +} + +ERTS_GLB_INLINE long +erts_refc_dectest(erts_refc_t *refcp, long min_val) +{ + long val = erts_smp_atomic_dectest((erts_smp_atomic_t *) refcp); +#ifdef ERTS_REFC_DEBUG + if (val < min_val) + erl_exit(ERTS_ABORT_EXIT, + "erts_refc_dectest(): Bad refc found (refc=%ld < %ld)!\n", + val, min_val); +#endif + return val; +} + +ERTS_GLB_INLINE void +erts_refc_add(erts_refc_t *refcp, long diff, long min_val) +{ +#ifdef ERTS_REFC_DEBUG + long val = erts_smp_atomic_addtest((erts_smp_atomic_t *) refcp, diff); + if (val < min_val) + erl_exit(ERTS_ABORT_EXIT, + "erts_refc_add(%ld): Bad refc found (refc=%ld < %ld)!\n", + diff, val, min_val); +#else + erts_smp_atomic_add((erts_smp_atomic_t *) refcp, diff); +#endif +} + +ERTS_GLB_INLINE long +erts_refc_read(erts_refc_t *refcp, long min_val) +{ + long val = erts_smp_atomic_read((erts_smp_atomic_t *) refcp); +#ifdef ERTS_REFC_DEBUG + if (val < min_val) + erl_exit(ERTS_ABORT_EXIT, + "erts_refc_read(): Bad refc found (refc=%ld < %ld)!\n", + val, min_val); +#endif + return val; +} + +#endif /* #if ERTS_GLB_INLINE_INCL_FUNC_DEF */ + +#ifdef ERTS_ENABLE_KERNEL_POLL +extern int erts_use_kernel_poll; +#endif + +void elib_ensure_initialized(void); + + +#if (defined(VXWORKS) || defined(_OSE_)) +/* NOTE! sys_calloc2 does not exist on other + platforms than VxWorks and OSE */ +EXTERN_FUNCTION(void*, sys_calloc2, (Uint, Uint)); +#endif /* VXWORKS || OSE */ + + +#define sys_memcpy(s1,s2,n) memcpy(s1,s2,n) +#define sys_memmove(s1,s2,n) memmove(s1,s2,n) +#define sys_memcmp(s1,s2,n) memcmp(s1,s2,n) +#define sys_memset(s,c,n) memset(s,c,n) +#define sys_memzero(s, n) memset(s,'\0',n) +#define sys_strcmp(s1,s2) strcmp(s1,s2) +#define sys_strncmp(s1,s2,n) strncmp(s1,s2,n) +#define sys_strcpy(s1,s2) strcpy(s1,s2) +#define sys_strncpy(s1,s2,n) strncpy(s1,s2,n) +#define sys_strlen(s) strlen(s) + +/* define function symbols (needed in sys_drv_api) */ +#define sys_fp_alloc sys_alloc +#define sys_fp_realloc sys_realloc +#define sys_fp_free sys_free +#define sys_fp_memcpy memcpy +#define sys_fp_memmove memmove +#define sys_fp_memcmp memcmp +#define sys_fp_memset memset +/* #define sys_fp_memzero elib_memzero */ +#define sys_fp_strcmp strcmp +#define sys_fp_strncmp strncmp +#define sys_fp_strcpy strcpy +#define sys_fp_strncpy strncpy +#define sys_fp_strlen strlen + + +/* Return codes from the nb_read and nb_write functions */ +#define FD_READY 1 +#define FD_CONTINUE 2 +#define FD_ERROR 3 + + + +/* Standard set of integer macros .. */ + +#define get_int64(s) ((((unsigned char*) (s))[0] << 56) | \ + (((unsigned char*) (s))[1] << 48) | \ + (((unsigned char*) (s))[2] << 40) | \ + (((unsigned char*) (s))[3] << 32) | \ + (((unsigned char*) (s))[4] << 24) | \ + (((unsigned char*) (s))[5] << 16) | \ + (((unsigned char*) (s))[6] << 8) | \ + (((unsigned char*) (s))[7])) + +#define put_int64(i, s) do {((char*)(s))[0] = (char)((Sint64)(i) >> 56) & 0xff;\ + ((char*)(s))[1] = (char)((Sint64)(i) >> 48) & 0xff;\ + ((char*)(s))[2] = (char)((Sint64)(i) >> 40) & 0xff;\ + ((char*)(s))[3] = (char)((Sint64)(i) >> 32) & 0xff;\ + ((char*)(s))[4] = (char)((Sint64)(i) >> 24) & 0xff;\ + ((char*)(s))[5] = (char)((Sint64)(i) >> 16) & 0xff;\ + ((char*)(s))[6] = (char)((Sint64)(i) >> 8) & 0xff;\ + ((char*)(s))[7] = (char)((Sint64)(i)) & 0xff;\ + } while (0) + +#define get_int32(s) ((((unsigned char*) (s))[0] << 24) | \ + (((unsigned char*) (s))[1] << 16) | \ + (((unsigned char*) (s))[2] << 8) | \ + (((unsigned char*) (s))[3])) + +#define put_int32(i, s) do {((char*)(s))[0] = (char)((i) >> 24) & 0xff; \ + ((char*)(s))[1] = (char)((i) >> 16) & 0xff; \ + ((char*)(s))[2] = (char)((i) >> 8) & 0xff; \ + ((char*)(s))[3] = (char)(i) & 0xff;} \ + while (0) + +#define get_int16(s) ((((unsigned char*) (s))[0] << 8) | \ + (((unsigned char*) (s))[1])) + + +#define put_int16(i, s) do {((char*)(s))[0] = (char)((i) >> 8) & 0xff; \ + ((char*)(s))[1] = (char)(i) & 0xff;} \ + while (0) + +#define get_int8(s) ((((unsigned char*) (s))[0] )) + + +#define put_int8(i, s) do {((unsigned char*)(s))[0] = (i) & 0xff;} while (0) + +/* + * Use DEBUGF as you would use printf, but use double parentheses: + * + * DEBUGF(("Error: %s\n", error)); + * + * The output will appear in a special console. + */ + +#ifdef DEBUG +EXTERN_FUNCTION(void, erl_debug, (char* format, ...)); +EXTERN_FUNCTION(void, erl_bin_write, (unsigned char *, int, int)); + +# define DEBUGF(x) erl_debug x +#else +# define DEBUGF(x) +#endif + + +#ifdef VXWORKS +/* This includes redefines of malloc etc + this should be done after sys_alloc, etc, above */ +# include "reclaim.h" +/*********************Malloc and friends************************ + * There is a problem with the naming of malloc and friends, + * malloc is used throughout sys.c and the resolver to mean save_alloc, + * but it should actually mean either sys_alloc or sys_alloc2, + * so the definitions from reclaim_master.h are not any + * good, i redefine the malloc family here, although it's quite + * ugly, actually it would be preferrable to use the + * names sys_alloc and so on throughout the offending code, but + * that will be saved as an later exercise... + * I also add an own calloc, to make the BSD resolver source happy. + ***************************************************************/ +/* Undefine malloc and friends */ +# ifdef malloc +# undef malloc +# endif +# ifdef calloc +# undef calloc +# endif +# ifdef realloc +# undef realloc +# endif +# ifdef free +# undef free +# endif +/* Redefine malloc and friends */ +# define malloc sys_alloc +# define calloc sys_calloc +# define realloc sys_realloc +# define free sys_free + +#endif + + +#ifdef __WIN32__ + +void call_break_handler(void); +char* last_error(void); +char* win32_errorstr(int); + + +#endif + + +#endif + diff --git a/erts/emulator/beam/time.c b/erts/emulator/beam/time.c new file mode 100644 index 0000000000..a07d6a5327 --- /dev/null +++ b/erts/emulator/beam/time.c @@ -0,0 +1,571 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +/* + * TIMING WHEEL + * + * Timeouts kept in an wheel. A timeout is measured relative to the + * current slot (tiw_pos) in the wheel, and inserted at slot + * (tiw_pos + timeout) % TIW_SIZE. Each timeout also has a count + * equal to timeout/TIW_SIZE, which is needed since the time axis + * is wrapped arount the wheel. + * + * Several slots may be processed in one operation. If the number of + * slots is greater that the wheel size, the wheel is only traversed + * once, + * + * The following example shows a time axis where there is one timeout + * at each "tick", and where 1, 2, 3 ... wheel slots are released in + * one operation. The notation "tv_usec = 1000 * (now->tv_usec / 1000); /* ms resolution */ + elapsed = (1000 * (now->tv_sec - time_start.tv_sec) + + (now->tv_usec - time_start.tv_usec) / 1000); + // elapsed /= CLOCK_RESOLUTION; + return elapsed; +} + +static long do_time_update(void) +{ + SysTimeval now; + long elapsed; + + elapsed = time_gettimeofday(&now); + ticks_latest = elapsed; + return elapsed; +} + +static ERTS_INLINE long do_time_read(void) +{ + return ticks_latest; +} + +static long do_time_reset(void) +{ + SysTimeval now; + long elapsed; + + elapsed = time_gettimeofday(&now); + time_start = now; + ticks_end = LONG_MAX; + ticks_latest = 0; + return elapsed; +} + +static ERTS_INLINE void do_time_init(void) +{ + (void)do_time_reset(); +} + +#else +erts_smp_atomic_t do_time; /* set at clock interrupt */ +static ERTS_INLINE long do_time_read(void) { return erts_smp_atomic_read(&do_time); } +static ERTS_INLINE long do_time_update(void) { return do_time_read(); } +static ERTS_INLINE void do_time_init(void) { erts_smp_atomic_init(&do_time, 0L); } +#endif + +/* get the time (in units of itime) to the next timeout, + or -1 if there are no timeouts */ + +static int next_time_internal(void) /* PRE: tiw_lock taken by caller */ +{ + int i, tm, nto; + unsigned int min; + ErlTimer* p; + long dt; + + if (tiw_nto == 0) + return -1; /* no timeouts in wheel */ + + /* start going through wheel to find next timeout */ + tm = nto = 0; + min = (unsigned int) -1; /* max unsigned int */ + i = tiw_pos; + do { + p = tiw[i]; + while (p != NULL) { + nto++; + if (p->count == 0) { + /* found next timeout */ + dt = do_time_read(); + return ((tm >= dt) ? (tm - dt) : 0); + } else { + /* keep shortest time in 'min' */ + if (tm + p->count*TIW_SIZE < min) + min = tm + p->count*TIW_SIZE; + } + p = p->next; + } + /* when we have found all timeouts the shortest time will be in min */ + if (nto == tiw_nto) break; + tm++; + i = (i + 1) % TIW_SIZE; + } while (i != tiw_pos); + dt = do_time_read(); + return ((min >= dt) ? (min - dt) : 0); +} + +#if !defined(ERTS_TIMER_THREAD) +/* Private export to erl_time_sup.c */ +int next_time(void) +{ + int ret; + + tiw_write_lock(); + (void)do_time_update(); + ret = next_time_internal(); + tiw_write_unlock(); + return ret; +} +#endif + +static ERTS_INLINE void bump_timer_internal(long dt) /* PRE: tiw_lock is write-locked */ +{ + Uint keep_pos; + Uint count; + ErlTimer *p, **prev, *timeout_head, **timeout_tail; + Uint dtime = (unsigned long)dt; + + /* no need to bump the position if there aren't any timeouts */ + if (tiw_nto == 0) { + tiw_write_unlock(); + return; + } + + /* if do_time > TIW_SIZE we want to go around just once */ + count = (Uint)(dtime / TIW_SIZE) + 1; + keep_pos = (tiw_pos + dtime) % TIW_SIZE; + if (dtime > TIW_SIZE) dtime = TIW_SIZE; + + timeout_head = NULL; + timeout_tail = &timeout_head; + while (dtime > 0) { + /* this is to decrease the counters with the right amount */ + /* when dtime >= TIW_SIZE */ + if (tiw_pos == keep_pos) count--; + prev = &tiw[tiw_pos]; + while ((p = *prev) != NULL) { + if (p->count < count) { /* we have a timeout */ + *prev = p->next; /* Remove from list */ + tiw_nto--; + p->next = NULL; + p->active = 0; /* Make sure cancel callback + isn't called */ + *timeout_tail = p; /* Insert in timeout queue */ + timeout_tail = &p->next; + } + else { + /* no timeout, just decrease counter */ + p->count -= count; + prev = &p->next; + } + } + tiw_pos = (tiw_pos + 1) % TIW_SIZE; + dtime--; + } + tiw_pos = keep_pos; + + tiw_write_unlock(); + + /* Call timedout timers callbacks */ + while (timeout_head) { + p = timeout_head; + timeout_head = p->next; + /* Here comes hairy use of the timer fields! + * They are reset without having the lock. + * It is assumed that no code but this will + * accesses any field until the ->timeout + * callback is called. + */ + p->next = NULL; + p->slot = 0; + (*p->timeout)(p->arg); + } +} + +#if defined(ERTS_TIMER_THREAD) +static void timer_thread_bump_timer(void) +{ + tiw_write_lock(); + bump_timer_internal(do_time_reset()); +} +#else +void bump_timer(long dt) /* dt is value from do_time */ +{ + tiw_write_lock(); + bump_timer_internal(dt); +} +#endif + +Uint +erts_timer_wheel_memory_size(void) +{ + return (Uint) TIW_SIZE * sizeof(ErlTimer*); +} + +#if defined(ERTS_TIMER_THREAD) +static struct erts_iwait *timer_thread_iwait; + +static int timer_thread_setup_delay(SysTimeval *rem_time) +{ + long elapsed; + int ticks; + + tiw_write_lock(); + elapsed = do_time_update(); + ticks = next_time_internal(); + if (ticks == -1) /* timer queue empty */ + ticks = 100*1000*1000; + if (elapsed > ticks) + elapsed = ticks; + ticks -= elapsed; + //ticks *= CLOCK_RESOLUTION; + rem_time->tv_sec = ticks / 1000; + rem_time->tv_usec = 1000 * (ticks % 1000); + ticks_end = ticks; + tiw_write_unlock(); + return ticks; +} + +static void *timer_thread_start(void *ignore) +{ + SysTimeval delay; + +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_set_thread_name("timer"); +#endif + erts_register_blockable_thread(); + + for(;;) { + if (timer_thread_setup_delay(&delay)) { + erts_smp_activity_begin(ERTS_ACTIVITY_WAIT, NULL, NULL, NULL); + ASSERT_NO_LOCKED_LOCKS; + erts_iwait_wait(timer_thread_iwait, &delay); + ASSERT_NO_LOCKED_LOCKS; + erts_smp_activity_end(ERTS_ACTIVITY_WAIT, NULL, NULL, NULL); + } + else + erts_smp_chk_system_block(NULL, NULL, NULL); + timer_thread_bump_timer(); + ASSERT_NO_LOCKED_LOCKS; + } + /*NOTREACHED*/ + return NULL; +} + +static ERTS_INLINE void timer_thread_post_insert(Uint ticks) +{ + if ((Sint)ticks < ticks_end) + erts_iwait_interrupt(timer_thread_iwait); +} + +static void timer_thread_init(void) +{ + erts_thr_opts_t opts = ERTS_THR_OPTS_DEFAULT_INITER; + erts_tid_t tid; + + opts->detached = 1; + + timer_thread_iwait = erts_iwait_init(); + erts_thr_create(&tid, timer_thread_start, NULL, &opts); +} + +#else +static ERTS_INLINE void timer_thread_post_insert(Uint ticks) { } +static ERTS_INLINE void timer_thread_init(void) { } +#endif + +/* this routine links the time cells into a free list at the start + and sets the time queue as empty */ +void +init_time(void) +{ + int i; + + /* system dependent init; must be done before do_time_init() + if timer thread is enabled */ + itime = erts_init_time_sup(); + + tiw_init_lock(); + + tiw = (ErlTimer**) erts_alloc(ERTS_ALC_T_TIMER_WHEEL, + TIW_SIZE * sizeof(ErlTimer*)); + for(i = 0; i < TIW_SIZE; i++) + tiw[i] = NULL; + do_time_init(); + tiw_pos = tiw_nto = 0; + + timer_thread_init(); +} + +/* +** Insert a process into the time queue, with a timeout 't' +*/ +static void +insert_timer(ErlTimer* p, Uint t) +{ + Uint tm; + Uint64 ticks; + + /* The current slot (tiw_pos) in timing wheel is the next slot to be + * be processed. Hence no extra time tick is needed. + * + * (x + y - 1)/y is precisely the "number of bins" formula. + */ + ticks = (t + itime - 1) / itime; + + /* + * Ticks must be a Uint64, or the addition may overflow here, + * resulting in an incorrect value for p->count below. + */ + ticks += do_time_update(); /* Add backlog of unprocessed time */ + + /* calculate slot */ + tm = (ticks + tiw_pos) % TIW_SIZE; + p->slot = (Uint) tm; + p->count = (Uint) (ticks / TIW_SIZE); + + /* insert at head of list at slot */ + p->next = tiw[tm]; + tiw[tm] = p; + tiw_nto++; + + timer_thread_post_insert(ticks); +} + +void +erl_set_timer(ErlTimer* p, ErlTimeoutProc timeout, ErlCancelProc cancel, + void* arg, Uint t) +{ + erts_deliver_time(); + tiw_write_lock(); + if (p->active) { /* XXX assert ? */ + tiw_write_unlock(); + return; + } + p->timeout = timeout; + p->cancel = cancel; + p->arg = arg; + p->active = 1; + insert_timer(p, t); + tiw_write_unlock(); +#if defined(ERTS_SMP) && !defined(ERTS_TIMER_THREAD) + if (t <= (Uint) LONG_MAX) + erts_sys_schedule_interrupt_timed(1, (long) t); +#endif +} + +void +erl_cancel_timer(ErlTimer* p) +{ + ErlTimer *tp; + ErlTimer **prev; + + tiw_write_lock(); + if (!p->active) { /* allow repeated cancel (drivers) */ + tiw_write_unlock(); + return; + } + /* find p in linked list at slot p->slot and remove it */ + prev = &tiw[p->slot]; + while ((tp = *prev) != NULL) { + if (tp == p) { + *prev = p->next; /* Remove from list */ + tiw_nto--; + p->next = NULL; + p->slot = p->count = 0; + p->active = 0; + if (p->cancel != NULL) { + tiw_write_unlock(); + (*p->cancel)(p->arg); + } else { + tiw_write_unlock(); + } + return; + } else { + prev = &tp->next; + } + } + tiw_write_unlock(); +} + +/* + Returns the amount of time left in ms until the timer 'p' is triggered. + 0 is returned if 'p' isn't active. + 0 is returned also if the timer is overdue (i.e., would have triggered + immediately if it hadn't been cancelled). +*/ +Uint +time_left(ErlTimer *p) +{ + Uint left; + long dt; + + tiw_read_lock(); + + if (!p->active) { + tiw_read_unlock(); + return 0; + } + + if (p->slot < tiw_pos) + left = (p->count + 1) * TIW_SIZE + p->slot - tiw_pos; + else + left = p->count * TIW_SIZE + p->slot - tiw_pos; + dt = do_time_read(); + if (left < dt) + left = 0; + else + left -= dt; + + tiw_read_unlock(); + + return left * itime; +} + +#ifdef DEBUG + +void p_slpq() +{ + int i; + ErlTimer* p; + + tiw_read_lock(); + + /* print the whole wheel, starting at the current position */ + erts_printf("\ntiw_pos = %d tiw_nto %d\n", tiw_pos, tiw_nto); + i = tiw_pos; + if (tiw[i] != NULL) { + erts_printf("%d:\n", i); + for(p = tiw[i]; p != NULL; p = p->next) { + erts_printf(" (count %d, slot %d)\n", + p->count, p->slot); + } + } + for(i = (i+1)%TIW_SIZE; i != tiw_pos; i = (i+1)%TIW_SIZE) { + if (tiw[i] != NULL) { + erts_printf("%d:\n", i); + for(p = tiw[i]; p != NULL; p = p->next) { + erts_printf(" (count %d, slot %d)\n", + p->count, p->slot); + } + } + } + + tiw_read_unlock(); +} + +#endif /* DEBUG */ diff --git a/erts/emulator/beam/utils.c b/erts/emulator/beam/utils.c new file mode 100644 index 0000000000..be442fa480 --- /dev/null +++ b/erts/emulator/beam/utils.c @@ -0,0 +1,4053 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#define ERTS_DO_INCL_GLB_INLINE_FUNC_DEF + +#include "sys.h" +#include "erl_vm.h" +#include "global.h" +#include "erl_process.h" +#include "big.h" +#include "bif.h" +#include "erl_binary.h" +#include "erl_bits.h" +#include "packet_parser.h" +#define ERTS_WANT_DB_INTERNAL__ +#include "erl_db.h" +#include "erl_threads.h" +#include "register.h" +#include "dist.h" +#include "erl_printf.h" +#include "erl_threads.h" +#include "erl_smp.h" +#include "erl_time.h" + +#undef M_TRIM_THRESHOLD +#undef M_TOP_PAD +#undef M_MMAP_THRESHOLD +#undef M_MMAP_MAX + +#if !defined(ELIB_ALLOC_IS_CLIB) && defined(__GLIBC__) && defined(HAVE_MALLOC_H) +#include +#endif + +#if defined(ELIB_ALLOC_IS_CLIB) || !defined(HAVE_MALLOPT) +#undef HAVE_MALLOPT +#define HAVE_MALLOPT 0 +#endif + +/* profile_scheduler mini message queue */ + +#ifdef ERTS_TIMER_THREAD +/* A timer thread is not welcomed with this lock violation work around. + * - Björn-Egil + */ +#error Timer thread may not be enabled due to lock violation. +#endif + +typedef struct { + Uint scheduler_id; + Uint no_schedulers; + Uint Ms; + Uint s; + Uint us; + Eterm state; +} profile_sched_msg; + +typedef struct { + profile_sched_msg msg[2]; + Uint n; +} profile_sched_msg_q; + +#ifdef ERTS_SMP + +static void +dispatch_profile_msg_q(profile_sched_msg_q *psmq) +{ + int i = 0; + profile_sched_msg *msg = NULL; + ASSERT(psmq != NULL); + for (i = 0; i < psmq->n; i++) { + msg = &(psmq->msg[i]); + profile_scheduler_q(make_small(msg->scheduler_id), msg->state, am_undefined, msg->Ms, msg->s, msg->us); + } +} + +#endif + +Eterm* +erts_heap_alloc(Process* p, Uint need) +{ + ErlHeapFragment* bp; + Eterm* htop; + Uint n; +#if defined(DEBUG) || defined(CHECK_FOR_HOLES) + Uint i; +#endif + + n = need; +#ifdef DEBUG + n++; +#endif + bp = (ErlHeapFragment*) + ERTS_HEAP_ALLOC(ERTS_ALC_T_HEAP_FRAG, + sizeof(ErlHeapFragment) + ((n-1)*sizeof(Eterm))); + +#ifdef DEBUG + n--; +#endif + +#if defined(DEBUG) + for (i = 0; i <= n; i++) { + bp->mem[i] = ERTS_HOLE_MARKER; + } +#elif defined(CHECK_FOR_HOLES) + for (i = 0; i < n; i++) { + bp->mem[i] = ERTS_HOLE_MARKER; + } +#endif + + /* + * When we have created a heap fragment, we are no longer allowed + * to store anything more on the heap. + */ + htop = HEAP_TOP(p); + if (htop < HEAP_LIMIT(p)) { + *htop = make_pos_bignum_header(HEAP_LIMIT(p)-htop-1); + HEAP_TOP(p) = HEAP_LIMIT(p); + } + + bp->next = MBUF(p); + MBUF(p) = bp; + bp->size = n; + MBUF_SIZE(p) += n; + bp->off_heap.mso = NULL; +#ifndef HYBRID /* FIND ME! */ + bp->off_heap.funs = NULL; +#endif + bp->off_heap.externals = NULL; + bp->off_heap.overhead = 0; + + return bp->mem; +} + +void erts_arith_shrink(Process* p, Eterm* hp) +{ +#if defined(CHECK_FOR_HOLES) + ErlHeapFragment* hf; + + /* + * We must find the heap fragment that hp points into. + * If we are unlucky, we might have to search through + * a large part of the list. We'll hope that will not + * happen too often. + */ + for (hf = MBUF(p); hf != 0; hf = hf->next) { + if (hp - hf->mem < (unsigned long)hf->size) { + /* + * We are not allowed to changed hf->size (because the + * size must be correct when deallocating). Therefore, + * clear out the uninitialized part of the heap fragment. + */ + Eterm* to = hf->mem + hf->size; + while (hp < to) { + *hp++ = NIL; + } + break; + } + } +#endif +} + +#ifdef CHECK_FOR_HOLES +Eterm* +erts_set_hole_marker(Eterm* ptr, Uint sz) +{ + Eterm* p = ptr; + int i; + + for (i = 0; i < sz; i++) { + *p++ = ERTS_HOLE_MARKER; + } + return ptr; +} +#endif + +/* + * Helper function for the ESTACK macros defined in global.h. + */ +void +erl_grow_stack(Eterm** start, Eterm** sp, Eterm** end) +{ + Uint old_size = (*end - *start); + Uint new_size = old_size * 2; + Uint sp_offs = *sp - *start; + if (new_size > 2 * DEF_ESTACK_SIZE) { + *start = erts_realloc(ERTS_ALC_T_ESTACK, (void *) *start, new_size*sizeof(Eterm)); + } else { + Eterm* new_ptr = erts_alloc(ERTS_ALC_T_ESTACK, new_size*sizeof(Eterm)); + sys_memcpy(new_ptr, *start, old_size*sizeof(Eterm)); + *start = new_ptr; + } + *end = *start + new_size; + *sp = *start + sp_offs; +} + +/* CTYPE macros */ + +#define LATIN1 + +#define IS_DIGIT(c) ((c) >= '0' && (c) <= '9') +#ifdef LATIN1 +#define IS_LOWER(c) (((c) >= 'a' && (c) <= 'z') \ + || ((c) >= 128+95 && (c) <= 255 && (c) != 247)) +#define IS_UPPER(c) (((c) >= 'A' && (c) <= 'Z') \ + || ((c) >= 128+64 && (c) <= 128+94 && (c) != 247-32)) +#else +#define IS_LOWER(c) ((c) >= 'a' && (c) <= 'z') +#define IS_UPPER(c) ((c) >= 'A' && (c) <= 'Z') +#endif + +#define IS_ALNUM(c) (IS_DIGIT(c) || IS_LOWER(c) || IS_UPPER(c)) + +/* We don't include 160 (non-breaking space). */ +#define IS_SPACE(c) (c == ' ' || c == '\n' || c == '\t' || c == '\r') + +#ifdef LATIN1 +#define IS_CNTRL(c) ((c) < ' ' || (c) == 127 \ + || ((c) >= 128 && (c) < 128+32)) +#else +/* Treat all non-ASCII as control characters */ +#define IS_CNTRL(c) ((c) < ' ' || (c) >= 127) +#endif + +#define IS_PRINT(c) (!IS_CNTRL(c)) + +/* + * Calculate length of a list. + * Returns -1 if not a proper list (i.e. not terminated with NIL) + */ +int +list_length(Eterm list) +{ + int i = 0; + + while(is_list(list)) { + i++; + list = CDR(list_val(list)); + } + if (is_not_nil(list)) { + return -1; + } + return i; +} + +Uint erts_fit_in_bits(Uint n) +{ + Uint i; + + i = 0; + while (n > 0) { + i++; + n >>= 1; + } + return i; +} + +int +erts_print(int to, void *arg, char *format, ...) +{ + int res; + va_list arg_list; + va_start(arg_list, format); + + if (to < ERTS_PRINT_MIN) + res = -EINVAL; + else { + switch (to) { + case ERTS_PRINT_STDOUT: + res = erts_vprintf(format, arg_list); + break; + case ERTS_PRINT_STDERR: + res = erts_vfprintf(stderr, format, arg_list); + break; + case ERTS_PRINT_FILE: + res = erts_vfprintf((FILE *) arg, format, arg_list); + break; + case ERTS_PRINT_SBUF: + res = erts_vsprintf((char *) arg, format, arg_list); + break; + case ERTS_PRINT_SNBUF: + res = erts_vsnprintf(((erts_print_sn_buf *) arg)->buf, + ((erts_print_sn_buf *) arg)->size, + format, + arg_list); + break; + case ERTS_PRINT_DSBUF: + res = erts_vdsprintf((erts_dsprintf_buf_t *) arg, format, arg_list); + break; + case ERTS_PRINT_INVALID: + res = -EINVAL; + break; + default: + res = erts_vfdprintf((int) to, format, arg_list); + break; + } + } + + va_end(arg_list); + return res; +} + +int +erts_putc(int to, void *arg, char c) +{ + return erts_print(to, arg, "%c", c); +} + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *\ + * Some Erlang term building utility functions (to be used when performance * + * isn't critical). * + * * + * Add more functions like these here (and function prototypes in global.h) * + * when needed. * + * * +\* */ + +Eterm +erts_bld_atom(Uint **hpp, Uint *szp, char *str) +{ + if (hpp) + return am_atom_put(str, sys_strlen(str)); + else + return THE_NON_VALUE; +} + +Eterm +erts_bld_uint(Uint **hpp, Uint *szp, Uint ui) +{ + Eterm res = THE_NON_VALUE; + if (IS_USMALL(0, ui)) { + if (hpp) + res = make_small(ui); + } + else { + if (szp) + *szp += BIG_UINT_HEAP_SIZE; + if (hpp) { + res = uint_to_big(ui, *hpp); + *hpp += BIG_UINT_HEAP_SIZE; + } + } + return res; +} + +Eterm +erts_bld_uint64(Uint **hpp, Uint *szp, Uint64 ui64) +{ + Eterm res = THE_NON_VALUE; + if (IS_USMALL(0, ui64)) { + if (hpp) + res = make_small((Uint) ui64); + } + else { + if (szp) + *szp = ERTS_UINT64_HEAP_SIZE(ui64); + if (hpp) + res = erts_uint64_to_big(ui64, hpp); + } + return res; +} + +Eterm +erts_bld_sint64(Uint **hpp, Uint *szp, Sint64 si64) +{ + Eterm res = THE_NON_VALUE; + if (IS_SSMALL(si64)) { + if (hpp) + res = make_small((Sint) si64); + } + else { + if (szp) + *szp = ERTS_SINT64_HEAP_SIZE(si64); + if (hpp) + res = erts_sint64_to_big(si64, hpp); + } + return res; +} + + +Eterm +erts_bld_cons(Uint **hpp, Uint *szp, Eterm car, Eterm cdr) +{ + Eterm res = THE_NON_VALUE; + if (szp) + *szp += 2; + if (hpp) { + res = CONS(*hpp, car, cdr); + *hpp += 2; + } + return res; +} + +Eterm +erts_bld_tuple(Uint **hpp, Uint *szp, Uint arity, ...) +{ + Eterm res = THE_NON_VALUE; + + ASSERT(arity < (((Uint)1) << (sizeof(Uint)*8 - _HEADER_ARITY_OFFS))); + + if (szp) + *szp += arity + 1; + if (hpp) { + res = make_tuple(*hpp); + *((*hpp)++) = make_arityval(arity); + + if (arity > 0) { + Uint i; + va_list argp; + + va_start(argp, arity); + for (i = 0; i < arity; i++) { + *((*hpp)++) = va_arg(argp, Eterm); + } + va_end(argp); + } + } + return res; +} + + +Eterm erts_bld_tuplev(Uint **hpp, Uint *szp, Uint arity, Eterm terms[]) +{ + Eterm res = THE_NON_VALUE; + /* + * Note callers expect that 'terms' is *not* accessed if hpp == NULL. + */ + + ASSERT(arity < (((Uint)1) << (sizeof(Uint)*8 - _HEADER_ARITY_OFFS))); + + if (szp) + *szp += arity + 1; + if (hpp) { + + res = make_tuple(*hpp); + *((*hpp)++) = make_arityval(arity); + + if (arity > 0) { + Uint i; + for (i = 0; i < arity; i++) + *((*hpp)++) = terms[i]; + } + } + return res; +} + +Eterm +erts_bld_string_n(Uint **hpp, Uint *szp, const char *str, Sint len) +{ + Eterm res = THE_NON_VALUE; + Sint i = len; + if (szp) + *szp += len*2; + if (hpp) { + res = NIL; + while (--i >= 0) { + res = CONS(*hpp, make_small(str[i]), res); + *hpp += 2; + } + } + return res; +} + +Eterm +erts_bld_list(Uint **hpp, Uint *szp, Sint length, Eterm terms[]) +{ + Eterm list = THE_NON_VALUE; + if (szp) + *szp += 2*length; + if (hpp) { + Sint i = length; + list = NIL; + + while (--i >= 0) { + list = CONS(*hpp, terms[i], list); + *hpp += 2; + } + } + return list; +} + +Eterm +erts_bld_2tup_list(Uint **hpp, Uint *szp, + Sint length, Eterm terms1[], Uint terms2[]) +{ + Eterm res = THE_NON_VALUE; + if (szp) + *szp += 5*length; + if (hpp) { + Sint i = length; + res = NIL; + + while (--i >= 0) { + res = CONS(*hpp+3, TUPLE2(*hpp, terms1[i], terms2[i]), res); + *hpp += 5; + } + } + return res; +} + +Eterm +erts_bld_atom_uint_2tup_list(Uint **hpp, Uint *szp, + Sint length, Eterm atoms[], Uint uints[]) +{ + Sint i; + Eterm res = THE_NON_VALUE; + if (szp) { + *szp += 5*length; + i = length; + while (--i >= 0) { + if (!IS_USMALL(0, uints[i])) + *szp += BIG_UINT_HEAP_SIZE; + } + } + if (hpp) { + i = length; + res = NIL; + + while (--i >= 0) { + Eterm ui; + + if (IS_USMALL(0, uints[i])) + ui = make_small(uints[i]); + else { + ui = uint_to_big(uints[i], *hpp); + *hpp += BIG_UINT_HEAP_SIZE; + } + + res = CONS(*hpp+3, TUPLE2(*hpp, atoms[i], ui), res); + *hpp += 5; + } + } + return res; +} + +Eterm +erts_bld_atom_2uint_3tup_list(Uint **hpp, Uint *szp, Sint length, + Eterm atoms[], Uint uints1[], Uint uints2[]) +{ + Sint i; + Eterm res = THE_NON_VALUE; + if (szp) { + *szp += 6*length; + i = length; + while (--i >= 0) { + if (!IS_USMALL(0, uints1[i])) + *szp += BIG_UINT_HEAP_SIZE; + if (!IS_USMALL(0, uints2[i])) + *szp += BIG_UINT_HEAP_SIZE; + } + } + if (hpp) { + i = length; + res = NIL; + + while (--i >= 0) { + Eterm ui1; + Eterm ui2; + + if (IS_USMALL(0, uints1[i])) + ui1 = make_small(uints1[i]); + else { + ui1 = uint_to_big(uints1[i], *hpp); + *hpp += BIG_UINT_HEAP_SIZE; + } + + if (IS_USMALL(0, uints2[i])) + ui2 = make_small(uints2[i]); + else { + ui2 = uint_to_big(uints2[i], *hpp); + *hpp += BIG_UINT_HEAP_SIZE; + } + + res = CONS(*hpp+4, TUPLE3(*hpp, atoms[i], ui1, ui2), res); + *hpp += 6; + } + } + return res; +} + +/* *\ + * * +\* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +/* make a hash index from an erlang term */ + +/* +** There are three hash functions. +** make_broken_hash: the one used for backward compatibility +** is called from the bif erlang:hash/2. Should never be used +** as it a) hashes only a part of binaries, b) hashes bignums really poorly, +** c) hashes bignums differently on different endian processors and d) hashes +** small integers with different weights on different bytes. +** +** make_hash: A hash function that will give the same values for the same +** terms regardless of the internal representation. Small integers are +** hashed using the same algorithm as bignums and bignums are hashed +** independent of the CPU endianess. +** Make_hash also hashes pids, ports and references like 32 bit numbers +** (but with different constants). +** make_hash() is called from the bif erlang:phash/2 +** +** The idea behind the hash algorithm is to produce values suitable for +** linear dynamic hashing. We cannot choose the range at all while hashing +** (it's not even supplied to the hashing functions). The good old algorithm +** [H = H*C+X mod M, where H is the hash value, C is a "random" constant(or M), +** M is the range, preferably a prime, and X is each byte value] is therefore +** modified to: +** H = H*C+X mod 2^32, where C is a large prime. This gives acceptable +** "spreading" of the hashes, so that later modulo calculations also will give +** acceptable "spreading" in the range. +** We really need to hash on bytes, otherwise the +** upper bytes of a word will be less significant than the lower ones. That's +** not acceptable at all. For internal use one could maybe optimize by using +** another hash function, that is less strict but faster. That is, however, not +** implemented. +** +** Short semi-formal description of make_hash: +** +** In make_hash, the number N is treated like this: +** Abs(N) is hashed bytewise with the least significant byte, B(0), first. +** The number of bytes (J) to calculate hash on in N is +** (the number of _32_ bit words needed to store the unsigned +** value of abs(N)) * 4. +** X = FUNNY_NUMBER2 +** If N < 0, Y = FUNNY_NUMBER4 else Y = FUNNY_NUMBER3. +** The hash value is Y*h(J) mod 2^32 where h(J) is calculated like +** h(0) = +** h(i) = h(i-i)*X + B(i-1) +** The above should hold regardless of internal representation. +** Pids are hashed like small numbers but with differrent constants, as are +** ports. +** References are hashed like ports but only on the least significant byte. +** Binaries are hashed on all bytes (not on the 15 first as in +** make_broken_hash()). +** Bytes in lists (possibly text strings) use a simpler multiplication inlined +** in the handling of lists, that is an optimization. +** Everything else is like in the old hash (make_broken_hash()). +** +** make_hash2() is faster than make_hash, in particular for bignums +** and binaries, and produces better hash values. +*/ + +/* some prime numbers just above 2 ^ 28 */ + +#define FUNNY_NUMBER1 268440163 +#define FUNNY_NUMBER2 268439161 +#define FUNNY_NUMBER3 268435459 +#define FUNNY_NUMBER4 268436141 +#define FUNNY_NUMBER5 268438633 +#define FUNNY_NUMBER6 268437017 +#define FUNNY_NUMBER7 268438039 +#define FUNNY_NUMBER8 268437511 +#define FUNNY_NUMBER9 268439627 +#define FUNNY_NUMBER10 268440479 +#define FUNNY_NUMBER11 268440577 +#define FUNNY_NUMBER12 268440581 + +static Uint32 +hash_binary_bytes(Eterm bin, Uint sz, Uint32 hash) +{ + byte* ptr; + Uint bitoffs; + Uint bitsize; + + ERTS_GET_BINARY_BYTES(bin, ptr, bitoffs, bitsize); + if (bitoffs == 0) { + while (sz--) { + hash = hash*FUNNY_NUMBER1 + *ptr++; + } + if (bitsize > 0) { + byte b = *ptr; + + b >>= 8 - bitsize; + hash = (hash*FUNNY_NUMBER1 + b) * FUNNY_NUMBER12 + bitsize; + } + } else { + Uint previous = *ptr++; + Uint b; + Uint lshift = bitoffs; + Uint rshift = 8 - lshift; + + while (sz--) { + b = (previous << lshift) & 0xFF; + previous = *ptr++; + b |= previous >> rshift; + hash = hash*FUNNY_NUMBER1 + b; + } + if (bitsize > 0) { + b = (previous << lshift) & 0xFF; + previous = *ptr++; + b |= previous >> rshift; + + b >>= 8 - bitsize; + hash = (hash*FUNNY_NUMBER1 + b) * FUNNY_NUMBER12 + bitsize; + } + } + return hash; +} + +Uint32 make_hash(Eterm term_arg) +{ + DECLARE_ESTACK(stack); + Eterm term = term_arg; + Eterm hash = 0; + unsigned op; + + /* Must not collide with the real tag_val_def's: */ +#define MAKE_HASH_TUPLE_OP 0x10 +#define MAKE_HASH_FUN_OP 0x11 +#define MAKE_HASH_CDR_PRE_OP 0x12 +#define MAKE_HASH_CDR_POST_OP 0x13 + + /* + ** Convenience macro for calculating a bytewise hash on an unsigned 32 bit + ** integer. + ** If the endianess is known, we could be smarter here, + ** but that gives no significant speedup (on a sparc at least) + */ +#define UINT32_HASH_STEP(Expr, Prime1) \ + do { \ + Uint32 x = (Uint32) (Expr); \ + hash = \ + (((((hash)*(Prime1) + (x & 0xFF)) * (Prime1) + \ + ((x >> 8) & 0xFF)) * (Prime1) + \ + ((x >> 16) & 0xFF)) * (Prime1) + \ + (x >> 24)); \ + } while(0) + +#define UINT32_HASH_RET(Expr, Prime1, Prime2) \ + UINT32_HASH_STEP(Expr, Prime1); \ + hash = hash * (Prime2); \ + break + + + /* + * Significant additions needed for real 64 bit port with larger fixnums. + */ + + /* + * Note, for the simple 64bit port, not utilizing the + * larger word size this function will work without modification. + */ +tail_recur: + op = tag_val_def(term); + + for (;;) { + switch (op) { + case NIL_DEF: + hash = hash*FUNNY_NUMBER3 + 1; + break; + case ATOM_DEF: + hash = hash*FUNNY_NUMBER1 + + (atom_tab(atom_val(term))->slot.bucket.hvalue); + break; + case SMALL_DEF: + { + Sint y1 = signed_val(term); + Uint y2 = y1 < 0 ? -(Uint)y1 : y1; + + UINT32_HASH_STEP(y2, FUNNY_NUMBER2); +#ifdef ARCH_64 + if (y2 >> 32) + UINT32_HASH_STEP(y2 >> 32, FUNNY_NUMBER2); +#endif + hash *= (y1 < 0 ? FUNNY_NUMBER4 : FUNNY_NUMBER3); + break; + } + case BINARY_DEF: + { + Uint sz = binary_size(term); + + hash = hash_binary_bytes(term, sz, hash); + hash = hash*FUNNY_NUMBER4 + sz; + break; + } + case EXPORT_DEF: + { + Export* ep = (Export *) (export_val(term))[1]; + + hash = hash * FUNNY_NUMBER11 + ep->code[2]; + hash = hash*FUNNY_NUMBER1 + + (atom_tab(atom_val(ep->code[0]))->slot.bucket.hvalue); + hash = hash*FUNNY_NUMBER1 + + (atom_tab(atom_val(ep->code[1]))->slot.bucket.hvalue); + break; + } + + case FUN_DEF: + { + ErlFunThing* funp = (ErlFunThing *) fun_val(term); + Uint num_free = funp->num_free; + + hash = hash * FUNNY_NUMBER10 + num_free; + hash = hash*FUNNY_NUMBER1 + + (atom_tab(atom_val(funp->fe->module))->slot.bucket.hvalue); + hash = hash*FUNNY_NUMBER2 + funp->fe->old_index; + hash = hash*FUNNY_NUMBER2 + funp->fe->old_uniq; + if (num_free > 0) { + if (num_free > 1) { + ESTACK_PUSH3(stack, (Eterm) &funp->env[1], (num_free-1), MAKE_HASH_FUN_OP); + } + term = funp->env[0]; + goto tail_recur; + } + break; + } + case PID_DEF: + UINT32_HASH_RET(internal_pid_number(term),FUNNY_NUMBER5,FUNNY_NUMBER6); + case EXTERNAL_PID_DEF: + UINT32_HASH_RET(external_pid_number(term),FUNNY_NUMBER5,FUNNY_NUMBER6); + case PORT_DEF: + UINT32_HASH_RET(internal_port_number(term),FUNNY_NUMBER9,FUNNY_NUMBER10); + case EXTERNAL_PORT_DEF: + UINT32_HASH_RET(external_port_number(term),FUNNY_NUMBER9,FUNNY_NUMBER10); + case REF_DEF: + UINT32_HASH_RET(internal_ref_numbers(term)[0],FUNNY_NUMBER9,FUNNY_NUMBER10); + case EXTERNAL_REF_DEF: + UINT32_HASH_RET(external_ref_numbers(term)[0],FUNNY_NUMBER9,FUNNY_NUMBER10); + case FLOAT_DEF: + { + FloatDef ff; + GET_DOUBLE(term, ff); + hash = hash*FUNNY_NUMBER6 + (ff.fw[0] ^ ff.fw[1]); + break; + } + + case MAKE_HASH_CDR_PRE_OP: + term = ESTACK_POP(stack); + if (is_not_list(term)) { + ESTACK_PUSH(stack, MAKE_HASH_CDR_POST_OP); + goto tail_recur; + } + /* fall through */ + case LIST_DEF: + { + Eterm* list = list_val(term); + while(is_byte(*list)) { + /* Optimization for strings. + ** Note that this hash is different from a 'small' hash, + ** as multiplications on a Sparc is so slow. + */ + hash = hash*FUNNY_NUMBER2 + unsigned_val(*list); + + if (is_not_list(CDR(list))) { + ESTACK_PUSH(stack, MAKE_HASH_CDR_POST_OP); + term = CDR(list); + goto tail_recur; + } + list = list_val(CDR(list)); + } + ESTACK_PUSH2(stack, CDR(list), MAKE_HASH_CDR_PRE_OP); + term = CAR(list); + goto tail_recur; + } + case MAKE_HASH_CDR_POST_OP: + hash *= FUNNY_NUMBER8; + break; + + case BIG_DEF: + /* Note that this is the exact same thing as the hashing of smalls.*/ + { + Eterm* ptr = big_val(term); + Uint n = BIG_SIZE(ptr); + Uint k = n-1; + ErtsDigit d; + int is_neg = BIG_SIGN(ptr); + Uint i; + int j; + + for (i = 0; i < k; i++) { + d = BIG_DIGIT(ptr, i); + for(j = 0; j < sizeof(ErtsDigit); ++j) { + hash = (hash*FUNNY_NUMBER2) + (d & 0xff); + d >>= 8; + } + } + d = BIG_DIGIT(ptr, k); + k = sizeof(ErtsDigit); +#ifdef ARCH_64 + if (!(d >> 32)) + k /= 2; +#endif + for(j = 0; j < (int)k; ++j) { + hash = (hash*FUNNY_NUMBER2) + (d & 0xff); + d >>= 8; + } + hash *= is_neg ? FUNNY_NUMBER4 : FUNNY_NUMBER3; + break; + } + case TUPLE_DEF: + { + Eterm* ptr = tuple_val(term); + Uint arity = arityval(*ptr); + + ESTACK_PUSH3(stack, arity, (Eterm)(ptr+1), arity); + op = MAKE_HASH_TUPLE_OP; + }/*fall through*/ + case MAKE_HASH_TUPLE_OP: + case MAKE_HASH_FUN_OP: + { + Uint i = ESTACK_POP(stack); + Eterm* ptr = (Eterm*) ESTACK_POP(stack); + if (i != 0) { + term = *ptr; + ESTACK_PUSH3(stack, (Eterm)(ptr+1), i-1, op); + goto tail_recur; + } + if (op == MAKE_HASH_TUPLE_OP) { + Uint32 arity = ESTACK_POP(stack); + hash = hash*FUNNY_NUMBER9 + arity; + } + break; + } + + default: + erl_exit(1, "Invalid tag in make_hash(0x%X,0x%X)\n", term, op); + return 0; + } + if (ESTACK_ISEMPTY(stack)) break; + op = ESTACK_POP(stack); + } + DESTROY_ESTACK(stack); + return hash; + +#undef UINT32_HASH_STEP +#undef UINT32_HASH_RET +} + + + +/* Hash function suggested by Bob Jenkins. */ + +#define MIX(a,b,c) \ +do { \ + a -= b; a -= c; a ^= (c>>13); \ + b -= c; b -= a; b ^= (a<<8); \ + c -= a; c -= b; c ^= (b>>13); \ + a -= b; a -= c; a ^= (c>>12); \ + b -= c; b -= a; b ^= (a<<16); \ + c -= a; c -= b; c ^= (b>>5); \ + a -= b; a -= c; a ^= (c>>3); \ + b -= c; b -= a; b ^= (a<<10); \ + c -= a; c -= b; c ^= (b>>15); \ +} while(0) + +#define HCONST 0x9e3779b9UL /* the golden ratio; an arbitrary value */ + +Uint32 +block_hash(byte *k, unsigned length, Uint32 initval) +{ + Uint32 a,b,c; + unsigned len; + + /* Set up the internal state */ + len = length; + a = b = HCONST; + c = initval; /* the previous hash value */ + + while (len >= 12) + { + a += (k[0] +((Uint32)k[1]<<8) +((Uint32)k[2]<<16) +((Uint32)k[3]<<24)); + b += (k[4] +((Uint32)k[5]<<8) +((Uint32)k[6]<<16) +((Uint32)k[7]<<24)); + c += (k[8] +((Uint32)k[9]<<8) +((Uint32)k[10]<<16)+((Uint32)k[11]<<24)); + MIX(a,b,c); + k += 12; len -= 12; + } + + c += length; + switch(len) /* all the case statements fall through */ + { + case 11: c+=((Uint32)k[10]<<24); + case 10: c+=((Uint32)k[9]<<16); + case 9 : c+=((Uint32)k[8]<<8); + /* the first byte of c is reserved for the length */ + case 8 : b+=((Uint32)k[7]<<24); + case 7 : b+=((Uint32)k[6]<<16); + case 6 : b+=((Uint32)k[5]<<8); + case 5 : b+=k[4]; + case 4 : a+=((Uint32)k[3]<<24); + case 3 : a+=((Uint32)k[2]<<16); + case 2 : a+=((Uint32)k[1]<<8); + case 1 : a+=k[0]; + /* case 0: nothing left to add */ + } + MIX(a,b,c); + return c; +} + +Uint32 +make_hash2(Eterm term) +{ + Uint32 hash; + Eterm tmp_big[2]; + +/* (HCONST * {2, ..., 14}) mod 2^32 */ +#define HCONST_2 0x3c6ef372UL +#define HCONST_3 0xdaa66d2bUL +#define HCONST_4 0x78dde6e4UL +#define HCONST_5 0x1715609dUL +#define HCONST_6 0xb54cda56UL +#define HCONST_7 0x5384540fUL +#define HCONST_8 0xf1bbcdc8UL +#define HCONST_9 0x8ff34781UL +#define HCONST_10 0x2e2ac13aUL +#define HCONST_11 0xcc623af3UL +#define HCONST_12 0x6a99b4acUL +#define HCONST_13 0x08d12e65UL +#define HCONST_14 0xa708a81eUL +#define HCONST_15 0x454021d7UL + +#define UINT32_HASH_2(Expr1, Expr2, AConst) \ + do { \ + Uint32 a,b; \ + a = AConst + (Uint32) (Expr1); \ + b = AConst + (Uint32) (Expr2); \ + MIX(a,b,hash); \ + } while(0) + +#define UINT32_HASH(Expr, AConst) UINT32_HASH_2(Expr, 0, AConst) + +#define SINT32_HASH(Expr, AConst) \ + do { \ + Sint32 y = (Sint32) (Expr); \ + if (y < 0) { \ + UINT32_HASH(-y, AConst); \ + /* Negative numbers are unnecessarily mixed twice. */ \ + } \ + UINT32_HASH(y, AConst); \ + } while(0) + +#define IS_SSMALL28(x) (((Uint) (((x) >> (28-1)) + 1)) < 2) + + /* Optimization. Simple cases before declaration of estack. */ + if (primary_tag(term) == TAG_PRIMARY_IMMED1) { + switch (term & _TAG_IMMED1_MASK) { + case _TAG_IMMED1_IMMED2: + switch (term & _TAG_IMMED2_MASK) { + case _TAG_IMMED2_ATOM: + /* Fast, but the poor hash value should be mixed. */ + return atom_tab(atom_val(term))->slot.bucket.hvalue; + } + break; + case _TAG_IMMED1_SMALL: + { + Sint x = signed_val(term); + + if (SMALL_BITS > 28 && !IS_SSMALL28(x)) { + term = small_to_big(x, tmp_big); + break; + } + hash = 0; + SINT32_HASH(x, HCONST); + return hash; + } + } + }; + { + Eterm tmp; + DECLARE_ESTACK(s); + + hash = 0; + for (;;) { + switch (primary_tag(term)) { + case TAG_PRIMARY_LIST: + { + int c = 0; + Uint32 sh = 0; + Eterm* ptr = list_val(term); + while (is_byte(*ptr)) { + /* Optimization for strings. */ + sh = (sh << 8) + unsigned_val(*ptr); + if (c == 3) { + UINT32_HASH(sh, HCONST_4); + c = sh = 0; + } else { + c++; + } + term = CDR(ptr); + if (is_not_list(term)) + break; + ptr = list_val(term); + } + if (c > 0) + UINT32_HASH(sh, HCONST_4); + if (is_list(term)) { + term = *ptr; + tmp = *++ptr; + ESTACK_PUSH(s, tmp); + } + } + break; + case TAG_PRIMARY_BOXED: + { + Eterm hdr = *boxed_val(term); + ASSERT(is_header(hdr)); + switch (hdr & _TAG_HEADER_MASK) { + case ARITYVAL_SUBTAG: + { + int i; + int arity = header_arity(hdr); + Eterm* elem = tuple_val(term); + UINT32_HASH(arity, HCONST_9); + if (arity == 0) /* Empty tuple */ + goto hash2_common; + for (i = arity; i >= 2; i--) { + tmp = elem[i]; + ESTACK_PUSH(s, tmp); + } + term = elem[1]; + } + break; + case EXPORT_SUBTAG: + { + Export* ep = (Export *) (export_val(term))[1]; + + UINT32_HASH_2 + (ep->code[2], + atom_tab(atom_val(ep->code[0]))->slot.bucket.hvalue, + HCONST); + UINT32_HASH + (atom_tab(atom_val(ep->code[1]))->slot.bucket.hvalue, + HCONST_14); + goto hash2_common; + } + + case FUN_SUBTAG: + { + ErlFunThing* funp = (ErlFunThing *) fun_val(term); + Uint num_free = funp->num_free; + + UINT32_HASH_2 + (num_free, + atom_tab(atom_val(funp->fe->module))->slot.bucket.hvalue, + HCONST); + UINT32_HASH_2 + (funp->fe->old_index, funp->fe->old_uniq, HCONST); + if (num_free == 0) { + goto hash2_common; + } else { + Eterm* bptr = funp->env + num_free - 1; + while (num_free-- > 1) { + term = *bptr--; + ESTACK_PUSH(s, term); + } + term = *bptr; + } + } + break; + case REFC_BINARY_SUBTAG: + case HEAP_BINARY_SUBTAG: + case SUB_BINARY_SUBTAG: + { + byte* bptr; + unsigned sz = binary_size(term); + Uint32 con = HCONST_13 + hash; + Uint bitoffs; + Uint bitsize; + + ERTS_GET_BINARY_BYTES(term, bptr, bitoffs, bitsize); + if (sz == 0 && bitsize == 0) { + hash = con; + } else { + if (bitoffs == 0) { + hash = block_hash(bptr, sz, con); + if (bitsize > 0) { + UINT32_HASH_2(bitsize, (bptr[sz] >> (8 - bitsize)), + HCONST_15); + } + } else { + byte* buf = (byte *) erts_alloc(ERTS_ALC_T_TMP, + sz + (bitsize != 0)); + erts_copy_bits(bptr, bitoffs, 1, buf, 0, 1, sz*8+bitsize); + hash = block_hash(buf, sz, con); + if (bitsize > 0) { + UINT32_HASH_2(bitsize, (buf[sz] >> (8 - bitsize)), + HCONST_15); + } + erts_free(ERTS_ALC_T_TMP, (void *) buf); + } + } + goto hash2_common; + } + break; + case POS_BIG_SUBTAG: + case NEG_BIG_SUBTAG: + { + Eterm* ptr = big_val(term); + Uint i = 0; + Uint n = BIG_SIZE(ptr); + Uint32 con = BIG_SIGN(ptr) ? HCONST_10 : HCONST_11; +#if D_EXP == 16 + do { + Uint32 x, y; + x = i < n ? BIG_DIGIT(ptr, i++) : 0; + x += (Uint32)(i < n ? BIG_DIGIT(ptr, i++) : 0) << 16; + y = i < n ? BIG_DIGIT(ptr, i++) : 0; + y += (Uint32)(i < n ? BIG_DIGIT(ptr, i++) : 0) << 16; + UINT32_HASH_2(x, y, con); + } while (i < n); +#elif D_EXP == 32 + do { + Uint32 x, y; + x = i < n ? BIG_DIGIT(ptr, i++) : 0; + y = i < n ? BIG_DIGIT(ptr, i++) : 0; + UINT32_HASH_2(x, y, con); + } while (i < n); +#elif D_EXP == 64 + do { + Uint t; + Uint32 x, y; + t = i < n ? BIG_DIGIT(ptr, i++) : 0; + x = t & 0xffffffff; + y = t >> 32; + UINT32_HASH_2(x, y, con); + } while (i < n); +#else +#error "unsupported D_EXP size" +#endif + goto hash2_common; + } + break; + case REF_SUBTAG: + /* All parts of the ref should be hashed. */ + UINT32_HASH(internal_ref_numbers(term)[0], HCONST_7); + goto hash2_common; + break; + case EXTERNAL_REF_SUBTAG: + /* All parts of the ref should be hashed. */ + UINT32_HASH(external_ref_numbers(term)[0], HCONST_7); + goto hash2_common; + break; + case EXTERNAL_PID_SUBTAG: + /* Only 15 bits are hashed. */ + UINT32_HASH(external_pid_number(term), HCONST_5); + goto hash2_common; + case EXTERNAL_PORT_SUBTAG: + /* Only 15 bits are hashed. */ + UINT32_HASH(external_port_number(term), HCONST_6); + goto hash2_common; + case FLOAT_SUBTAG: + { + FloatDef ff; + GET_DOUBLE(term, ff); +#if defined(WORDS_BIGENDIAN) + UINT32_HASH_2(ff.fw[0], ff.fw[1], HCONST_12); +#else + UINT32_HASH_2(ff.fw[1], ff.fw[0], HCONST_12); +#endif + goto hash2_common; + } + break; + + default: + erl_exit(1, "Invalid tag in make_hash2(0x%X)\n", term); + } + } + break; + case TAG_PRIMARY_IMMED1: + switch (term & _TAG_IMMED1_MASK) { + case _TAG_IMMED1_PID: + /* Only 15 bits are hashed. */ + UINT32_HASH(internal_pid_number(term), HCONST_5); + goto hash2_common; + case _TAG_IMMED1_PORT: + /* Only 15 bits are hashed. */ + UINT32_HASH(internal_port_number(term), HCONST_6); + goto hash2_common; + case _TAG_IMMED1_IMMED2: + switch (term & _TAG_IMMED2_MASK) { + case _TAG_IMMED2_ATOM: + if (hash == 0) + /* Fast, but the poor hash value should be mixed. */ + hash = atom_tab(atom_val(term))->slot.bucket.hvalue; + else + UINT32_HASH(atom_tab(atom_val(term))->slot.bucket.hvalue, + HCONST_3); + goto hash2_common; + case _TAG_IMMED2_NIL: + if (hash == 0) + hash = 3468870702UL; + else + UINT32_HASH(NIL_DEF, HCONST_2); + goto hash2_common; + default: + erl_exit(1, "Invalid tag in make_hash2(0x%X)\n", term); + } + case _TAG_IMMED1_SMALL: + { + Sint x = signed_val(term); + + if (SMALL_BITS > 28 && !IS_SSMALL28(x)) { + term = small_to_big(x, tmp_big); + break; + } + SINT32_HASH(x, HCONST); + goto hash2_common; + } + } + break; + default: + erl_exit(1, "Invalid tag in make_hash2(0x%X)\n", term); + hash2_common: + if (ESTACK_ISEMPTY(s)) { + DESTROY_ESTACK(s); + return hash; + } + term = ESTACK_POP(s); + } + } + } +#undef UINT32_HASH_2 +#undef UINT32_HASH +#undef SINT32_HASH +} + +#undef HCONST +#undef MIX + + +Uint32 make_broken_hash(Eterm term) +{ + Uint32 hash = 0; + DECLARE_ESTACK(stack); + unsigned op; +tail_recur: + op = tag_val_def(term); + for (;;) { + switch (op) { + case NIL_DEF: + hash = hash*FUNNY_NUMBER3 + 1; + break; + case ATOM_DEF: + hash = hash*FUNNY_NUMBER1 + + (atom_tab(atom_val(term))->slot.bucket.hvalue); + break; + case SMALL_DEF: +#ifdef ARCH_64 + { + Sint y1 = signed_val(term); + Uint y2 = y1 < 0 ? -(Uint)y1 : y1; + Uint32 y3 = (Uint32) (y2 >> 32); + int arity = 1; + +#if defined(WORDS_BIGENDIAN) + if (!IS_SSMALL28(y1)) + { /* like a bignum */ + Uint32 y4 = (Uint32) y2; + hash = hash*FUNNY_NUMBER2 + ((y4 << 16) | (y4 >> 16)); + if (y3) + { + hash = hash*FUNNY_NUMBER2 + ((y3 << 16) | (y3 >> 16)); + arity++; + } + hash = hash * (y1 < 0 ? FUNNY_NUMBER3 : FUNNY_NUMBER2) + arity; + } else { + hash = hash*FUNNY_NUMBER2 + (((Uint) y1) & 0xfffffff); + } +#else + if (!IS_SSMALL28(y1)) + { /* like a bignum */ + hash = hash*FUNNY_NUMBER2 + ((Uint32) y2); + if (y3) + { + hash = hash*FUNNY_NUMBER2 + y3; + arity++; + } + hash = hash * (y1 < 0 ? FUNNY_NUMBER3 : FUNNY_NUMBER2) + arity; + } else { + hash = hash*FUNNY_NUMBER2 + (((Uint) y1) & 0xfffffff); + } +#endif + } +#else + hash = hash*FUNNY_NUMBER2 + unsigned_val(term); +#endif + break; + + case BINARY_DEF: + { + size_t sz = binary_size(term); + size_t i = (sz < 15) ? sz : 15; + + hash = hash_binary_bytes(term, i, hash); + hash = hash*FUNNY_NUMBER4 + sz; + break; + } + + case EXPORT_DEF: + { + Export* ep = (Export *) (export_val(term))[1]; + + hash = hash * FUNNY_NUMBER11 + ep->code[2]; + hash = hash*FUNNY_NUMBER1 + + (atom_tab(atom_val(ep->code[0]))->slot.bucket.hvalue); + hash = hash*FUNNY_NUMBER1 + + (atom_tab(atom_val(ep->code[1]))->slot.bucket.hvalue); + break; + } + + case FUN_DEF: + { + ErlFunThing* funp = (ErlFunThing *) fun_val(term); + Uint num_free = funp->num_free; + + hash = hash * FUNNY_NUMBER10 + num_free; + hash = hash*FUNNY_NUMBER1 + + (atom_tab(atom_val(funp->fe->module))->slot.bucket.hvalue); + hash = hash*FUNNY_NUMBER2 + funp->fe->old_index; + hash = hash*FUNNY_NUMBER2 + funp->fe->old_uniq; + if (num_free > 0) { + if (num_free > 1) { + ESTACK_PUSH3(stack, (Eterm) &funp->env[1], (num_free-1), MAKE_HASH_FUN_OP); + } + term = funp->env[0]; + goto tail_recur; + } + break; + } + + case PID_DEF: + hash = hash*FUNNY_NUMBER5 + internal_pid_number(term); + break; + case EXTERNAL_PID_DEF: + hash = hash*FUNNY_NUMBER5 + external_pid_number(term); + break; + case PORT_DEF: + hash = hash*FUNNY_NUMBER9 + internal_port_number(term); + break; + case EXTERNAL_PORT_DEF: + hash = hash*FUNNY_NUMBER9 + external_port_number(term); + break; + case REF_DEF: + hash = hash*FUNNY_NUMBER9 + internal_ref_numbers(term)[0]; + break; + case EXTERNAL_REF_DEF: + hash = hash*FUNNY_NUMBER9 + external_ref_numbers(term)[0]; + break; + case FLOAT_DEF: + { + FloatDef ff; + GET_DOUBLE(term, ff); + hash = hash*FUNNY_NUMBER6 + (ff.fw[0] ^ ff.fw[1]); + } + break; + + case MAKE_HASH_CDR_PRE_OP: + term = ESTACK_POP(stack); + if (is_not_list(term)) { + ESTACK_PUSH(stack, MAKE_HASH_CDR_POST_OP); + goto tail_recur; + } + /*fall through*/ + case LIST_DEF: + { + Eterm* list = list_val(term); + ESTACK_PUSH2(stack, CDR(list), MAKE_HASH_CDR_PRE_OP); + term = CAR(list); + goto tail_recur; + } + + case MAKE_HASH_CDR_POST_OP: + hash *= FUNNY_NUMBER8; + break; + + case BIG_DEF: + { + Eterm* ptr = big_val(term); + int is_neg = BIG_SIGN(ptr); + Uint arity = BIG_ARITY(ptr); + Uint i = arity; + ptr++; +#if D_EXP == 16 + /* hash over 32 bit LE */ + + while(i--) { + hash = hash*FUNNY_NUMBER2 + *ptr++; + } +#elif D_EXP == 32 + +#if defined(WORDS_BIGENDIAN) + while(i--) { + Uint d = *ptr++; + hash = hash*FUNNY_NUMBER2 + ((d << 16) | (d >> 16)); + } +#else + while(i--) { + hash = hash*FUNNY_NUMBER2 + *ptr++; + } +#endif + +#elif D_EXP == 64 + { + Uint32 h = 0, l; +#if defined(WORDS_BIGENDIAN) + while(i--) { + Uint d = *ptr++; + l = d & 0xffffffff; + h = d >> 32; + hash = hash*FUNNY_NUMBER2 + ((l << 16) | (l >> 16)); + if (h || i) + hash = hash*FUNNY_NUMBER2 + ((h << 16) | (h >> 16)); + } +#else + while(i--) { + Uint d = *ptr++; + l = d & 0xffffffff; + h = d >> 32; + hash = hash*FUNNY_NUMBER2 + l; + if (h || i) + hash = hash*FUNNY_NUMBER2 + h; + } +#endif + /* adjust arity to match 32 bit mode */ + arity = (arity << 1) - (h == 0); + } + +#else +#error "unsupported D_EXP size" +#endif + hash = hash * (is_neg ? FUNNY_NUMBER3 : FUNNY_NUMBER2) + arity; + } + break; + + case TUPLE_DEF: + { + Eterm* ptr = tuple_val(term); + Uint arity = arityval(*ptr); + + ESTACK_PUSH3(stack, arity, (Eterm)(ptr+1), arity); + op = MAKE_HASH_TUPLE_OP; + }/*fall through*/ + case MAKE_HASH_TUPLE_OP: + case MAKE_HASH_FUN_OP: + { + Uint i = ESTACK_POP(stack); + Eterm* ptr = (Eterm*) ESTACK_POP(stack); + if (i != 0) { + term = *ptr; + ESTACK_PUSH3(stack, (Eterm)(ptr+1), i-1, op); + goto tail_recur; + } + if (op == MAKE_HASH_TUPLE_OP) { + Uint32 arity = ESTACK_POP(stack); + hash = hash*FUNNY_NUMBER9 + arity; + } + break; + } + + default: + erl_exit(1, "Invalid tag in make_broken_hash\n"); + return 0; + } + if (ESTACK_ISEMPTY(stack)) break; + op = ESTACK_POP(stack); + } + + DESTROY_ESTACK(stack); + return hash; + +#undef MAKE_HASH_TUPLE_OP +#undef MAKE_HASH_FUN_OP +#undef MAKE_HASH_CDR_PRE_OP +#undef MAKE_HASH_CDR_POST_OP +} + +static int do_send_to_logger(Eterm tag, Eterm gleader, char *buf, int len) +{ + /* error_logger ! + {notify,{info_msg,gleader,{emulator,"~s~n",[]}}} | + {notify,{error,gleader,{emulator,"~s~n",[]}}} | + {notify,{warning_msg,gleader,{emulator,"~s~n",[}]}} */ + Eterm* hp; + Uint sz; + Uint gl_sz; + Eterm gl; + Eterm list,plist,format,tuple1,tuple2,tuple3; + ErlOffHeap *ohp; + ErlHeapFragment *bp = NULL; +#if !defined(ERTS_SMP) + Process *p; +#endif + + ASSERT(is_atom(tag)); + + if (len <= 0) { + return -1; + } + +#ifndef ERTS_SMP + if ( +#ifdef USE_THREADS + !erts_get_scheduler_data() || /* Must be scheduler thread */ +#endif + (p = erts_whereis_process(NULL, 0, am_error_logger, 0, 0)) == NULL + || p->status == P_RUNNING) { + /* buf *always* points to a null terminated string */ + erts_fprintf(stderr, "(no error logger present) %T: \"%s\"\n", + tag, buf); + return 0; + } + /* So we have an error logger, lets build the message */ +#endif + gl_sz = IS_CONST(gleader) ? 0 : size_object(gleader); + sz = len * 2 /* message list */+ 2 /* cons surrounding message list */ + + gl_sz + + 3 /*outer 2-tuple*/ + 4 /* middle 3-tuple */ + 4 /*inner 3-tuple */ + + 8 /* "~s~n" */; + +#ifndef ERTS_SMP + if (sz <= HeapWordsLeft(p)) { + ohp = &MSO(p); + hp = HEAP_TOP(p); + HEAP_TOP(p) += sz; + } else { +#endif + bp = new_message_buffer(sz); + ohp = &bp->off_heap; + hp = bp->mem; +#ifndef ERTS_SMP + } +#endif + gl = (is_nil(gleader) + ? am_noproc + : (IS_CONST(gleader) + ? gleader + : copy_struct(gleader,gl_sz,&hp,ohp))); + list = buf_to_intlist(&hp, buf, len, NIL); + plist = CONS(hp,list,NIL); + hp += 2; + format = buf_to_intlist(&hp, "~s~n", 4, NIL); + tuple1 = TUPLE3(hp, am_emulator, format, plist); + hp += 4; + tuple2 = TUPLE3(hp, tag, gl, tuple1); + hp += 4; + tuple3 = TUPLE2(hp, am_notify, tuple2); +#ifdef HARDDEBUG + erts_fprintf(stderr, "%T\n", tuple3); +#endif +#ifdef ERTS_SMP + { + Eterm from = erts_get_current_pid(); + if (is_not_internal_pid(from)) + from = NIL; + erts_queue_error_logger_message(from, tuple3, bp); + } +#else + erts_queue_message(p, NULL /* only used for smp build */, bp, tuple3, NIL); +#endif + return 0; +} + +static ERTS_INLINE int +send_info_to_logger(Eterm gleader, char *buf, int len) +{ + return do_send_to_logger(am_info_msg, gleader, buf, len); +} + +static ERTS_INLINE int +send_warning_to_logger(Eterm gleader, char *buf, int len) +{ + Eterm tag; + switch (erts_error_logger_warnings) { + case am_info: tag = am_info_msg; break; + case am_warning: tag = am_warning_msg; break; + default: tag = am_error; break; + } + return do_send_to_logger(tag, gleader, buf, len); +} + +static ERTS_INLINE int +send_error_to_logger(Eterm gleader, char *buf, int len) +{ + return do_send_to_logger(am_error, gleader, buf, len); +} + +#define LOGGER_DSBUF_INC_SZ 256 + +static erts_dsprintf_buf_t * +grow_logger_dsbuf(erts_dsprintf_buf_t *dsbufp, size_t need) +{ + size_t size; + size_t free_size = dsbufp->size - dsbufp->str_len; + + ASSERT(dsbufp && dsbufp->str); + + if (need <= free_size) + return dsbufp; + + size = need - free_size + LOGGER_DSBUF_INC_SZ; + size = (((size + LOGGER_DSBUF_INC_SZ - 1) / LOGGER_DSBUF_INC_SZ) + * LOGGER_DSBUF_INC_SZ); + size += dsbufp->size; + ASSERT(dsbufp->str_len + need <= size); + dsbufp->str = (char *) erts_realloc(ERTS_ALC_T_LOGGER_DSBUF, + (void *) dsbufp->str, + size); + dsbufp->size = size; + return dsbufp; +} + +erts_dsprintf_buf_t * +erts_create_logger_dsbuf(void) +{ + erts_dsprintf_buf_t init = ERTS_DSPRINTF_BUF_INITER(grow_logger_dsbuf); + erts_dsprintf_buf_t *dsbufp = erts_alloc(ERTS_ALC_T_LOGGER_DSBUF, + sizeof(erts_dsprintf_buf_t)); + sys_memcpy((void *) dsbufp, (void *) &init, sizeof(erts_dsprintf_buf_t)); + dsbufp->str = (char *) erts_alloc(ERTS_ALC_T_LOGGER_DSBUF, + LOGGER_DSBUF_INC_SZ); + dsbufp->str[0] = '\0'; + dsbufp->size = LOGGER_DSBUF_INC_SZ; + return dsbufp; +} + +static ERTS_INLINE void +destroy_logger_dsbuf(erts_dsprintf_buf_t *dsbufp) +{ + ASSERT(dsbufp && dsbufp->str); + erts_free(ERTS_ALC_T_LOGGER_DSBUF, (void *) dsbufp->str); + erts_free(ERTS_ALC_T_LOGGER_DSBUF, (void *) dsbufp); +} + +int +erts_send_info_to_logger(Eterm gleader, erts_dsprintf_buf_t *dsbufp) +{ + int res; + res = send_info_to_logger(gleader, dsbufp->str, dsbufp->str_len); + destroy_logger_dsbuf(dsbufp); + return res; +} + +int +erts_send_warning_to_logger(Eterm gleader, erts_dsprintf_buf_t *dsbufp) +{ + int res; + res = send_warning_to_logger(gleader, dsbufp->str, dsbufp->str_len); + destroy_logger_dsbuf(dsbufp); + return res; +} + +int +erts_send_error_to_logger(Eterm gleader, erts_dsprintf_buf_t *dsbufp) +{ + int res; + res = send_error_to_logger(gleader, dsbufp->str, dsbufp->str_len); + destroy_logger_dsbuf(dsbufp); + return res; +} + +int +erts_send_info_to_logger_str(Eterm gleader, char *str) +{ + return send_info_to_logger(gleader, str, sys_strlen(str)); +} + +int +erts_send_warning_to_logger_str(Eterm gleader, char *str) +{ + return send_warning_to_logger(gleader, str, sys_strlen(str)); +} + +int +erts_send_error_to_logger_str(Eterm gleader, char *str) +{ + return send_error_to_logger(gleader, str, sys_strlen(str)); +} + +int +erts_send_info_to_logger_nogl(erts_dsprintf_buf_t *dsbuf) +{ + return erts_send_info_to_logger(NIL, dsbuf); +} + +int +erts_send_warning_to_logger_nogl(erts_dsprintf_buf_t *dsbuf) +{ + return erts_send_warning_to_logger(NIL, dsbuf); +} + +int +erts_send_error_to_logger_nogl(erts_dsprintf_buf_t *dsbuf) +{ + return erts_send_error_to_logger(NIL, dsbuf); +} + +int +erts_send_info_to_logger_str_nogl(char *str) +{ + return erts_send_info_to_logger_str(NIL, str); +} + +int +erts_send_warning_to_logger_str_nogl(char *str) +{ + return erts_send_warning_to_logger_str(NIL, str); +} + +int +erts_send_error_to_logger_str_nogl(char *str) +{ + return erts_send_error_to_logger_str(NIL, str); +} + + +#define TMP_DSBUF_INC_SZ 256 + +static erts_dsprintf_buf_t * +grow_tmp_dsbuf(erts_dsprintf_buf_t *dsbufp, size_t need) +{ + size_t size; + size_t free_size = dsbufp->size - dsbufp->str_len; + + ASSERT(dsbufp); + + if (need <= free_size) + return dsbufp; + size = need - free_size + TMP_DSBUF_INC_SZ; + size = ((size + TMP_DSBUF_INC_SZ - 1)/TMP_DSBUF_INC_SZ)*TMP_DSBUF_INC_SZ; + size += dsbufp->size; + ASSERT(dsbufp->str_len + need <= size); + dsbufp->str = (char *) erts_realloc(ERTS_ALC_T_TMP_DSBUF, + (void *) dsbufp->str, + size); + dsbufp->size = size; + return dsbufp; +} + +erts_dsprintf_buf_t * +erts_create_tmp_dsbuf(Uint size) +{ + Uint init_size = size ? size : TMP_DSBUF_INC_SZ; + erts_dsprintf_buf_t init = ERTS_DSPRINTF_BUF_INITER(grow_tmp_dsbuf); + erts_dsprintf_buf_t *dsbufp = erts_alloc(ERTS_ALC_T_TMP_DSBUF, + sizeof(erts_dsprintf_buf_t)); + sys_memcpy((void *) dsbufp, (void *) &init, sizeof(erts_dsprintf_buf_t)); + dsbufp->str = (char *) erts_alloc(ERTS_ALC_T_TMP_DSBUF, init_size); + dsbufp->str[0] = '\0'; + dsbufp->size = init_size; + return dsbufp; +} + +void +erts_destroy_tmp_dsbuf(erts_dsprintf_buf_t *dsbufp) +{ + if (dsbufp->str) + erts_free(ERTS_ALC_T_TMP_DSBUF, (void *) dsbufp->str); + erts_free(ERTS_ALC_T_TMP_DSBUF, (void *) dsbufp); +} + + +/* eq and cmp are written as separate functions a eq is a little faster */ + +/* + * Test for equality of two terms. + * Returns 0 if not equal, or a non-zero value otherwise. + */ + +int eq(Eterm a, Eterm b) +{ + DECLARE_ESTACK(stack); + Sint sz; + Eterm* aa; + Eterm* bb; + +tailrecur: + if (a == b) goto pop_next; +tailrecur_ne: + + switch (primary_tag(a)) { + case TAG_PRIMARY_LIST: + if (is_list(b)) { + Eterm* aval = list_val(a); + Eterm* bval = list_val(b); + while (1) { + Eterm atmp = CAR(aval); + Eterm btmp = CAR(bval); + if (atmp != btmp) { + ESTACK_PUSH2(stack,CDR(bval),CDR(aval)); + a = atmp; + b = btmp; + goto tailrecur_ne; + } + atmp = CDR(aval); + btmp = CDR(bval); + if (atmp == btmp) { + goto pop_next; + } + if (is_not_list(atmp) || is_not_list(btmp)) { + a = atmp; + b = btmp; + goto tailrecur_ne; + } + aval = list_val(atmp); + bval = list_val(btmp); + } + } + break; /* not equal */ + + case TAG_PRIMARY_BOXED: + { + Eterm hdr = *boxed_val(a); + switch (hdr & _TAG_HEADER_MASK) { + case ARITYVAL_SUBTAG: + { + aa = tuple_val(a); + if (!is_boxed(b) || *boxed_val(b) != *aa) + goto not_equal; + bb = tuple_val(b); + if ((sz = arityval(*aa)) == 0) goto pop_next; + ++aa; + ++bb; + goto term_array; + } + case REFC_BINARY_SUBTAG: + case HEAP_BINARY_SUBTAG: + case SUB_BINARY_SUBTAG: + { + byte* a_ptr; + byte* b_ptr; + size_t a_size; + size_t b_size; + Uint a_bitsize; + Uint b_bitsize; + Uint a_bitoffs; + Uint b_bitoffs; + + if (is_not_binary(b)) { + goto not_equal; + } + a_size = binary_size(a); + b_size = binary_size(b); + if (a_size != b_size) { + goto not_equal; + } + ERTS_GET_BINARY_BYTES(a, a_ptr, a_bitoffs, a_bitsize); + ERTS_GET_BINARY_BYTES(b, b_ptr, b_bitoffs, b_bitsize); + if ((a_bitsize | b_bitsize | a_bitoffs | b_bitoffs) == 0) { + if (sys_memcmp(a_ptr, b_ptr, a_size) == 0) goto pop_next; + } else if (a_bitsize == b_bitsize) { + if (erts_cmp_bits(a_ptr, a_bitoffs, b_ptr, b_bitoffs, + (a_size << 3) + a_bitsize) == 0) goto pop_next; + } + break; /* not equal */ + } + case EXPORT_SUBTAG: + { + if (is_export(b)) { + Export* a_exp = (Export *) (export_val(a))[1]; + Export* b_exp = (Export *) (export_val(b))[1]; + if (a_exp == b_exp) goto pop_next; + } + break; /* not equal */ + } + case FUN_SUBTAG: + { + ErlFunThing* f1; + ErlFunThing* f2; + + if (is_not_fun(b)) + goto not_equal; + f1 = (ErlFunThing *) fun_val(a); + f2 = (ErlFunThing *) fun_val(b); + if (f1->fe->module != f2->fe->module || + f1->fe->old_index != f2->fe->old_index || + f1->fe->old_uniq != f2->fe->old_uniq || + f1->num_free != f2->num_free) { + goto not_equal; + } + if ((sz = f1->num_free) == 0) goto pop_next; + aa = f1->env; + bb = f2->env; + goto term_array; + } + + case EXTERNAL_PID_SUBTAG: + case EXTERNAL_PORT_SUBTAG: { + ExternalThing *ap; + ExternalThing *bp; + + if(is_not_external(b)) + goto not_equal; + + ap = external_thing_ptr(a); + bp = external_thing_ptr(b); + + if(ap->header == bp->header && ap->node == bp->node) { + ASSERT(1 == external_data_words(a)); + ASSERT(1 == external_data_words(b)); + + if (ap->data.ui[0] == bp->data.ui[0]) goto pop_next; + } + break; /* not equal */ + } + case EXTERNAL_REF_SUBTAG: { + /* + * Observe! + * When comparing refs we need to compare ref numbers + * (32-bit words) *not* ref data words. + */ + Uint32 *anum; + Uint32 *bnum; + Uint common_len; + Uint alen; + Uint blen; + Uint i; + + if(is_not_external_ref(b)) + goto not_equal; + + if(external_node(a) != external_node(b)) + goto not_equal; + + anum = external_ref_numbers(a); + bnum = external_ref_numbers(b); + alen = external_ref_no_of_numbers(a); + blen = external_ref_no_of_numbers(b); + + goto ref_common; + case REF_SUBTAG: + + if (is_not_internal_ref(b)) + goto not_equal; + alen = internal_ref_no_of_numbers(a); + blen = internal_ref_no_of_numbers(b); + anum = internal_ref_numbers(a); + bnum = internal_ref_numbers(b); + + ref_common: + ASSERT(alen > 0 && blen > 0); + + if (anum[0] != bnum[0]) + goto not_equal; + + if (alen == 3 && blen == 3) { + /* Most refs are of length 3 */ + if (anum[1] == bnum[1] && anum[2] == bnum[2]) { + goto pop_next; + } else { + goto not_equal; + } + } + + common_len = alen; + if (blen < alen) + common_len = blen; + + for (i = 1; i < common_len; i++) + if (anum[i] != bnum[i]) + goto not_equal; + + if(alen != blen) { + + if (alen > blen) { + for (i = common_len; i < alen; i++) + if (anum[i] != 0) + goto not_equal; + } + else { + for (i = common_len; i < blen; i++) + if (bnum[i] != 0) + goto not_equal; + } + } + goto pop_next; + } + case POS_BIG_SUBTAG: + case NEG_BIG_SUBTAG: + { + int i; + + if (is_not_big(b)) + goto not_equal; + aa = big_val(a); /* get pointer to thing */ + bb = big_val(b); + if (*aa != *bb) + goto not_equal; + i = BIG_ARITY(aa); + while(i--) { + if (*++aa != *++bb) + goto not_equal; + } + goto pop_next; + } + case FLOAT_SUBTAG: + { + FloatDef af; + FloatDef bf; + + if (is_float(b)) { + GET_DOUBLE(a, af); + GET_DOUBLE(b, bf); + if (af.fd == bf.fd) goto pop_next; + } + break; /* not equal */ + } + } + break; + } + } + goto not_equal; + + +term_array: /* arrays in 'aa' and 'bb', length in 'sz' */ + ASSERT(sz != 0); + { + Eterm* ap = aa; + Eterm* bp = bb; + Sint i = sz; + for (;;) { + if (*ap != *bp) break; + if (--i == 0) goto pop_next; + ++ap; + ++bp; + } + a = *ap; + b = *bp; + if (is_both_immed(a,b)) { + goto not_equal; + } + if (i > 1) { /* push the rest */ + ESTACK_PUSH3(stack, i-1, (Eterm)(bp+1), + ((Eterm)(ap+1)) | TAG_PRIMARY_HEADER); + /* We (ab)use TAG_PRIMARY_HEADER to recognize a term_array */ + } + goto tailrecur_ne; + } + +pop_next: + if (!ESTACK_ISEMPTY(stack)) { + Eterm something = ESTACK_POP(stack); + if (primary_tag(something) == TAG_PRIMARY_HEADER) { /* a term_array */ + aa = (Eterm*) something; + bb = (Eterm*) ESTACK_POP(stack); + sz = ESTACK_POP(stack); + goto term_array; + } + a = something; + b = ESTACK_POP(stack); + goto tailrecur; + } + + DESTROY_ESTACK(stack); + return 1; + +not_equal: + DESTROY_ESTACK(stack); + return 0; +} + + +/* + * Lexically compare two strings of bytes (string s1 length l1 and s2 l2). + * + * s1 < s2 return -1 + * s1 = s2 return 0 + * s1 > s2 return +1 + */ +static int cmpbytes(byte *s1, int l1, byte *s2, int l2) +{ + int i; + i = 0; + while((i < l1) && (i < l2)) { + if (s1[i] < s2[i]) return(-1); + if (s1[i] > s2[i]) return(1); + i++; + } + if (l1 < l2) return(-1); + if (l1 > l2) return(1); + return(0); +} + + +/* + * Compare objects. + * Returns 0 if equal, a negative value if a < b, or a positive number a > b. + * + * According to the Erlang Standard, types are orderered as follows: + * numbers < (characters) < atoms < refs < funs < ports < pids < + * tuples < [] < conses < binaries. + * + * Note that characters are currently not implemented. + * + */ + + +#define float_comp(x,y) (((x)<(y)) ? -1 : (((x)==(y)) ? 0 : 1)) + +static int cmp_atoms(Eterm a, Eterm b) +{ + Atom *aa = atom_tab(atom_val(a)); + Atom *bb = atom_tab(atom_val(b)); + int diff = aa->ord0 - bb->ord0; + if (diff) + return diff; + return cmpbytes(aa->name+3, aa->len-3, + bb->name+3, bb->len-3); +} + +Sint cmp(Eterm a, Eterm b) +{ + DECLARE_ESTACK(stack); + Eterm* aa; + Eterm* bb; + int i; + Sint j; + int a_tag; + int b_tag; + ErlNode *anode; + ErlNode *bnode; + Uint adata; + Uint bdata; + Uint alen; + Uint blen; + Uint32 *anum; + Uint32 *bnum; + +#define RETURN_NEQ(cmp) { j=(cmp); ASSERT(j != 0); goto not_equal; } +#define ON_CMP_GOTO(cmp) if ((j=(cmp)) == 0) goto pop_next; else goto not_equal + +#undef CMP_NODES +#define CMP_NODES(AN, BN) \ + do { \ + if((AN) != (BN)) { \ + if((AN)->sysname != (BN)->sysname) \ + RETURN_NEQ(cmp_atoms((AN)->sysname, (BN)->sysname)); \ + ASSERT((AN)->creation != (BN)->creation); \ + RETURN_NEQ(((AN)->creation < (BN)->creation) ? -1 : 1); \ + } \ + } while (0) + + +tailrecur: + if (a == b) { /* Equal values or pointers. */ + goto pop_next; + } +tailrecur_ne: + + /* deal with majority (?) cases by brute-force */ + if (is_atom(a)) { + if (is_atom(b)) { + ON_CMP_GOTO(cmp_atoms(a, b)); + } + } else if (is_both_small(a, b)) { + ON_CMP_GOTO(signed_val(a) - signed_val(b)); + } + + /* + * Take care of cases where the types are the same. + */ + + a_tag = 42; /* Suppress warning */ + switch (primary_tag(a)) { + case TAG_PRIMARY_IMMED1: + switch ((a & _TAG_IMMED1_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_IMMED1_PORT >> _TAG_PRIMARY_SIZE): + if (is_internal_port(b)) { + bnode = erts_this_node; + bdata = internal_port_data(b); + } else if (is_external_port(b)) { + bnode = external_port_node(b); + bdata = external_port_data(b); + } else { + a_tag = PORT_DEF; + goto mixed_types; + } + anode = erts_this_node; + adata = internal_port_data(a); + + port_common: + CMP_NODES(anode, bnode); + ON_CMP_GOTO((Sint)(adata - bdata)); + + case (_TAG_IMMED1_PID >> _TAG_PRIMARY_SIZE): + if (is_internal_pid(b)) { + bnode = erts_this_node; + bdata = internal_pid_data(b); + } else if (is_external_pid(b)) { + bnode = external_pid_node(b); + bdata = external_pid_data(b); + } else { + a_tag = PID_DEF; + goto mixed_types; + } + anode = erts_this_node; + adata = internal_pid_data(a); + + pid_common: + if (adata != bdata) { + RETURN_NEQ(adata < bdata ? -1 : 1); + } + CMP_NODES(anode, bnode); + goto pop_next; + case (_TAG_IMMED1_SMALL >> _TAG_PRIMARY_SIZE): + a_tag = SMALL_DEF; + goto mixed_types; + case (_TAG_IMMED1_IMMED2 >> _TAG_PRIMARY_SIZE): { + switch ((a & _TAG_IMMED2_MASK) >> _TAG_IMMED1_SIZE) { + case (_TAG_IMMED2_ATOM >> _TAG_IMMED1_SIZE): + a_tag = ATOM_DEF; + goto mixed_types; + case (_TAG_IMMED2_NIL >> _TAG_IMMED1_SIZE): + a_tag = NIL_DEF; + goto mixed_types; + } + } + } + case TAG_PRIMARY_LIST: + if (is_not_list(b)) { + a_tag = LIST_DEF; + goto mixed_types; + } + aa = list_val(a); + bb = list_val(b); + while (1) { + Eterm atmp = CAR(aa); + Eterm btmp = CAR(bb); + if (atmp != btmp) { + ESTACK_PUSH2(stack,CDR(bb),CDR(aa)); + a = atmp; + b = btmp; + goto tailrecur_ne; + } + atmp = CDR(aa); + btmp = CDR(bb); + if (atmp == btmp) { + goto pop_next; + } + if (is_not_list(atmp) || is_not_list(btmp)) { + a = atmp; + b = btmp; + goto tailrecur_ne; + } + aa = list_val(atmp); + bb = list_val(btmp); + } + case TAG_PRIMARY_BOXED: + { + Eterm ahdr = *boxed_val(a); + switch ((ahdr & _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE) { + case (_TAG_HEADER_ARITYVAL >> _TAG_PRIMARY_SIZE): + if (is_not_tuple(b)) { + a_tag = TUPLE_DEF; + goto mixed_types; + } + aa = tuple_val(a); + bb = tuple_val(b); + /* compare the arities */ + i = arityval(ahdr); /* get the arity*/ + if (i != arityval(*bb)) { + RETURN_NEQ((int)(i - arityval(*bb))); + } + if (i == 0) { + goto pop_next; + } + ++aa; + ++bb; + goto term_array; + + case (_TAG_HEADER_FLOAT >> _TAG_PRIMARY_SIZE): + if (is_not_float(b)) { + a_tag = FLOAT_DEF; + goto mixed_types; + } else { + FloatDef af; + FloatDef bf; + + GET_DOUBLE(a, af); + GET_DOUBLE(b, bf); + ON_CMP_GOTO(float_comp(af.fd, bf.fd)); + } + case (_TAG_HEADER_POS_BIG >> _TAG_PRIMARY_SIZE): + case (_TAG_HEADER_NEG_BIG >> _TAG_PRIMARY_SIZE): + if (is_not_big(b)) { + a_tag = BIG_DEF; + goto mixed_types; + } + ON_CMP_GOTO(big_comp(a, b)); + case (_TAG_HEADER_EXPORT >> _TAG_PRIMARY_SIZE): + if (is_not_export(b)) { + a_tag = EXPORT_DEF; + goto mixed_types; + } else { + Export* a_exp = (Export *) (export_val(a))[1]; + Export* b_exp = (Export *) (export_val(b))[1]; + + if ((j = cmp_atoms(a_exp->code[0], b_exp->code[0])) != 0) { + RETURN_NEQ(j); + } + if ((j = cmp_atoms(a_exp->code[1], b_exp->code[1])) != 0) { + RETURN_NEQ(j); + } + ON_CMP_GOTO((Sint) a_exp->code[2] - (Sint) b_exp->code[2]); + } + break; + case (_TAG_HEADER_FUN >> _TAG_PRIMARY_SIZE): + if (is_not_fun(b)) { + a_tag = FUN_DEF; + goto mixed_types; + } else { + ErlFunThing* f1 = (ErlFunThing *) fun_val(a); + ErlFunThing* f2 = (ErlFunThing *) fun_val(b); + Sint diff; + + diff = cmpbytes(atom_tab(atom_val(f1->fe->module))->name, + atom_tab(atom_val(f1->fe->module))->len, + atom_tab(atom_val(f2->fe->module))->name, + atom_tab(atom_val(f2->fe->module))->len); + if (diff != 0) { + RETURN_NEQ(diff); + } + diff = f1->fe->old_index - f2->fe->old_index; + if (diff != 0) { + RETURN_NEQ(diff); + } + diff = f1->fe->old_uniq - f2->fe->old_uniq; + if (diff != 0) { + RETURN_NEQ(diff); + } + diff = f1->num_free - f2->num_free; + if (diff != 0) { + RETURN_NEQ(diff); + } + i = f1->num_free; + if (i == 0) goto pop_next; + aa = f1->env; + bb = f2->env; + goto term_array; + } + case (_TAG_HEADER_EXTERNAL_PID >> _TAG_PRIMARY_SIZE): + if (is_internal_pid(b)) { + bnode = erts_this_node; + bdata = internal_pid_data(b); + } else if (is_external_pid(b)) { + bnode = external_pid_node(b); + bdata = external_pid_data(b); + } else { + a_tag = EXTERNAL_PID_DEF; + goto mixed_types; + } + anode = external_pid_node(a); + adata = external_pid_data(a); + goto pid_common; + case (_TAG_HEADER_EXTERNAL_PORT >> _TAG_PRIMARY_SIZE): + if (is_internal_port(b)) { + bnode = erts_this_node; + bdata = internal_port_data(b); + } else if (is_external_port(b)) { + bnode = external_port_node(b); + bdata = external_port_data(b); + } else { + a_tag = EXTERNAL_PORT_DEF; + goto mixed_types; + } + anode = external_port_node(a); + adata = external_port_data(a); + goto port_common; + case (_TAG_HEADER_REF >> _TAG_PRIMARY_SIZE): + /* + * Note! When comparing refs we need to compare ref numbers + * (32-bit words), *not* ref data words. + */ + + if (is_internal_ref(b)) { + bnode = erts_this_node; + bnum = internal_ref_numbers(b); + blen = internal_ref_no_of_numbers(b); + } else if(is_external_ref(b)) { + bnode = external_ref_node(b); + bnum = external_ref_numbers(b); + blen = external_ref_no_of_numbers(b); + } else { + a_tag = REF_DEF; + goto mixed_types; + } + anode = erts_this_node; + anum = internal_ref_numbers(a); + alen = internal_ref_no_of_numbers(a); + + ref_common: + CMP_NODES(anode, bnode); + + ASSERT(alen > 0 && blen > 0); + if (alen != blen) { + if (alen > blen) { + do { + if (anum[alen - 1] != 0) + RETURN_NEQ(1); + alen--; + } while (alen > blen); + } + else { + do { + if (bnum[blen - 1] != 0) + RETURN_NEQ(-1); + blen--; + } while (alen < blen); + } + } + + ASSERT(alen == blen); + for (i = (Sint) alen - 1; i >= 0; i--) + if (anum[i] != bnum[i]) + RETURN_NEQ((Sint32) (anum[i] - bnum[i])); + goto pop_next; + case (_TAG_HEADER_EXTERNAL_REF >> _TAG_PRIMARY_SIZE): + if (is_internal_ref(b)) { + bnode = erts_this_node; + bnum = internal_ref_numbers(b); + blen = internal_ref_no_of_numbers(b); + } else if (is_external_ref(b)) { + bnode = external_ref_node(b); + bnum = external_ref_numbers(b); + blen = external_ref_no_of_numbers(b); + } else { + a_tag = EXTERNAL_REF_DEF; + goto mixed_types; + } + anode = external_ref_node(a); + anum = external_ref_numbers(a); + alen = external_ref_no_of_numbers(a); + goto ref_common; + default: + /* Must be a binary */ + ASSERT(is_binary(a)); + if (is_not_binary(b)) { + a_tag = BINARY_DEF; + goto mixed_types; + } else { + Uint a_size = binary_size(a); + Uint b_size = binary_size(b); + Uint a_bitsize; + Uint b_bitsize; + Uint a_bitoffs; + Uint b_bitoffs; + Uint min_size; + int cmp; + byte* a_ptr; + byte* b_ptr; + ERTS_GET_BINARY_BYTES(a, a_ptr, a_bitoffs, a_bitsize); + ERTS_GET_BINARY_BYTES(b, b_ptr, b_bitoffs, b_bitsize); + if ((a_bitsize | b_bitsize | a_bitoffs | b_bitoffs) == 0) { + min_size = (a_size < b_size) ? a_size : b_size; + if ((cmp = sys_memcmp(a_ptr, b_ptr, min_size)) != 0) { + RETURN_NEQ(cmp); + } + } + else { + a_size = (a_size << 3) + a_bitsize; + b_size = (b_size << 3) + b_bitsize; + min_size = (a_size < b_size) ? a_size : b_size; + if ((cmp = erts_cmp_bits(a_ptr,a_bitoffs, + b_ptr,b_bitoffs,min_size)) != 0) { + RETURN_NEQ(cmp); + } + } + ON_CMP_GOTO((Sint)(a_size - b_size)); + } + } + } + } + + /* + * Take care of the case that the tags are different. + */ + + mixed_types: + b_tag = tag_val_def(b); + + { + FloatDef f1, f2; + Eterm big; + Eterm big_buf[2]; + + switch(_NUMBER_CODE(a_tag, b_tag)) { + case SMALL_BIG: + big = small_to_big(signed_val(a), big_buf); + j = big_comp(big, b); + break; + case SMALL_FLOAT: + f1.fd = signed_val(a); + GET_DOUBLE(b, f2); + j = float_comp(f1.fd, f2.fd); + break; + case BIG_SMALL: + big = small_to_big(signed_val(b), big_buf); + j = big_comp(a, big); + break; + case BIG_FLOAT: + if (big_to_double(a, &f1.fd) < 0) { + j = big_sign(a) ? -1 : 1; + } else { + GET_DOUBLE(b, f2); + j = float_comp(f1.fd, f2.fd); + } + break; + case FLOAT_SMALL: + GET_DOUBLE(a, f1); + f2.fd = signed_val(b); + j = float_comp(f1.fd, f2.fd); + break; + case FLOAT_BIG: + if (big_to_double(b, &f2.fd) < 0) { + j = big_sign(b) ? 1 : -1; + } else { + GET_DOUBLE(a, f1); + j = float_comp(f1.fd, f2.fd); + } + break; + default: + j = b_tag - a_tag; + } + } + if (j == 0) { + goto pop_next; + } else { + goto not_equal; + } + +term_array: /* arrays in 'aa' and 'bb', length in 'i' */ + ASSERT(i>0); + while (--i) { + a = *aa++; + b = *bb++; + if (a != b) { + if (is_atom(a) && is_atom(b)) { + if ((j = cmp_atoms(a, b)) != 0) { + goto not_equal; + } + } else if (is_both_small(a, b)) { + if ((j = signed_val(a)-signed_val(b)) != 0) { + goto not_equal; + } + } else { + /* (ab)Use TAG_PRIMARY_HEADER to recognize a term_array */ + ESTACK_PUSH3(stack, i, (Eterm)bb, (Eterm)aa | TAG_PRIMARY_HEADER); + goto tailrecur_ne; + } + } + } + a = *aa; + b = *bb; + goto tailrecur; + +pop_next: + if (!ESTACK_ISEMPTY(stack)) { + Eterm something = ESTACK_POP(stack); + if (primary_tag(something) == TAG_PRIMARY_HEADER) { /* a term_array */ + aa = (Eterm*) something; + bb = (Eterm*) ESTACK_POP(stack); + i = ESTACK_POP(stack); + goto term_array; + } + a = something; + b = ESTACK_POP(stack); + goto tailrecur; + } + + DESTROY_ESTACK(stack); + return 0; + +not_equal: + DESTROY_ESTACK(stack); + return j; + +#undef CMP_NODES +} + + +void +erts_cleanup_externals(ExternalThing *etp) +{ + ExternalThing *tetp; + + tetp = etp; + + while(tetp) { + erts_deref_node_entry(tetp->node); + tetp = tetp->next; + } +} + +Eterm +store_external_or_ref_(Uint **hpp, ExternalThing **etpp, Eterm ns) +{ + Uint i; + Uint size; + Uint *from_hp; + Uint *to_hp = *hpp; + + ASSERT(is_external(ns) || is_internal_ref(ns)); + + if(is_external(ns)) { + from_hp = external_val(ns); + size = thing_arityval(*from_hp) + 1; + *hpp += size; + + for(i = 0; i < size; i++) + to_hp[i] = from_hp[i]; + + erts_refc_inc(&((ExternalThing *) to_hp)->node->refc, 2); + + ((ExternalThing *) to_hp)->next = *etpp; + *etpp = (ExternalThing *) to_hp; + + return make_external(to_hp); + } + + /* Internal ref */ + from_hp = internal_ref_val(ns); + + size = thing_arityval(*from_hp) + 1; + + *hpp += size; + + for(i = 0; i < size; i++) + to_hp[i] = from_hp[i]; + + return make_internal_ref(to_hp); +} + +Eterm +store_external_or_ref_in_proc_(Process *proc, Eterm ns) +{ + Uint sz; + Uint *hp; + + ASSERT(is_external(ns) || is_internal_ref(ns)); + + sz = NC_HEAP_SIZE(ns); + ASSERT(sz > 0); + hp = HAlloc(proc, sz); + return store_external_or_ref_(&hp, &MSO(proc).externals, ns); +} + +void bin_write(int to, void *to_arg, byte* buf, int sz) +{ + int i; + + for (i=0;is[sizeof(buf->s)-1]; + int sign = 0; + + *p-- = '\0'; /* null terminate */ + if (n == 0) + *p-- = '0'; + else if (n < 0) { + sign = 1; + n = -n; + } + + while (n != 0) { + *p-- = (n % 10) + '0'; + n /= 10; + } + if (sign) + *p-- = '-'; + return p+1; +} + +/* Build a list of integers in some safe memory area +** Memory must be pre allocated prio call 2*len in size +** hp is a pointer to the "heap" pointer on return +** this pointer is updated to point after the list +*/ + +Eterm +buf_to_intlist(Eterm** hpp, char *buf, int len, Eterm tail) +{ + Eterm* hp = *hpp; + + buf += (len-1); + while(len > 0) { + tail = CONS(hp, make_small((byte)*buf), tail); + hp += 2; + buf--; + len--; + } + *hpp = hp; + return tail; +} + +/* +** Write io list in to a buffer. +** +** An iolist is defined as: +** +** iohead ::= Binary +** | Byte (i.e integer in range [0..255] +** | iolist +** ; +** +** iotail ::= [] +** | Binary (added by tony) +** | iolist +** ; +** +** iolist ::= [] +** | Binary +** | [ iohead | iotail] +** ; +** +** Return remaining bytes in buffer on success +** -1 on overflow +** -2 on type error (including that result would not be a whole number of bytes) +*/ + +int io_list_to_buf(Eterm obj, char* buf, int len) +{ + Eterm* objp; + DECLARE_ESTACK(s); + goto L_again; + + while (!ESTACK_ISEMPTY(s)) { + obj = ESTACK_POP(s); + L_again: + if (is_list(obj)) { + L_iter_list: + objp = list_val(obj); + obj = CAR(objp); + if (is_byte(obj)) { + if (len == 0) { + goto L_overflow; + } + *buf++ = unsigned_val(obj); + len--; + } else if (is_binary(obj)) { + byte* bptr; + size_t size = binary_size(obj); + Uint bitsize; + Uint bitoffs; + Uint num_bits; + + if (len < size) { + goto L_overflow; + } + ERTS_GET_BINARY_BYTES(obj, bptr, bitoffs, bitsize); + if (bitsize != 0) { + goto L_type_error; + } + num_bits = 8*size; + copy_binary_to_buffer(buf, 0, bptr, bitoffs, num_bits); + buf += size; + len -= size; + } else if (is_list(obj)) { + ESTACK_PUSH(s, CDR(objp)); + goto L_iter_list; /* on head */ + } else if (is_not_nil(obj)) { + goto L_type_error; + } + + obj = CDR(objp); + if (is_list(obj)) { + goto L_iter_list; /* on tail */ + } else if (is_binary(obj)) { + byte* bptr; + size_t size = binary_size(obj); + Uint bitsize; + Uint bitoffs; + Uint num_bits; + if (len < size) { + goto L_overflow; + } + ERTS_GET_BINARY_BYTES(obj, bptr, bitoffs, bitsize); + if (bitsize != 0) { + goto L_type_error; + } + num_bits = 8*size; + copy_binary_to_buffer(buf, 0, bptr, bitoffs, num_bits); + buf += size; + len -= size; + } else if (is_not_nil(obj)) { + goto L_type_error; + } + } else if (is_binary(obj)) { + byte* bptr; + size_t size = binary_size(obj); + Uint bitsize; + Uint bitoffs; + Uint num_bits; + if (len < size) { + goto L_overflow; + } + ERTS_GET_BINARY_BYTES(obj, bptr, bitoffs, bitsize); + if (bitsize != 0) { + goto L_type_error; + } + num_bits = 8*size; + copy_binary_to_buffer(buf, 0, bptr, bitoffs, num_bits); + buf += size; + len -= size; + } else if (is_not_nil(obj)) { + goto L_type_error; + } + } + + DESTROY_ESTACK(s); + return len; + + L_type_error: + DESTROY_ESTACK(s); + return -2; + + L_overflow: + DESTROY_ESTACK(s); + return -1; +} + +int io_list_len(Eterm obj) +{ + Eterm* objp; + Sint len = 0; + DECLARE_ESTACK(s); + goto L_again; + + while (!ESTACK_ISEMPTY(s)) { + obj = ESTACK_POP(s); + L_again: + if (is_list(obj)) { + L_iter_list: + objp = list_val(obj); + /* Head */ + obj = CAR(objp); + if (is_byte(obj)) { + len++; + } else if (is_binary(obj) && binary_bitsize(obj) == 0) { + len += binary_size(obj); + } else if (is_list(obj)) { + ESTACK_PUSH(s, CDR(objp)); + goto L_iter_list; /* on head */ + } else if (is_not_nil(obj)) { + goto L_type_error; + } + /* Tail */ + obj = CDR(objp); + if (is_list(obj)) + goto L_iter_list; /* on tail */ + else if (is_binary(obj) && binary_bitsize(obj) == 0) { + len += binary_size(obj); + } else if (is_not_nil(obj)) { + goto L_type_error; + } + } else if (is_binary(obj) && binary_bitsize(obj) == 0) { /* Tail was binary */ + len += binary_size(obj); + } else if (is_not_nil(obj)) { + goto L_type_error; + } + } + + DESTROY_ESTACK(s); + return len; + + L_type_error: + DESTROY_ESTACK(s); + return -1; +} + +/* return 0 if item is not a non-empty flat list of bytes */ +int +is_string(Eterm list) +{ + int len = 0; + + while(is_list(list)) { + Eterm* consp = list_val(list); + Eterm hd = CAR(consp); + + if (!is_byte(hd)) + return 0; + len++; + list = CDR(consp); + } + if (is_nil(list)) + return len; + return 0; +} + +#ifdef ERTS_SMP + +/* + * Process and Port timers in smp case + */ + +ERTS_SCHED_PREF_PRE_ALLOC_IMPL(ptimer_pre, ErtsSmpPTimer, 1000) + +#define ERTS_PTMR_FLGS_ALLCD_SIZE \ + 2 +#define ERTS_PTMR_FLGS_ALLCD_MASK \ + ((((Uint32) 1) << ERTS_PTMR_FLGS_ALLCD_SIZE) - 1) + +#define ERTS_PTMR_FLGS_PREALLCD ((Uint32) 1) +#define ERTS_PTMR_FLGS_SLALLCD ((Uint32) 2) +#define ERTS_PTMR_FLGS_LLALLCD ((Uint32) 3) +#define ERTS_PTMR_FLG_CANCELLED (((Uint32) 1) << (ERTS_PTMR_FLGS_ALLCD_SIZE+0)) + +static void +init_ptimers(void) +{ + init_ptimer_pre_alloc(); +} + +static ERTS_INLINE void +free_ptimer(ErtsSmpPTimer *ptimer) +{ + switch (ptimer->timer.flags & ERTS_PTMR_FLGS_ALLCD_MASK) { + case ERTS_PTMR_FLGS_PREALLCD: + (void) ptimer_pre_free(ptimer); + break; + case ERTS_PTMR_FLGS_SLALLCD: + erts_free(ERTS_ALC_T_SL_PTIMER, (void *) ptimer); + break; + case ERTS_PTMR_FLGS_LLALLCD: + erts_free(ERTS_ALC_T_LL_PTIMER, (void *) ptimer); + break; + default: + erl_exit(ERTS_ABORT_EXIT, + "Internal error: Bad ptimer alloc type\n"); + break; + } +} + +/* Callback for process timeout cancelled */ +static void +ptimer_cancelled(ErtsSmpPTimer *ptimer) +{ + free_ptimer(ptimer); +} + +/* Callback for process timeout */ +static void +ptimer_timeout(ErtsSmpPTimer *ptimer) +{ + if (is_internal_pid(ptimer->timer.id)) { + Process *p; + p = erts_pid2proc_opt(NULL, + 0, + ptimer->timer.id, + ERTS_PROC_LOCK_MAIN|ERTS_PROC_LOCK_STATUS, + ERTS_P2P_FLG_ALLOW_OTHER_X); + if (p) { + if (!p->is_exiting + && !(ptimer->timer.flags & ERTS_PTMR_FLG_CANCELLED)) { + ASSERT(*ptimer->timer.timer_ref == ptimer); + *ptimer->timer.timer_ref = NULL; + (*ptimer->timer.timeout_func)(p); + } + erts_smp_proc_unlock(p, ERTS_PROC_LOCK_MAIN|ERTS_PROC_LOCK_STATUS); + } + } + else { + Port *p; + ASSERT(is_internal_port(ptimer->timer.id)); + p = erts_id2port_sflgs(ptimer->timer.id, + NULL, + 0, + ERTS_PORT_SFLGS_DEAD); + if (p) { + if (!(ptimer->timer.flags & ERTS_PTMR_FLG_CANCELLED)) { + ASSERT(*ptimer->timer.timer_ref == ptimer); + *ptimer->timer.timer_ref = NULL; + (*ptimer->timer.timeout_func)(p); + } + erts_port_release(p); + } + } + free_ptimer(ptimer); +} + +void +erts_create_smp_ptimer(ErtsSmpPTimer **timer_ref, + Eterm id, + ErlTimeoutProc timeout_func, + Uint timeout) +{ + ErtsSmpPTimer *res = ptimer_pre_alloc(); + if (res) + res->timer.flags = ERTS_PTMR_FLGS_PREALLCD; + else { + if (timeout < ERTS_ALC_MIN_LONG_LIVED_TIME) { + res = erts_alloc(ERTS_ALC_T_SL_PTIMER, sizeof(ErtsSmpPTimer)); + res->timer.flags = ERTS_PTMR_FLGS_SLALLCD; + } + else { + res = erts_alloc(ERTS_ALC_T_LL_PTIMER, sizeof(ErtsSmpPTimer)); + res->timer.flags = ERTS_PTMR_FLGS_LLALLCD; + } + } + res->timer.timeout_func = timeout_func; + res->timer.timer_ref = timer_ref; + res->timer.id = id; + res->timer.tm.active = 0; /* MUST be initalized */ + + ASSERT(!*timer_ref); + + *timer_ref = res; + + erl_set_timer(&res->timer.tm, + (ErlTimeoutProc) ptimer_timeout, + (ErlCancelProc) ptimer_cancelled, + (void*) res, + timeout); +} + +void +erts_cancel_smp_ptimer(ErtsSmpPTimer *ptimer) +{ + if (ptimer) { + ASSERT(*ptimer->timer.timer_ref == ptimer); + *ptimer->timer.timer_ref = NULL; + ptimer->timer.flags |= ERTS_PTMR_FLG_CANCELLED; + erl_cancel_timer(&ptimer->timer.tm); + } +} + +#endif + +static Sint trim_threshold; +static Sint top_pad; +static Sint mmap_threshold; +static Sint mmap_max; + +Uint tot_bin_allocated; + +void erts_init_utils(void) +{ +#ifdef ERTS_SMP + init_ptimers(); +#endif +} + +void erts_init_utils_mem(void) +{ + trim_threshold = -1; + top_pad = -1; + mmap_threshold = -1; + mmap_max = -1; +} + +int +sys_alloc_opt(int opt, int value) +{ +#if HAVE_MALLOPT + Sint m_opt; + Sint *curr_val; + + switch(opt) { + case SYS_ALLOC_OPT_TRIM_THRESHOLD: +#ifdef M_TRIM_THRESHOLD + m_opt = M_TRIM_THRESHOLD; + curr_val = &trim_threshold; + break; +#else + return 0; +#endif + case SYS_ALLOC_OPT_TOP_PAD: +#ifdef M_TOP_PAD + m_opt = M_TOP_PAD; + curr_val = &top_pad; + break; +#else + return 0; +#endif + case SYS_ALLOC_OPT_MMAP_THRESHOLD: +#ifdef M_MMAP_THRESHOLD + m_opt = M_MMAP_THRESHOLD; + curr_val = &mmap_threshold; + break; +#else + return 0; +#endif + case SYS_ALLOC_OPT_MMAP_MAX: +#ifdef M_MMAP_MAX + m_opt = M_MMAP_MAX; + curr_val = &mmap_max; + break; +#else + return 0; +#endif + default: + return 0; + } + + if(mallopt(m_opt, value)) { + *curr_val = (Sint) value; + return 1; + } + +#endif /* #if HAVE_MALLOPT */ + + return 0; +} + +void +sys_alloc_stat(SysAllocStat *sasp) +{ + sasp->trim_threshold = trim_threshold; + sasp->top_pad = top_pad; + sasp->mmap_threshold = mmap_threshold; + sasp->mmap_max = mmap_max; + +} + +#ifdef ERTS_SMP + +/* Local system block state */ + +struct { + int emergency; + long emergency_timeout; + erts_smp_cnd_t watchdog_cnd; + erts_smp_tid_t watchdog_tid; + int threads_to_block; + int have_blocker; + erts_smp_tid_t blocker_tid; + int recursive_block; + Uint32 allowed_activities; + erts_smp_tsd_key_t blockable_key; + erts_smp_mtx_t mtx; + erts_smp_cnd_t cnd; +#ifdef ERTS_ENABLE_LOCK_CHECK + int activity_changing; + int checking; +#endif +} system_block_state; + +/* Global system block state */ +erts_system_block_state_t erts_system_block_state; + + +static ERTS_INLINE int +is_blockable_thread(void) +{ + return erts_smp_tsd_get(system_block_state.blockable_key) != NULL; +} + +static ERTS_INLINE int +is_blocker(void) +{ + return (system_block_state.have_blocker + && erts_smp_equal_tids(system_block_state.blocker_tid, + erts_smp_thr_self())); +} + +#ifdef ERTS_ENABLE_LOCK_CHECK +int +erts_lc_is_blocking(void) +{ + int res; + erts_smp_mtx_lock(&system_block_state.mtx); + res = erts_smp_pending_system_block() && is_blocker(); + erts_smp_mtx_unlock(&system_block_state.mtx); + return res; +} +#endif + +static ERTS_INLINE void +block_me(void (*prepare)(void *), + void (*resume)(void *), + void *arg, + int mtx_locked, + int want_to_block, + int update_act_changing, + profile_sched_msg_q *psmq) +{ + if (prepare) + (*prepare)(arg); + + /* Locks might be held... */ + + if (!mtx_locked) + erts_smp_mtx_lock(&system_block_state.mtx); + + if (erts_smp_pending_system_block() && !is_blocker()) { + int is_blockable = is_blockable_thread(); + ASSERT(is_blockable); + + if (is_blockable) + system_block_state.threads_to_block--; + + if (erts_system_profile_flags.scheduler && psmq) { + ErtsSchedulerData *esdp = erts_get_scheduler_data(); + if (esdp) { + profile_sched_msg *msg = NULL; + + ASSERT(psmq->n < 2); + msg = &((psmq->msg)[psmq->n]); + msg->scheduler_id = esdp->no; + get_now(&(msg->Ms), &(msg->s), &(msg->us)); + msg->no_schedulers = 0; + msg->state = am_inactive; + psmq->n++; + } + } + +#ifdef ERTS_ENABLE_LOCK_CHECK + if (update_act_changing) + system_block_state.activity_changing--; +#endif + + erts_smp_cnd_broadcast(&system_block_state.cnd); + + do { + erts_smp_cnd_wait(&system_block_state.cnd, &system_block_state.mtx); + } while (erts_smp_pending_system_block() + && !(want_to_block && !system_block_state.have_blocker)); + +#ifdef ERTS_ENABLE_LOCK_CHECK + if (update_act_changing) + system_block_state.activity_changing++; +#endif + if (erts_system_profile_flags.scheduler && psmq) { + ErtsSchedulerData *esdp = erts_get_scheduler_data(); + if (esdp) { + profile_sched_msg *msg = NULL; + + ASSERT(psmq->n < 2); + msg = &((psmq->msg)[psmq->n]); + msg->scheduler_id = esdp->no; + get_now(&(msg->Ms), &(msg->s), &(msg->us)); + msg->no_schedulers = 0; + msg->state = am_active; + psmq->n++; + } + } + + if (is_blockable) + system_block_state.threads_to_block++; + } + + if (!mtx_locked) + erts_smp_mtx_unlock(&system_block_state.mtx); + + if (resume) + (*resume)(arg); +} + +void +erts_block_me(void (*prepare)(void *), + void (*resume)(void *), + void *arg) +{ + profile_sched_msg_q psmq; + psmq.n = 0; + if (prepare) + (*prepare)(arg); + +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_check_exact(NULL, 0); /* No locks should be locked */ +#endif + + block_me(NULL, NULL, NULL, 0, 0, 0, &psmq); + + if (erts_system_profile_flags.scheduler && psmq.n > 0) + dispatch_profile_msg_q(&psmq); + + if (resume) + (*resume)(arg); +} + +void +erts_register_blockable_thread(void) +{ + profile_sched_msg_q psmq; + psmq.n = 0; + if (!is_blockable_thread()) { + erts_smp_mtx_lock(&system_block_state.mtx); + system_block_state.threads_to_block++; + erts_smp_tsd_set(system_block_state.blockable_key, + (void *) &erts_system_block_state); + + /* Someone might be waiting for us to block... */ + if (erts_smp_pending_system_block()) + block_me(NULL, NULL, NULL, 1, 0, 0, &psmq); + erts_smp_mtx_unlock(&system_block_state.mtx); + + if (erts_system_profile_flags.scheduler && psmq.n > 0) + dispatch_profile_msg_q(&psmq); + } +} + +void +erts_unregister_blockable_thread(void) +{ + if (is_blockable_thread()) { + erts_smp_mtx_lock(&system_block_state.mtx); + system_block_state.threads_to_block--; + ASSERT(system_block_state.threads_to_block >= 0); + erts_smp_tsd_set(system_block_state.blockable_key, NULL); + + /* Someone might be waiting for us to block... */ + if (erts_smp_pending_system_block()) + erts_smp_cnd_broadcast(&system_block_state.cnd); + erts_smp_mtx_unlock(&system_block_state.mtx); + } +} + +void +erts_note_activity_begin(erts_activity_t activity) +{ + erts_smp_mtx_lock(&system_block_state.mtx); + if (erts_smp_pending_system_block()) { + Uint32 broadcast = 0; + switch (activity) { + case ERTS_ACTIVITY_GC: + broadcast = (system_block_state.allowed_activities + & ERTS_BS_FLG_ALLOW_GC); + break; + case ERTS_ACTIVITY_IO: + broadcast = (system_block_state.allowed_activities + & ERTS_BS_FLG_ALLOW_IO); + break; + case ERTS_ACTIVITY_WAIT: + broadcast = 1; + break; + default: + abort(); + break; + } + if (broadcast) + erts_smp_cnd_broadcast(&system_block_state.cnd); + } + erts_smp_mtx_unlock(&system_block_state.mtx); +} + +void +erts_check_block(erts_activity_t old_activity, + erts_activity_t new_activity, + int locked, + void (*prepare)(void *), + void (*resume)(void *), + void *arg) +{ + int do_block; + profile_sched_msg_q psmq; + + psmq.n = 0; + if (!locked && prepare) + (*prepare)(arg); + + erts_smp_mtx_lock(&system_block_state.mtx); + + /* First check if it is ok to block... */ + if (!locked) + do_block = 1; + else { + switch (old_activity) { + case ERTS_ACTIVITY_UNDEFINED: + do_block = 0; + break; + case ERTS_ACTIVITY_GC: + do_block = (system_block_state.allowed_activities + & ERTS_BS_FLG_ALLOW_GC); + break; + case ERTS_ACTIVITY_IO: + do_block = (system_block_state.allowed_activities + & ERTS_BS_FLG_ALLOW_IO); + break; + case ERTS_ACTIVITY_WAIT: + /* You are not allowed to leave activity waiting + * without supplying the possibility to block + * unlocked. + */ + erts_set_activity_error(ERTS_ACT_ERR_LEAVE_WAIT_UNLOCKED, + __FILE__, __LINE__); + do_block = 0; + break; + default: + erts_set_activity_error(ERTS_ACT_ERR_LEAVE_UNKNOWN_ACTIVITY, + __FILE__, __LINE__); + do_block = 0; + break; + } + } + + if (do_block) { + /* ... then check if it is necessary to block... */ + + switch (new_activity) { + case ERTS_ACTIVITY_UNDEFINED: + do_block = 1; + break; + case ERTS_ACTIVITY_GC: + do_block = !(system_block_state.allowed_activities + & ERTS_BS_FLG_ALLOW_GC); + break; + case ERTS_ACTIVITY_IO: + do_block = !(system_block_state.allowed_activities + & ERTS_BS_FLG_ALLOW_IO); + break; + case ERTS_ACTIVITY_WAIT: + /* No need to block if we are going to wait */ + do_block = 0; + break; + default: + erts_set_activity_error(ERTS_ACT_ERR_ENTER_UNKNOWN_ACTIVITY, + __FILE__, __LINE__); + break; + } + } + + if (do_block) { + +#ifdef ERTS_ENABLE_LOCK_CHECK + if (!locked) { + /* Only system_block_state.mtx should be held */ + erts_lc_check_exact(&system_block_state.mtx.lc, 1); + } +#endif + + block_me(NULL, NULL, NULL, 1, 0, 1, &psmq); + + } + + erts_smp_mtx_unlock(&system_block_state.mtx); + + if (erts_system_profile_flags.scheduler && psmq.n > 0) + dispatch_profile_msg_q(&psmq); + + if (!locked && resume) + (*resume)(arg); +} + + + +void +erts_set_activity_error(erts_activity_error_t error, char *file, int line) +{ + switch (error) { + case ERTS_ACT_ERR_LEAVE_WAIT_UNLOCKED: + erl_exit(1, "%s:%d: Fatal error: Leaving activity waiting without " + "supplying the possibility to block unlocked.", + file, line); + break; + case ERTS_ACT_ERR_LEAVE_UNKNOWN_ACTIVITY: + erl_exit(1, "%s:%d: Fatal error: Leaving unknown activity.", + file, line); + break; + case ERTS_ACT_ERR_ENTER_UNKNOWN_ACTIVITY: + erl_exit(1, "%s:%d: Fatal error: Leaving unknown activity.", + file, line); + break; + default: + erl_exit(1, "%s:%d: Internal error in erts_smp_set_activity()", + file, line); + break; + } + +} + + +static ERTS_INLINE int +threads_not_under_control(void) +{ + int res = system_block_state.threads_to_block; + + /* Waiting is always an allowed activity... */ + res -= erts_smp_atomic_read(&erts_system_block_state.in_activity.wait); + + if (system_block_state.allowed_activities & ERTS_BS_FLG_ALLOW_GC) + res -= erts_smp_atomic_read(&erts_system_block_state.in_activity.gc); + + if (system_block_state.allowed_activities & ERTS_BS_FLG_ALLOW_IO) + res -= erts_smp_atomic_read(&erts_system_block_state.in_activity.io); + + if (res < 0) { + ASSERT(0); + return 0; + } + return res; +} + +/* + * erts_block_system() blocks all threads registered as blockable. + * It doesn't return until either all threads have blocked (0 is returned) + * or it has timed out (ETIMEDOUT) is returned. + * + * If allowed activities == 0, blocked threads will release all locks + * before blocking. + * + * If allowed_activities is != 0, erts_block_system() will allow blockable + * threads to continue executing as long as they are doing an allowed + * activity. When they are done with the allowed activity they will block, + * *but* they will block holding locks. Therefore, the thread calling + * erts_block_system() must *not* try to aquire any locks that might be + * held by blocked threads holding locks from allowed activities. + * + * Currently allowed_activities are: + * * ERTS_BS_FLG_ALLOW_GC Thread continues with garbage + * collection and blocks with + * main process lock on current + * process locked. + * * ERTS_BS_FLG_ALLOW_IO Thread continues with I/O + */ + +void +erts_block_system(Uint32 allowed_activities) +{ + int do_block; + profile_sched_msg_q psmq; + + psmq.n = 0; +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_check_exact(NULL, 0); /* No locks should be locked */ +#endif + + erts_smp_mtx_lock(&system_block_state.mtx); + + do_block = erts_smp_pending_system_block(); + if (do_block + && system_block_state.have_blocker + && erts_smp_equal_tids(system_block_state.blocker_tid, + erts_smp_thr_self())) { + ASSERT(system_block_state.recursive_block >= 0); + system_block_state.recursive_block++; + + /* You are not allowed to restrict allowed activites + in a recursive block! */ + ERTS_SMP_LC_ASSERT((system_block_state.allowed_activities + & ~allowed_activities) == 0); + } + else { + + erts_smp_atomic_inc(&erts_system_block_state.do_block); + + /* Someone else might be waiting for us to block... */ + if (do_block) { + do_block_me: + block_me(NULL, NULL, NULL, 1, 1, 0, &psmq); + } + + ASSERT(!system_block_state.have_blocker); + system_block_state.have_blocker = 1; + system_block_state.blocker_tid = erts_smp_thr_self(); + system_block_state.allowed_activities = allowed_activities; + + if (is_blockable_thread()) + system_block_state.threads_to_block--; + + while (threads_not_under_control() && !system_block_state.emergency) + erts_smp_cnd_wait(&system_block_state.cnd, &system_block_state.mtx); + + if (system_block_state.emergency) { + system_block_state.have_blocker = 0; + goto do_block_me; + } + } + + erts_smp_mtx_unlock(&system_block_state.mtx); + + if (erts_system_profile_flags.scheduler && psmq.n > 0 ) + dispatch_profile_msg_q(&psmq); +} + +/* + * erts_emergency_block_system() should only be called when we are + * about to write a crash dump... + */ + +int +erts_emergency_block_system(long timeout, Uint32 allowed_activities) +{ + int res = 0; + long another_blocker; + + erts_smp_mtx_lock(&system_block_state.mtx); + + if (system_block_state.emergency) { + /* Argh... */ + res = EINVAL; + goto done; + } + + another_blocker = erts_smp_pending_system_block(); + system_block_state.emergency = 1; + erts_smp_atomic_inc(&erts_system_block_state.do_block); + + if (another_blocker) { + if (is_blocker()) { + erts_smp_atomic_dec(&erts_system_block_state.do_block); + res = 0; + goto done; + } + /* kick the other blocker */ + erts_smp_cnd_broadcast(&system_block_state.cnd); + while (system_block_state.have_blocker) + erts_smp_cnd_wait(&system_block_state.cnd, &system_block_state.mtx); + } + + ASSERT(!system_block_state.have_blocker); + system_block_state.have_blocker = 1; + system_block_state.blocker_tid = erts_smp_thr_self(); + system_block_state.allowed_activities = allowed_activities; + + if (is_blockable_thread()) + system_block_state.threads_to_block--; + + if (timeout < 0) { + while (threads_not_under_control()) + erts_smp_cnd_wait(&system_block_state.cnd, &system_block_state.mtx); + } + else { + system_block_state.emergency_timeout = timeout; + erts_smp_cnd_signal(&system_block_state.watchdog_cnd); + + while (system_block_state.emergency_timeout >= 0 + && threads_not_under_control()) { + erts_smp_cnd_wait(&system_block_state.cnd, + &system_block_state.mtx); + } + } + done: + erts_smp_mtx_unlock(&system_block_state.mtx); + return res; +} + +void +erts_release_system(void) +{ + long do_block; + profile_sched_msg_q psmq; + + psmq.n = 0; + +#ifdef ERTS_ENABLE_LOCK_CHECK + erts_lc_check_exact(NULL, 0); /* No locks should be locked */ +#endif + + erts_smp_mtx_lock(&system_block_state.mtx); + ASSERT(is_blocker()); + + ASSERT(system_block_state.recursive_block >= 0); + + if (system_block_state.recursive_block) + system_block_state.recursive_block--; + else { + do_block = erts_smp_atomic_dectest(&erts_system_block_state.do_block); + system_block_state.have_blocker = 0; + if (is_blockable_thread()) + system_block_state.threads_to_block++; + else + do_block = 0; + + /* Someone else might be waiting for us to block... */ + if (do_block) + block_me(NULL, NULL, NULL, 1, 0, 0, &psmq); + else + erts_smp_cnd_broadcast(&system_block_state.cnd); + } + + erts_smp_mtx_unlock(&system_block_state.mtx); + + if (erts_system_profile_flags.scheduler && psmq.n > 0) + dispatch_profile_msg_q(&psmq); +} + +#ifdef ERTS_ENABLE_LOCK_CHECK + +void +erts_lc_activity_change_begin(void) +{ + erts_smp_mtx_lock(&system_block_state.mtx); + system_block_state.activity_changing++; + erts_smp_mtx_unlock(&system_block_state.mtx); +} + +void +erts_lc_activity_change_end(void) +{ + erts_smp_mtx_lock(&system_block_state.mtx); + system_block_state.activity_changing--; + if (system_block_state.checking && !system_block_state.activity_changing) + erts_smp_cnd_broadcast(&system_block_state.cnd); + erts_smp_mtx_unlock(&system_block_state.mtx); +} + +#endif + +int +erts_is_system_blocked(erts_activity_t allowed_activities) +{ + int blkd; + + erts_smp_mtx_lock(&system_block_state.mtx); + blkd = (erts_smp_pending_system_block() + && system_block_state.have_blocker + && erts_smp_equal_tids(system_block_state.blocker_tid, + erts_smp_thr_self()) + && !(system_block_state.allowed_activities & ~allowed_activities)); +#ifdef ERTS_ENABLE_LOCK_CHECK + if (blkd) { + system_block_state.checking = 1; + while (system_block_state.activity_changing) + erts_smp_cnd_wait(&system_block_state.cnd, &system_block_state.mtx); + system_block_state.checking = 0; + blkd = !threads_not_under_control(); + } +#endif + erts_smp_mtx_unlock(&system_block_state.mtx); + return blkd; +} + +static void * +emergency_watchdog(void *unused) +{ + erts_smp_mtx_lock(&system_block_state.mtx); + while (1) { + long timeout; + while (system_block_state.emergency_timeout < 0) + erts_smp_cnd_wait(&system_block_state.watchdog_cnd, &system_block_state.mtx); + timeout = system_block_state.emergency_timeout; + erts_smp_mtx_unlock(&system_block_state.mtx); + + if (erts_disable_tolerant_timeofday) + erts_milli_sleep(timeout); + else { + SysTimeval to; + erts_get_timeval(&to); + to.tv_sec += timeout / 1000; + to.tv_usec += timeout % 1000; + + while (1) { + SysTimeval curr; + erts_milli_sleep(timeout); + erts_get_timeval(&curr); + if (curr.tv_sec > to.tv_sec + || (curr.tv_sec == to.tv_sec && curr.tv_usec >= to.tv_usec)) { + break; + } + timeout = (to.tv_sec - curr.tv_sec)*1000; + timeout += (to.tv_usec - curr.tv_usec)/1000; + } + } + + erts_smp_mtx_lock(&system_block_state.mtx); + system_block_state.emergency_timeout = -1; + erts_smp_cnd_broadcast(&system_block_state.cnd); + } + erts_smp_mtx_unlock(&system_block_state.mtx); + return NULL; +} + +void +erts_system_block_init(void) +{ + erts_smp_thr_opts_t thr_opts = ERTS_SMP_THR_OPTS_DEFAULT_INITER; + /* Local state... */ + system_block_state.emergency = 0; + system_block_state.emergency_timeout = -1; + erts_smp_cnd_init(&system_block_state.watchdog_cnd); + system_block_state.threads_to_block = 0; + system_block_state.have_blocker = 0; + /* system_block_state.block_tid */ + system_block_state.recursive_block = 0; + system_block_state.allowed_activities = 0; + erts_smp_tsd_key_create(&system_block_state.blockable_key); + erts_smp_mtx_init(&system_block_state.mtx, "system_block"); + erts_smp_cnd_init(&system_block_state.cnd); +#ifdef ERTS_ENABLE_LOCK_CHECK + system_block_state.activity_changing = 0; + system_block_state.checking = 0; +#endif + + thr_opts.suggested_stack_size = 8; + erts_smp_thr_create(&system_block_state.watchdog_tid, + emergency_watchdog, + NULL, + &thr_opts); + + /* Global state... */ + + erts_smp_atomic_init(&erts_system_block_state.do_block, 0L); + erts_smp_atomic_init(&erts_system_block_state.in_activity.wait, 0L); + erts_smp_atomic_init(&erts_system_block_state.in_activity.gc, 0L); + erts_smp_atomic_init(&erts_system_block_state.in_activity.io, 0L); + + /* Make sure blockable threads unregister when exiting... */ + erts_smp_install_exit_handler(erts_unregister_blockable_thread); +} + + +#endif /* #ifdef ERTS_SMP */ + +char * +erts_read_env(char *key) +{ + size_t value_len = 256; + char *value = erts_alloc(ERTS_ALC_T_TMP, value_len); + int res; + while (1) { + res = erts_sys_getenv(key, value, &value_len); + if (res <= 0) + break; + value = erts_realloc(ERTS_ALC_T_TMP, value, value_len); + } + if (res != 0) { + erts_free(ERTS_ALC_T_TMP, value); + return NULL; + } + return value; +} + +void +erts_free_read_env(void *value) +{ + if (value) + erts_free(ERTS_ALC_T_TMP, value); +} + +int +erts_write_env(char *key, char *value) +{ + int ix, res; + size_t key_len = sys_strlen(key), value_len = sys_strlen(value); + char *key_value = erts_alloc_fnf(ERTS_ALC_T_TMP, + key_len + 1 + value_len + 1); + if (!key_value) { + errno = ENOMEM; + return -1; + } + sys_memcpy((void *) key_value, (void *) key, key_len); + ix = key_len; + key_value[ix++] = '='; + sys_memcpy((void *) key_value, (void *) value, value_len); + ix += value_len; + key_value[ix] = '\0'; + res = erts_sys_putenv(key_value, key_len); + erts_free(ERTS_ALC_T_TMP, key_value); + return res; +} + +#ifdef DEBUG +/* + * Handy functions when using a debugger - don't use in the code! + */ + +void upp(buf,sz) +byte* buf; +int sz; +{ + bin_write(ERTS_PRINT_STDERR,NULL,buf,sz); +} + +void pat(Eterm atom) +{ + upp(atom_tab(atom_val(atom))->name, + atom_tab(atom_val(atom))->len); +} + + +void pinfo() +{ + process_info(ERTS_PRINT_STDOUT, NULL); +} + + +void pp(p) +Process *p; +{ + if(p) + print_process_info(ERTS_PRINT_STDERR, NULL, p); +} + +void ppi(Eterm pid) +{ + pp(erts_pid2proc_unlocked(pid)); +} + +void td(Eterm x) +{ + erts_fprintf(stderr, "%T\n", x); +} + +void +ps(Process* p, Eterm* stop) +{ + Eterm* sp = STACK_START(p) - 1; + + if (stop <= STACK_END(p)) { + stop = STACK_END(p) + 1; + } + + while(sp >= stop) { + erts_printf("%p: %.75T\n", sp, *sp); + sp--; + } +} +#endif + + diff --git a/erts/emulator/beam/version.h b/erts/emulator/beam/version.h new file mode 100644 index 0000000000..3952c751b7 --- /dev/null +++ b/erts/emulator/beam/version.h @@ -0,0 +1,19 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2009. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ +extern char erlversion[], erlhost[], erldate[]; -- cgit v1.2.3