aboutsummaryrefslogtreecommitdiffstats
path: root/erts/emulator/beam/utils.c
diff options
context:
space:
mode:
authorErlang/OTP <[email protected]>2009-11-20 14:54:40 +0000
committerErlang/OTP <[email protected]>2009-11-20 14:54:40 +0000
commit84adefa331c4159d432d22840663c38f155cd4c1 (patch)
treebff9a9c66adda4df2106dfd0e5c053ab182a12bd /erts/emulator/beam/utils.c
downloadotp-84adefa331c4159d432d22840663c38f155cd4c1.tar.gz
otp-84adefa331c4159d432d22840663c38f155cd4c1.tar.bz2
otp-84adefa331c4159d432d22840663c38f155cd4c1.zip
The R13B03 release.OTP_R13B03
Diffstat (limited to 'erts/emulator/beam/utils.c')
-rw-r--r--erts/emulator/beam/utils.c4053
1 files changed, 4053 insertions, 0 deletions
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 <malloc.h>
+#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) = <initial hash>
+** 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",[<message as list>]}}} |
+ {notify,{error,gleader,{emulator,"~s~n",[<message as list>]}}} |
+ {notify,{warning_msg,gleader,{emulator,"~s~n",[<message as list>}]}} */
+ 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;i<sz;i++) {
+ if (IS_DIGIT(buf[i]))
+ erts_print(to, to_arg, "%d,", buf[i]);
+ else if (IS_PRINT(buf[i])) {
+ erts_print(to, to_arg, "%c,", buf[i]);
+ }
+ else
+ erts_print(to, to_arg, "%d,", buf[i]);
+ }
+ erts_putc(to, to_arg, '\n');
+}
+
+/* Fill buf with the contents of bytelist list
+ return number of chars in list or -1 for error */
+
+int
+intlist_to_buf(Eterm list, char *buf, int len)
+{
+ Eterm* listptr;
+ int sz = 0;
+
+ if (is_nil(list))
+ return 0;
+ if (is_not_list(list))
+ return -1;
+ listptr = list_val(list);
+
+ while (sz < len) {
+ if (!is_byte(*listptr))
+ return -1;
+ buf[sz++] = unsigned_val(*listptr);
+ if (is_nil(*(listptr + 1)))
+ return(sz);
+ if (is_not_list(*(listptr + 1)))
+ return -1;
+ listptr = list_val(*(listptr + 1));
+ }
+ return -1; /* not enough space */
+}
+
+/*
+** Convert an integer to a byte list
+** return pointer to converted stuff (need not to be at start of buf!)
+*/
+char* Sint_to_buf(Sint n, struct Sint_buf *buf)
+{
+ char* p = &buf->s[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
+
+
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-11 04:33:33 +0000