aboutsummaryrefslogtreecommitdiffstats
path: root/erts/emulator/beam/erl_db_util.c
diff options
context:
space:
mode:
Diffstat (limited to 'erts/emulator/beam/erl_db_util.c')
-rw-r--r--erts/emulator/beam/erl_db_util.c4651
1 files changed, 4651 insertions, 0 deletions
diff --git a/erts/emulator/beam/erl_db_util.c b/erts/emulator/beam/erl_db_util.c
new file mode 100644
index 0000000000..8c373451fd
--- /dev/null
+++ b/erts/emulator/beam/erl_db_util.c
@@ -0,0 +1,4651 @@
+/*
+ * %CopyrightBegin%
+ *
+ * Copyright Ericsson AB 1998-2009. All Rights Reserved.
+ *
+ * The contents of this file are subject to the Erlang Public License,
+ * Version 1.1, (the "License"); you may not use this file except in
+ * compliance with the License. You should have received a copy of the
+ * Erlang Public License along with this software. If not, it can be
+ * retrieved online at http://www.erlang.org/.
+ *
+ * Software distributed under the License is distributed on an "AS IS"
+ * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
+ * the License for the specific language governing rights and limitations
+ * under the License.
+ *
+ * %CopyrightEnd%
+ */
+
+/*
+ * Common utilities for the different types of db tables.
+ * Mostly matching etc.
+ */
+
+#ifdef HAVE_CONFIG_H
+# include "config.h"
+#endif
+
+#include "sys.h"
+#include "erl_vm.h"
+#include "global.h"
+#include "erl_process.h"
+#include "error.h"
+#define ERTS_WANT_DB_INTERNAL__
+#include "erl_db.h"
+#include "bif.h"
+#include "big.h"
+#include "erl_binary.h"
+
+#include "erl_db_util.h"
+
+
+/*
+** Flags for the guard bif's
+*/
+
+/* These are offsets from the DCOMP_* value */
+#define DBIF_GUARD 1
+#define DBIF_BODY 0
+
+/* These are the DBIF flag bits corresponding to the DCOMP_* value.
+ * If a bit is set, the BIF is allowed in that context. */
+#define DBIF_TABLE_GUARD (1 << (DCOMP_TABLE + DBIF_GUARD))
+#define DBIF_TABLE_BODY (1 << (DCOMP_TABLE + DBIF_BODY))
+#define DBIF_TRACE_GUARD (1 << (DCOMP_TRACE + DBIF_GUARD))
+#define DBIF_TRACE_BODY (1 << (DCOMP_TRACE + DBIF_BODY))
+#define DBIF_ALL \
+DBIF_TABLE_GUARD | DBIF_TABLE_BODY | DBIF_TRACE_GUARD | DBIF_TRACE_BODY
+
+
+
+/*
+** Some convenience macros for stacks (DMC == db_match_compile)
+*/
+
+#define DMC_DEFAULT_SIZE 25
+
+#define DMC_STACK_TYPE(Type) DMC_##Type##_stack
+
+#define DMC_DECLARE_STACK_TYPE(Type) \
+typedef struct DMC_STACK_TYPE(Type) { \
+ int pos; \
+ int siz; \
+ Type def[DMC_DEFAULT_SIZE]; \
+ Type *data; \
+} DMC_STACK_TYPE(Type)
+
+#define DMC_INIT_STACK(Name) \
+ (Name).pos = 0; (Name).siz = DMC_DEFAULT_SIZE; (Name).data = (Name).def
+
+#define DMC_STACK_DATA(Name) (Name).data
+
+#define DMC_STACK_NUM(Name) (Name).pos
+
+#define DMC_PUSH(On, What) \
+do { \
+ if ((On).pos >= (On).siz) { \
+ (On).siz *= 2; \
+ (On).data \
+ = (((On).def == (On).data) \
+ ? memcpy(erts_alloc(ERTS_ALC_T_DB_MC_STK, \
+ (On).siz*sizeof(*((On).data))), \
+ (On).def, \
+ DMC_DEFAULT_SIZE*sizeof(*((On).data))) \
+ : erts_realloc(ERTS_ALC_T_DB_MC_STK, \
+ (void *) (On).data, \
+ (On).siz*sizeof(*((On).data)))); \
+ } \
+ (On).data[(On).pos++] = What; \
+} while (0)
+
+#define DMC_POP(From) (From).data[--(From).pos]
+
+#define DMC_TOP(From) (From).data[(From).pos - 1]
+
+#define DMC_EMPTY(Name) ((Name).pos == 0)
+
+#define DMC_PEEK(On, At) (On).data[At]
+
+#define DMC_POKE(On, At, Value) ((On).data[At] = (Value))
+
+#define DMC_CLEAR(Name) (Name).pos = 0
+
+#define DMC_FREE(Name) \
+do { \
+ if ((Name).def != (Name).data) \
+ erts_free(ERTS_ALC_T_DB_MC_STK, (Name).data); \
+} while (0)
+
+static ERTS_INLINE Process *
+get_proc(Process *cp, Uint32 cp_locks, Eterm id, Uint32 id_locks)
+{
+ Process *proc = erts_pid2proc(cp, cp_locks, id, id_locks);
+ if (!proc && is_atom(id))
+ proc = erts_whereis_process(cp, cp_locks, id, id_locks, 0);
+ return proc;
+}
+
+
+static Eterm
+set_tracee_flags(Process *tracee_p, Eterm tracer, Uint d_flags, Uint e_flags) {
+ Eterm ret;
+ Uint flags;
+
+ if (tracer == NIL) {
+ flags = tracee_p->trace_flags & ~TRACEE_FLAGS;
+ } else {
+ flags = ((tracee_p->trace_flags & ~d_flags) | e_flags);
+ if (! flags) tracer = NIL;
+ }
+ ret = tracee_p->tracer_proc != tracer || tracee_p->trace_flags != flags
+ ? am_true : am_false;
+ tracee_p->tracer_proc = tracer;
+ tracee_p->trace_flags = flags;
+ return ret;
+}
+/*
+** Assuming all locks on tracee_p on entry
+**
+** Changes tracee_p->trace_flags and tracee_p->tracer_proc
+** according to input disable/enable flags and tracer.
+**
+** Returns am_true|am_false on success, am_true if value changed,
+** returns fail_term on failure. Fails if tracer pid or port is invalid.
+*/
+static Eterm
+set_match_trace(Process *tracee_p, Eterm fail_term, Eterm tracer,
+ Uint d_flags, Uint e_flags) {
+ Eterm ret = fail_term;
+ Process *tracer_p;
+
+ ERTS_SMP_LC_ASSERT(ERTS_PROC_LOCKS_ALL ==
+ erts_proc_lc_my_proc_locks(tracee_p));
+
+ if (is_internal_pid(tracer)
+ && (tracer_p =
+ erts_pid2proc(tracee_p, ERTS_PROC_LOCKS_ALL,
+ tracer, ERTS_PROC_LOCKS_ALL))) {
+ if (tracee_p != tracer_p) {
+ ret = set_tracee_flags(tracee_p, tracer, d_flags, e_flags);
+ tracer_p->trace_flags |= tracee_p->trace_flags ? F_TRACER : 0;
+ erts_smp_proc_unlock(tracer_p, ERTS_PROC_LOCKS_ALL);
+ }
+ } else if (is_internal_port(tracer)) {
+ Port *tracer_port =
+ erts_id2port(tracer, tracee_p, ERTS_PROC_LOCKS_ALL);
+ if (tracer_port) {
+ if (! INVALID_TRACER_PORT(tracer_port, tracer)) {
+ ret = set_tracee_flags(tracee_p, tracer, d_flags, e_flags);
+ }
+ erts_smp_port_unlock(tracer_port);
+ }
+ } else {
+ ASSERT(is_nil(tracer));
+ ret = set_tracee_flags(tracee_p, tracer, d_flags, e_flags);
+ }
+ return ret;
+}
+
+
+/* Type checking... */
+
+#define BOXED_IS_TUPLE(Boxed) is_arity_value(*boxed_val((Boxed)))
+
+/*
+**
+** Types and enum's (compiled matches)
+**
+*/
+
+/*
+** match VM instructions
+*/
+typedef enum {
+ matchArray, /* Only when parameter is an array (DCOMP_TRACE) */
+ matchArrayBind, /* ------------- " ------------ */
+ matchTuple,
+ matchPushT,
+ matchPushL,
+ matchPop,
+ matchBind,
+ matchCmp,
+ matchEqBin,
+ matchEqFloat,
+ matchEqBig,
+ matchEqRef,
+ matchEq,
+ matchList,
+ matchSkip,
+ matchPushC,
+ matchConsA, /* Car is below Cdr */
+ matchConsB, /* Cdr is below Car (unusual) */
+ matchMkTuple,
+ matchCall0,
+ matchCall1,
+ matchCall2,
+ matchCall3,
+ matchPushV,
+ matchPushExpr, /* Push the whole expression we're matching ('$_') */
+ matchPushArrayAsList, /* Only when parameter is an Array and
+ not an erlang term (DCOMP_TRACE) */
+ matchPushArrayAsListU, /* As above but unknown size */
+ matchTrue,
+ matchOr,
+ matchAnd,
+ matchOrElse,
+ matchAndAlso,
+ matchJump,
+ matchSelf,
+ matchWaste,
+ matchReturn,
+ matchProcessDump,
+ matchDisplay,
+ matchIsSeqTrace,
+ matchSetSeqToken,
+ matchGetSeqToken,
+ matchSetReturnTrace,
+ matchSetExceptionTrace,
+ matchCatch,
+ matchEnableTrace,
+ matchDisableTrace,
+ matchEnableTrace2,
+ matchDisableTrace2,
+ matchTryMeElse,
+ matchCaller,
+ matchHalt,
+ matchSilent,
+ matchSetSeqTokenFake,
+ matchTrace2,
+ matchTrace3
+} MatchOps;
+
+/*
+** Guard bif's
+*/
+
+typedef struct dmc_guard_bif {
+ Eterm name; /* atom */
+ void *biff;
+ /* BIF_RETTYPE (*biff)(); */
+ int arity;
+ Uint32 flags;
+} DMCGuardBif;
+
+/*
+** Error information (for lint)
+*/
+
+/*
+** Type declarations for stacks
+*/
+DMC_DECLARE_STACK_TYPE(Eterm);
+
+DMC_DECLARE_STACK_TYPE(Uint);
+
+DMC_DECLARE_STACK_TYPE(unsigned);
+
+/*
+** Data about the heap during compilation
+*/
+
+typedef struct DMCHeap {
+ int size;
+ unsigned def[DMC_DEFAULT_SIZE];
+ unsigned *data;
+ int used;
+} DMCHeap;
+
+/*
+** Return values from sub compilation steps (guard compilation)
+*/
+
+typedef enum dmc_ret {
+ retOk,
+ retFail,
+ retRestart
+} DMCRet;
+
+/*
+** Diverse context information
+*/
+
+typedef struct dmc_context {
+ int stack_need;
+ int stack_used;
+ ErlHeapFragment *save;
+ ErlHeapFragment *copy;
+ Eterm *matchexpr;
+ Eterm *guardexpr;
+ Eterm *bodyexpr;
+ int num_match;
+ int current_match;
+ int eheap_need;
+ Uint cflags;
+ int is_guard; /* 1 if in guard, 0 if in body */
+ int special; /* 1 if the head in the match was a single expression */
+ DMCErrInfo *err_info;
+} DMCContext;
+
+/*
+**
+** Global variables
+**
+*/
+
+/*
+** Internal
+*/
+
+/*
+** The pseudo process used by the VM (pam).
+*/
+
+#define ERTS_DEFAULT_MS_HEAP_SIZE 128
+
+typedef struct {
+ Process process;
+ Eterm *heap;
+ Eterm default_heap[ERTS_DEFAULT_MS_HEAP_SIZE];
+} ErtsMatchPseudoProcess;
+
+
+#ifdef ERTS_SMP
+static erts_smp_tsd_key_t match_pseudo_process_key;
+#else
+static ErtsMatchPseudoProcess *match_pseudo_process;
+#endif
+
+static ERTS_INLINE void
+cleanup_match_pseudo_process(ErtsMatchPseudoProcess *mpsp, int keep_heap)
+{
+ if (mpsp->process.mbuf
+ || mpsp->process.off_heap.mso
+#ifndef HYBRID /* FIND ME! */
+ || mpsp->process.off_heap.funs
+#endif
+ || mpsp->process.off_heap.externals) {
+ erts_cleanup_empty_process(&mpsp->process);
+ }
+#ifdef DEBUG
+ else {
+ erts_debug_verify_clean_empty_process(&mpsp->process);
+ }
+#endif
+ if (!keep_heap) {
+ if (mpsp->heap != &mpsp->default_heap[0]) {
+ /* Have to be done *after* call to erts_cleanup_empty_process() */
+ erts_free(ERTS_ALC_T_DB_MS_RUN_HEAP, (void *) mpsp->heap);
+ mpsp->heap = &mpsp->default_heap[0];
+ }
+#ifdef DEBUG
+ else {
+ int i;
+ for (i = 0; i < ERTS_DEFAULT_MS_HEAP_SIZE; i++) {
+#ifdef ARCH_64
+ mpsp->default_heap[i] = (Eterm) 0xdeadbeefdeadbeef;
+#else
+ mpsp->default_heap[i] = (Eterm) 0xdeadbeef;
+#endif
+ }
+ }
+#endif
+ }
+}
+
+static ErtsMatchPseudoProcess *
+create_match_pseudo_process(void)
+{
+ ErtsMatchPseudoProcess *mpsp;
+ mpsp = (ErtsMatchPseudoProcess *)erts_alloc(ERTS_ALC_T_DB_MS_PSDO_PROC,
+ sizeof(ErtsMatchPseudoProcess));
+ erts_init_empty_process(&mpsp->process);
+ mpsp->heap = &mpsp->default_heap[0];
+ return mpsp;
+}
+
+static ERTS_INLINE ErtsMatchPseudoProcess *
+get_match_pseudo_process(Process *c_p, Uint heap_size)
+{
+ ErtsMatchPseudoProcess *mpsp;
+#ifdef ERTS_SMP
+ mpsp = (ErtsMatchPseudoProcess *) c_p->scheduler_data->match_pseudo_process;
+ if (mpsp)
+ cleanup_match_pseudo_process(mpsp, 0);
+ else {
+ ASSERT(erts_smp_tsd_get(match_pseudo_process_key) == NULL);
+ mpsp = create_match_pseudo_process();
+ c_p->scheduler_data->match_pseudo_process = (void *) mpsp;
+ erts_smp_tsd_set(match_pseudo_process_key, (void *) mpsp);
+ }
+ ASSERT(mpsp == erts_smp_tsd_get(match_pseudo_process_key));
+ mpsp->process.scheduler_data = c_p->scheduler_data;
+#else
+ mpsp = match_pseudo_process;
+ cleanup_match_pseudo_process(mpsp, 0);
+#endif
+ if (heap_size > ERTS_DEFAULT_MS_HEAP_SIZE)
+ mpsp->heap = (Eterm *) erts_alloc(ERTS_ALC_T_DB_MS_RUN_HEAP,
+ heap_size*sizeof(Uint));
+ else {
+ ASSERT(mpsp->heap == &mpsp->default_heap[0]);
+ }
+ return mpsp;
+}
+
+#ifdef ERTS_SMP
+static void
+destroy_match_pseudo_process(void)
+{
+ ErtsMatchPseudoProcess *mpsp;
+ mpsp = (ErtsMatchPseudoProcess *)erts_smp_tsd_get(match_pseudo_process_key);
+ if (mpsp) {
+ cleanup_match_pseudo_process(mpsp, 0);
+ erts_free(ERTS_ALC_T_DB_MS_PSDO_PROC, (void *) mpsp);
+ erts_smp_tsd_set(match_pseudo_process_key, (void *) NULL);
+ }
+}
+#endif
+
+static
+void
+match_pseudo_process_init(void)
+{
+#ifdef ERTS_SMP
+ erts_smp_tsd_key_create(&match_pseudo_process_key);
+ erts_smp_install_exit_handler(destroy_match_pseudo_process);
+#else
+ match_pseudo_process = create_match_pseudo_process();
+#endif
+}
+
+void
+erts_match_set_release_result(Process* c_p)
+{
+ (void) get_match_pseudo_process(c_p, 0); /* Clean it up */
+}
+
+/* The trace control word. */
+
+static erts_smp_atomic_t trace_control_word;
+
+
+Eterm
+erts_ets_copy_object(Eterm obj, Process* to)
+{
+ Uint size = size_object(obj);
+ Eterm* hp = HAlloc(to, size);
+ Eterm res;
+
+ res = copy_struct(obj, size, &hp, &MSO(to));
+#ifdef DEBUG
+ if (eq(obj, res) == 0) {
+ erl_exit(1, "copy not equal to source\n");
+ }
+#endif
+ return res;
+}
+
+/* This needs to be here, before the bif table... */
+
+static Eterm db_set_trace_control_word_fake_1(Process *p, Eterm val);
+
+/*
+** The table of callable bif's, i e guard bif's and
+** some special animals that can provide us with trace
+** information. This array is sorted on init.
+*/
+static DMCGuardBif guard_tab[] =
+{
+ {
+ am_is_atom,
+ &is_atom_1,
+ 1,
+ DBIF_ALL
+ },
+ {
+ am_is_float,
+ &is_float_1,
+ 1,
+ DBIF_ALL
+ },
+ {
+ am_is_integer,
+ &is_integer_1,
+ 1,
+ DBIF_ALL
+ },
+ {
+ am_is_list,
+ &is_list_1,
+ 1,
+ DBIF_ALL
+ },
+ {
+ am_is_number,
+ &is_number_1,
+ 1,
+ DBIF_ALL
+ },
+ {
+ am_is_pid,
+ &is_pid_1,
+ 1,
+ DBIF_ALL
+ },
+ {
+ am_is_port,
+ &is_port_1,
+ 1,
+ DBIF_ALL
+ },
+ {
+ am_is_reference,
+ &is_reference_1,
+ 1,
+ DBIF_ALL
+ },
+ {
+ am_is_tuple,
+ &is_tuple_1,
+ 1,
+ DBIF_ALL
+ },
+ {
+ am_is_binary,
+ &is_binary_1,
+ 1,
+ DBIF_ALL
+ },
+ {
+ am_is_function,
+ &is_function_1,
+ 1,
+ DBIF_ALL
+ },
+ {
+ am_is_record,
+ &is_record_3,
+ 3,
+ DBIF_ALL
+ },
+ {
+ am_abs,
+ &abs_1,
+ 1,
+ DBIF_ALL
+ },
+ {
+ am_element,
+ &element_2,
+ 2,
+ DBIF_ALL
+ },
+ {
+ am_hd,
+ &hd_1,
+ 1,
+ DBIF_ALL
+ },
+ {
+ am_length,
+ &length_1,
+ 1,
+ DBIF_ALL
+ },
+ {
+ am_node,
+ &node_1,
+ 1,
+ DBIF_ALL
+ },
+ {
+ am_node,
+ &node_0,
+ 0,
+ DBIF_ALL
+ },
+ {
+ am_round,
+ &round_1,
+ 1,
+ DBIF_ALL
+ },
+ {
+ am_size,
+ &size_1,
+ 1,
+ DBIF_ALL
+ },
+ {
+ am_bit_size,
+ &bit_size_1,
+ 1,
+ DBIF_ALL
+ },
+ {
+ am_tl,
+ &tl_1,
+ 1,
+ DBIF_ALL
+ },
+ {
+ am_trunc,
+ &trunc_1,
+ 1,
+ DBIF_ALL
+ },
+ {
+ am_float,
+ &float_1,
+ 1,
+ DBIF_ALL
+ },
+ {
+ am_Plus,
+ &splus_1,
+ 1,
+ DBIF_ALL
+ },
+ {
+ am_Minus,
+ &sminus_1,
+ 1,
+ DBIF_ALL
+ },
+ {
+ am_Plus,
+ &splus_2,
+ 2,
+ DBIF_ALL
+ },
+ {
+ am_Minus,
+ &sminus_2,
+ 2,
+ DBIF_ALL
+ },
+ {
+ am_Times,
+ &stimes_2,
+ 2,
+ DBIF_ALL
+ },
+ {
+ am_Div,
+ &div_2,
+ 2,
+ DBIF_ALL
+ },
+ {
+ am_div,
+ &intdiv_2,
+ 2,
+ DBIF_ALL
+ },
+ {
+ am_rem,
+ &rem_2,
+ 2,
+ DBIF_ALL
+ },
+ {
+ am_band,
+ &band_2,
+ 2,
+ DBIF_ALL
+ },
+ {
+ am_bor,
+ &bor_2,
+ 2,
+ DBIF_ALL
+ },
+ {
+ am_bxor,
+ &bxor_2,
+ 2,
+ DBIF_ALL
+ },
+ {
+ am_bnot,
+ &bnot_1,
+ 1,
+ DBIF_ALL
+ },
+ {
+ am_bsl,
+ &bsl_2,
+ 2,
+ DBIF_ALL
+ },
+ {
+ am_bsr,
+ &bsr_2,
+ 2,
+ DBIF_ALL
+ },
+ {
+ am_Gt,
+ &sgt_2,
+ 2,
+ DBIF_ALL
+ },
+ {
+ am_Ge,
+ &sge_2,
+ 2,
+ DBIF_ALL
+ },
+ {
+ am_Lt,
+ &slt_2,
+ 2,
+ DBIF_ALL
+ },
+ {
+ am_Le,
+ &sle_2,
+ 2,
+ DBIF_ALL
+ },
+ {
+ am_Eq,
+ &seq_2,
+ 2,
+ DBIF_ALL
+ },
+ {
+ am_Eqeq,
+ &seqeq_2,
+ 2,
+ DBIF_ALL
+ },
+ {
+ am_Neq,
+ &sneq_2,
+ 2,
+ DBIF_ALL
+ },
+ {
+ am_Neqeq,
+ &sneqeq_2,
+ 2,
+ DBIF_ALL
+ },
+ {
+ am_not,
+ &not_1,
+ 1,
+ DBIF_ALL
+ },
+ {
+ am_xor,
+ &xor_2,
+ 2,
+ DBIF_ALL
+ },
+ {
+ am_get_tcw,
+ &db_get_trace_control_word_0,
+ 0,
+ DBIF_TRACE_GUARD | DBIF_TRACE_BODY
+ },
+ {
+ am_set_tcw,
+ &db_set_trace_control_word_1,
+ 1,
+ DBIF_TRACE_BODY
+ },
+ {
+ am_set_tcw_fake,
+ &db_set_trace_control_word_fake_1,
+ 1,
+ DBIF_TRACE_BODY
+ }
+};
+
+/*
+** Exported
+*/
+Eterm db_am_eot; /* Atom '$end_of_table' */
+
+/*
+** Forward decl's
+*/
+
+
+/*
+** ... forwards for compiled matches
+*/
+/* Utility code */
+static DMCGuardBif *dmc_lookup_bif(Eterm t, int arity);
+#ifdef DMC_DEBUG
+static Eterm dmc_lookup_bif_reversed(void *f);
+#endif
+static int cmp_uint(void *a, void *b);
+static int cmp_guard_bif(void *a, void *b);
+static int match_compact(ErlHeapFragment *expr, DMCErrInfo *err_info);
+static Uint my_size_object(Eterm t);
+static Eterm my_copy_struct(Eterm t, Eterm **hp, ErlOffHeap* off_heap);
+
+/* Guard compilation */
+static void do_emit_constant(DMCContext *context, DMC_STACK_TYPE(Uint) *text,
+ Eterm t);
+static DMCRet dmc_list(DMCContext *context,
+ DMCHeap *heap,
+ DMC_STACK_TYPE(Uint) *text,
+ Eterm t,
+ int *constant);
+static DMCRet dmc_tuple(DMCContext *context,
+ DMCHeap *heap,
+ DMC_STACK_TYPE(Uint) *text,
+ Eterm t,
+ int *constant);
+static DMCRet dmc_variable(DMCContext *context,
+ DMCHeap *heap,
+ DMC_STACK_TYPE(Uint) *text,
+ Eterm t,
+ int *constant);
+static DMCRet dmc_fun(DMCContext *context,
+ DMCHeap *heap,
+ DMC_STACK_TYPE(Uint) *text,
+ Eterm t,
+ int *constant);
+static DMCRet dmc_expr(DMCContext *context,
+ DMCHeap *heap,
+ DMC_STACK_TYPE(Uint) *text,
+ Eterm t,
+ int *constant);
+static DMCRet compile_guard_expr(DMCContext *context,
+ DMCHeap *heap,
+ DMC_STACK_TYPE(Uint) *text,
+ Eterm t);
+/* match expression subroutine */
+static DMCRet dmc_one_term(DMCContext *context,
+ DMCHeap *heap,
+ DMC_STACK_TYPE(Eterm) *stack,
+ DMC_STACK_TYPE(Uint) *text,
+ Eterm c);
+
+
+#ifdef DMC_DEBUG
+static int test_disassemble_next = 0;
+static void db_match_dis(Binary *prog);
+#define TRACE erts_fprintf(stderr,"Trace: %s:%d\n",__FILE__,__LINE__)
+#define FENCE_PATTERN_SIZE 1
+#define FENCE_PATTERN 0xDEADBEEFUL
+#else
+#define TRACE /* Nothing */
+#define FENCE_PATTERN_SIZE 0
+#endif
+static void add_dmc_err(DMCErrInfo *err_info,
+ char *str,
+ int variable,
+ Eterm term,
+ DMCErrorSeverity severity);
+
+static Eterm dpm_array_to_list(Process *psp, Eterm *arr, int arity);
+
+static Eterm match_spec_test(Process *p, Eterm against, Eterm spec, int trace);
+
+static Eterm seq_trace_fake(Process *p, Eterm arg1);
+
+
+/*
+** Interface routines.
+*/
+
+/*
+** Pseudo BIF:s to be callable from the PAM VM.
+*/
+
+BIF_RETTYPE db_get_trace_control_word_0(Process *p)
+{
+ Uint32 tcw = (Uint32) erts_smp_atomic_read(&trace_control_word);
+ BIF_RET(erts_make_integer((Uint) tcw, p));
+}
+
+BIF_RETTYPE db_set_trace_control_word_1(Process *p, Eterm new)
+{
+ Uint val;
+ Uint32 old_tcw;
+ if (!term_to_Uint(new, &val))
+ BIF_ERROR(p, BADARG);
+ if (val != ((Uint32)val))
+ BIF_ERROR(p, BADARG);
+
+ old_tcw = (Uint32) erts_smp_atomic_xchg(&trace_control_word, (long) val);
+ BIF_RET(erts_make_integer((Uint) old_tcw, p));
+}
+
+static Eterm db_set_trace_control_word_fake_1(Process *p, Eterm new)
+{
+ Uint val;
+ if (!term_to_Uint(new, &val))
+ BIF_ERROR(p, BADARG);
+ if (val != ((Uint32)val))
+ BIF_ERROR(p, BADARG);
+ BIF_RET(db_get_trace_control_word_0(p));
+}
+
+/*
+** The API used by the tracer (declared in global.h):
+*/
+
+/*
+** Matchexpr is a list of tuples containing match-code, i e:
+**
+** Matchexpr = [{Pattern, Guards, Body}, ...]
+** Pattern = [ PatternExpr , ...]
+** PatternExpr = Constant | PatternTuple | PatternList | Variable
+** Constant = Any erlang term
+** PatternTuple = { PatternExpr ... }
+** PatternList = [ PatternExpr ]
+** Variable = '$' ++ <number>
+** Guards = [Guard ...]
+** Guard = {GuardFunc, GuardExpr, ...}
+** GuardExpr = BoundVariable | Guard | GuardList | GuardTuple | ConstExpr
+** BoundVariable = Variable (existing in Pattern)
+** GuardList = [ GuardExpr , ... ]
+** GuardTuple = {{ GuardExpr, ... }}
+** ConstExpr = {const, Constant}
+** GuardFunc = is_list | .... | element | ...
+** Body = [ BodyExpr, ... ]
+** BodyExpr = GuardExpr | { BodyFunc, GuardExpr, ... }
+** BodyFunc = return_trace | seq_trace | trace | ...
+** - or something like that...
+*/
+
+
+Eterm erts_match_set_get_source(Binary *mpsp)
+{
+ MatchProg *prog = Binary2MatchProg(mpsp);
+ return prog->saved_program;
+}
+
+/* This one is for the tracing */
+Binary *erts_match_set_compile(Process *p, Eterm matchexpr) {
+ Binary *bin;
+ Uint sz;
+ Eterm *hp;
+
+ bin = db_match_set_compile(p, matchexpr, DCOMP_TRACE);
+ if (bin != NULL) {
+ MatchProg *prog = Binary2MatchProg(bin);
+ sz = size_object(matchexpr);
+ prog->saved_program_buf = new_message_buffer(sz);
+ hp = prog->saved_program_buf->mem;
+ prog->saved_program =
+ copy_struct(matchexpr, sz, &hp,
+ &(prog->saved_program_buf->off_heap));
+ }
+ return bin;
+}
+
+Binary *db_match_set_compile(Process *p, Eterm matchexpr,
+ Uint flags)
+{
+ Eterm l;
+ Eterm t;
+ Eterm l2;
+ Eterm *tp;
+ Eterm *hp;
+ int n = 0;
+ int num_heads;
+ int i;
+ Binary *mps = NULL;
+ int compiled = 0;
+ Eterm *matches,*guards, *bodies;
+ Eterm *buff;
+ Eterm sbuff[15];
+
+ if (!is_list(matchexpr))
+ return NULL;
+ num_heads = 0;
+ for (l = matchexpr; is_list(l); l = CDR(list_val(l)))
+ ++num_heads;
+
+ if (l != NIL) /* proper list... */
+ return NULL;
+
+ if (num_heads > 5) {
+ buff = erts_alloc(ERTS_ALC_T_DB_TMP,
+ sizeof(Eterm) * num_heads * 3);
+ } else {
+ buff = sbuff;
+ }
+
+ matches = buff;
+ guards = buff + num_heads;
+ bodies = buff + (num_heads * 2);
+
+ i = 0;
+ for (l = matchexpr; is_list(l); l = CDR(list_val(l))) {
+ t = CAR(list_val(l));
+ if (!is_tuple(t) || arityval((tp = tuple_val(t))[0]) != 3) {
+ goto error;
+ }
+ if (!(flags & DCOMP_TRACE) || (!is_list(tp[1]) &&
+ !is_nil(tp[1]))) {
+ t = tp[1];
+ } else {
+ /* This is when tracing, the parameter is a list,
+ that I convert to a tuple and that is matched
+ against an array (strange, but gives the semantics
+ of matching against a parameter list) */
+ n = 0;
+ for (l2 = tp[1]; is_list(l2); l2 = CDR(list_val(l2))) {
+ ++n;
+ }
+ if (l2 != NIL) {
+ goto error;
+ }
+ hp = HAlloc(p, n + 1);
+ t = make_tuple(hp);
+ *hp++ = make_arityval((Uint) n);
+ l2 = tp[1];
+ while (n--) {
+ *hp++ = CAR(list_val(l2));
+ l2 = CDR(list_val(l2));
+ }
+ }
+ matches[i] = t;
+ guards[i] = tp[2];
+ bodies[i] = tp[3];
+ ++i;
+ }
+ if ((mps = db_match_compile(matches, guards, bodies,
+ num_heads,
+ flags,
+ NULL)) == NULL) {
+ goto error;
+ }
+ compiled = 1;
+ if (buff != sbuff) {
+ erts_free(ERTS_ALC_T_DB_TMP, buff);
+ }
+ return mps;
+
+error:
+ if (compiled) {
+ erts_bin_free(mps);
+ }
+ if (buff != sbuff) {
+ erts_free(ERTS_ALC_T_DB_TMP, buff);
+ }
+ return NULL;
+}
+
+/* This is used when tracing */
+Eterm erts_match_set_lint(Process *p, Eterm matchexpr) {
+ return db_match_set_lint(p, matchexpr, DCOMP_TRACE);
+}
+
+Eterm db_match_set_lint(Process *p, Eterm matchexpr, Uint flags)
+{
+ Eterm l;
+ Eterm t;
+ Eterm l2;
+ Eterm *tp;
+ Eterm *hp;
+ DMCErrInfo *err_info = db_new_dmc_err_info();
+ Eterm ret;
+ int n = 0;
+ int num_heads;
+ Binary *mp;
+ Eterm *matches,*guards, *bodies;
+ Eterm sbuff[15];
+ Eterm *buff = sbuff;
+ int i;
+
+ if (!is_list(matchexpr)) {
+ add_dmc_err(err_info, "Match programs are not in a list.",
+ -1, 0UL, dmcError);
+ goto done;
+ }
+ num_heads = 0;
+ for (l = matchexpr; is_list(l); l = CDR(list_val(l)))
+ ++num_heads;
+
+ if (l != NIL) { /* proper list... */
+ add_dmc_err(err_info, "Match programs are not in a proper "
+ "list.",
+ -1, 0UL, dmcError);
+ goto done;
+ }
+
+ if (num_heads > 5) {
+ buff = erts_alloc(ERTS_ALC_T_DB_TMP,
+ sizeof(Eterm) * num_heads * 3);
+ }
+
+ matches = buff;
+ guards = buff + num_heads;
+ bodies = buff + (num_heads * 2);
+
+ i = 0;
+ for (l = matchexpr; is_list(l); l = CDR(list_val(l))) {
+ t = CAR(list_val(l));
+ if (!is_tuple(t) || arityval((tp = tuple_val(t))[0]) != 3) {
+ add_dmc_err(err_info,
+ "Match program part is not a tuple of "
+ "arity 3.",
+ -1, 0UL, dmcError);
+ goto done;
+ }
+ if (!(flags & DCOMP_TRACE) || (!is_list(tp[1]) &&
+ !is_nil(tp[1]))) {
+ t = tp[1];
+ } else {
+ n = 0;
+ for (l2 = tp[1]; is_list(l2); l2 = CDR(list_val(l2))) {
+ ++n;
+ }
+ if (l2 != NIL) {
+ add_dmc_err(err_info,
+ "Match expression part %T is not a "
+ "proper list.",
+ -1, tp[1], dmcError);
+
+ goto done;
+ }
+ hp = HAlloc(p, n + 1);
+ t = make_tuple(hp);
+ *hp++ = make_arityval((Uint) n);
+ l2 = tp[1];
+ while (n--) {
+ *hp++ = CAR(list_val(l2));
+ l2 = CDR(list_val(l2));
+ }
+ }
+ matches[i] = t;
+ guards[i] = tp[2];
+ bodies[i] = tp[3];
+ ++i;
+ }
+ mp = db_match_compile(matches, guards, bodies, num_heads,
+ flags, err_info);
+ if (mp != NULL) {
+ erts_bin_free(mp);
+ }
+done:
+ ret = db_format_dmc_err_info(p, err_info);
+ db_free_dmc_err_info(err_info);
+ if (buff != sbuff) {
+ erts_free(ERTS_ALC_T_DB_TMP, buff);
+ }
+ return ret;
+}
+
+Eterm erts_match_set_run(Process *p, Binary *mpsp,
+ Eterm *args, int num_args,
+ Uint32 *return_flags)
+{
+ Eterm ret;
+
+ ret = db_prog_match(p, mpsp,
+ (Eterm) args,
+ num_args, return_flags);
+#if defined(HARDDEBUG)
+ if (is_non_value(ret)) {
+ erts_fprintf(stderr, "Failed\n");
+ } else {
+ erts_fprintf(stderr, "Returning : %T\n", ret);
+ }
+#endif
+ return ret;
+ /* Returns
+ * THE_NON_VALUE if no match
+ * am_false if {message,false} has been called,
+ * am_true if {message,_} has not been called or
+ * if {message,true} has been called,
+ * Msg if {message,Msg} has been called.
+ */
+}
+
+/*
+** API Used by other erl_db modules.
+*/
+
+void db_initialize_util(void){
+ qsort(guard_tab,
+ sizeof(guard_tab) / sizeof(DMCGuardBif),
+ sizeof(DMCGuardBif),
+ (int (*)(const void *, const void *)) &cmp_guard_bif);
+ match_pseudo_process_init();
+ erts_smp_atomic_init(&trace_control_word, 0);
+}
+
+
+
+Eterm db_getkey(int keypos, Eterm obj)
+{
+ if (is_tuple(obj)) {
+ Eterm *tptr = tuple_val(obj);
+ if (arityval(*tptr) >= keypos)
+ return *(tptr + keypos);
+ }
+ return THE_NON_VALUE;
+}
+
+/*
+** Matching compiled (executed by "Pam" :-)
+*/
+
+/*
+** The actual compiling of the match expression and the guards
+*/
+Binary *db_match_compile(Eterm *matchexpr,
+ Eterm *guards,
+ Eterm *body,
+ int num_progs,
+ Uint flags,
+ DMCErrInfo *err_info)
+{
+ DMCHeap heap;
+ DMC_STACK_TYPE(Eterm) stack;
+ DMC_STACK_TYPE(Uint) text;
+ DMCContext context;
+ MatchProg *ret = NULL;
+ Eterm t;
+ Uint i;
+ Uint num_iters;
+ int structure_checked;
+ DMCRet res;
+ int current_try_label;
+ Uint max_eheap_need;
+ Binary *bp = NULL;
+ unsigned clause_start;
+
+ DMC_INIT_STACK(stack);
+ DMC_INIT_STACK(text);
+
+ context.stack_need = context.stack_used = 0;
+ context.save = context.copy = NULL;
+ context.num_match = num_progs;
+ context.matchexpr = matchexpr;
+ context.guardexpr = guards;
+ context.bodyexpr = body;
+ context.eheap_need = 0;
+ context.err_info = err_info;
+ context.cflags = flags;
+
+ heap.size = DMC_DEFAULT_SIZE;
+ heap.data = heap.def;
+
+ /*
+ ** Compile the match expression
+ */
+restart:
+ heap.used = 0;
+ max_eheap_need = 0;
+ for (context.current_match = 0;
+ context.current_match < num_progs;
+ ++context.current_match) { /* This loop is long,
+ too long */
+ memset(heap.data, 0, heap.size * sizeof(*heap.data));
+ t = context.matchexpr[context.current_match];
+ context.stack_used = 0;
+ context.eheap_need = 0;
+ structure_checked = 0;
+ if (context.current_match < num_progs - 1) {
+ DMC_PUSH(text,matchTryMeElse);
+ current_try_label = DMC_STACK_NUM(text);
+ DMC_PUSH(text,0);
+ } else {
+ current_try_label = -1;
+ }
+ clause_start = DMC_STACK_NUM(text); /* the "special" test needs it */
+ DMC_PUSH(stack,NIL);
+ for (;;) {
+ switch (t & _TAG_PRIMARY_MASK) {
+ case TAG_PRIMARY_BOXED:
+ if (!BOXED_IS_TUPLE(t)) {
+ goto simple_term;
+ }
+ num_iters = arityval(*tuple_val(t));
+ if (!structure_checked) { /* i.e. we did not
+ pop it */
+ DMC_PUSH(text,matchTuple);
+ DMC_PUSH(text,num_iters);
+ }
+ structure_checked = 0;
+ for (i = 1; i <= num_iters; ++i) {
+ if ((res = dmc_one_term(&context,
+ &heap,
+ &stack,
+ &text,
+ tuple_val(t)[i]))
+ != retOk) {
+ if (res == retRestart) {
+ goto restart; /* restart the
+ surrounding
+ loop */
+ } else goto error;
+ }
+ }
+ break;
+ case TAG_PRIMARY_LIST:
+ if (!structure_checked) {
+ DMC_PUSH(text, matchList);
+ }
+ structure_checked = 0; /* Whatever it is, we did
+ not pop it */
+ if ((res = dmc_one_term(&context, &heap, &stack,
+ &text, CAR(list_val(t))))
+ != retOk) {
+ if (res == retRestart) {
+ goto restart;
+ } else goto error;
+ }
+ t = CDR(list_val(t));
+ continue;
+ default: /* Nil and non proper tail end's or
+ single terms as match
+ expressions */
+ simple_term:
+ structure_checked = 0;
+ if ((res = dmc_one_term(&context, &heap, &stack,
+ &text, t))
+ != retOk) {
+ if (res == retRestart) {
+ goto restart;
+ } else goto error;
+ }
+ break;
+ }
+
+ /* The *program's* stack just *grows* while we are
+ traversing one composite data structure, we can
+ check the stack usage here */
+
+ if (context.stack_used > context.stack_need)
+ context.stack_need = context.stack_used;
+
+ /* We are at the end of one composite data structure,
+ pop sub structures and emit a matchPop instruction
+ (or break) */
+ if ((t = DMC_POP(stack)) == NIL) {
+ break;
+ } else {
+ DMC_PUSH(text, matchPop);
+ structure_checked = 1; /*
+ * Checked with matchPushT
+ * or matchPushL
+ */
+ --(context.stack_used);
+ }
+ }
+
+ /*
+ ** There is one single top variable in the match expression
+ ** iff the text is tho Uint's and the single instruction
+ ** is 'matchBind' or it is only a skip.
+ */
+ context.special =
+ (DMC_STACK_NUM(text) == 2 + clause_start &&
+ DMC_PEEK(text,clause_start) == matchBind) ||
+ (DMC_STACK_NUM(text) == 1 + clause_start &&
+ DMC_PEEK(text, clause_start) == matchSkip);
+
+ if (flags & DCOMP_TRACE) {
+ if (context.special) {
+ if (DMC_PEEK(text, clause_start) == matchBind) {
+ DMC_POKE(text, clause_start, matchArrayBind);
+ }
+ } else {
+ ASSERT(DMC_STACK_NUM(text) >= 1);
+ if (DMC_PEEK(text, clause_start) != matchTuple) {
+ /* If it isn't "special" and the argument is
+ not a tuple, the expression is not valid
+ when matching an array*/
+ if (context.err_info) {
+ add_dmc_err(context.err_info,
+ "Match head is invalid in "
+ "this context.",
+ -1, 0UL,
+ dmcError);
+ }
+ goto error;
+ }
+ DMC_POKE(text, clause_start, matchArray);
+ }
+ }
+
+
+ /*
+ ** ... and the guards
+ */
+ context.is_guard = 1;
+ if (compile_guard_expr
+ (&context,
+ &heap,
+ &text,
+ context.guardexpr[context.current_match]) != retOk)
+ goto error;
+ context.is_guard = 0;
+ if ((context.cflags & DCOMP_TABLE) &&
+ !is_list(context.bodyexpr[context.current_match])) {
+ if (context.err_info) {
+ add_dmc_err(context.err_info,
+ "Body clause does not return "
+ "anything.", -1, 0UL,
+ dmcError);
+ }
+ goto error;
+ }
+ if (compile_guard_expr
+ (&context,
+ &heap,
+ &text,
+ context.bodyexpr[context.current_match]) != retOk)
+ goto error;
+
+ /*
+ * The compilation does not bail out when error information
+ * is requested, so we need to detect that here...
+ */
+ if (context.err_info != NULL &&
+ (context.err_info)->error_added) {
+ goto error;
+ }
+
+
+ /* If the matchprogram comes here, the match is
+ successful */
+ DMC_PUSH(text,matchHalt);
+ /* Fill in try-me-else label if there is one. */
+ if (current_try_label >= 0) {
+ DMC_POKE(text, current_try_label, DMC_STACK_NUM(text));
+ }
+ /* So, how much eheap did this part of the match program need? */
+ if (context.eheap_need > max_eheap_need) {
+ max_eheap_need = context.eheap_need;
+ }
+ } /* for (context.current_match = 0 ...) */
+
+
+ /*
+ ** Done compiling
+ ** Allocate enough space for the program,
+ ** heap size is in 'heap_used', stack size is in 'stack_need'
+ ** and text size is simply DMC_STACK_NUM(text).
+ ** The "program memory" is allocated like this:
+ ** text ----> +-------------+
+ ** | |
+ ** ..........
+ ** +-------------+
+ **
+ ** The heap-eheap-stack block of a MatchProg is nowadays allocated
+ ** when the match program is run (see db_prog_match()).
+ **
+ ** heap ----> +-------------+
+ ** ..........
+ ** eheap ---> + +
+ ** ..........
+ ** stack ---> + +
+ ** ..........
+ ** +-------------+
+ ** The stack is expected to grow towards *higher* adresses.
+ ** A special case is when the match expression is a single binding
+ ** (i.e '$1'), then the field single_variable is set to 1.
+ */
+ bp = erts_create_magic_binary(((sizeof(MatchProg) - sizeof(Uint)) +
+ (DMC_STACK_NUM(text) * sizeof(Uint))),
+ erts_db_match_prog_destructor);
+ ret = Binary2MatchProg(bp);
+ ret->saved_program_buf = NULL;
+ ret->saved_program = NIL;
+ ret->term_save = context.save;
+ ret->num_bindings = heap.used;
+ ret->single_variable = context.special;
+ sys_memcpy(ret->text, DMC_STACK_DATA(text),
+ DMC_STACK_NUM(text) * sizeof(Uint));
+ ret->heap_size = ((heap.used * sizeof(Eterm)) +
+ (max_eheap_need * sizeof(Eterm)) +
+ (context.stack_need * sizeof(Eterm *)) +
+ (3 * (FENCE_PATTERN_SIZE * sizeof(Eterm *))));
+ ret->eheap_offset = heap.used + FENCE_PATTERN_SIZE;
+ ret->stack_offset = ret->eheap_offset + max_eheap_need + FENCE_PATTERN_SIZE;
+#ifdef DMC_DEBUG
+ ret->prog_end = ret->text + DMC_STACK_NUM(text);
+#endif
+
+ /*
+ * Fall through to cleanup code, but context.save should not be free'd
+ */
+ context.save = NULL;
+error: /* Here is were we land when compilation failed. */
+ while (context.save != NULL) {
+ ErlHeapFragment *ll = context.save->next;
+ free_message_buffer(context.save);
+ context.save = ll;
+ }
+ DMC_FREE(stack);
+ DMC_FREE(text);
+ if (context.copy != NULL)
+ free_message_buffer(context.copy);
+ if (heap.data != heap.def)
+ erts_free(ERTS_ALC_T_DB_MS_CMPL_HEAP, (void *) heap.data);
+ return bp;
+}
+
+/*
+** Free a match program (in a binary)
+*/
+void erts_db_match_prog_destructor(Binary *bprog)
+{
+ MatchProg *prog;
+ ErlHeapFragment *tmp, *ll;
+ if (bprog == NULL)
+ return;
+ prog = Binary2MatchProg(bprog);
+ tmp = prog->term_save;
+ while (tmp != NULL) {
+ ll = tmp->next;
+ free_message_buffer(tmp);
+ tmp = ll;
+ }
+ if (prog->saved_program_buf != NULL)
+ free_message_buffer(prog->saved_program_buf);
+}
+
+void
+erts_match_prog_foreach_offheap(Binary *bprog,
+ void (*func)(ErlOffHeap *, void *),
+ void *arg)
+{
+ MatchProg *prog;
+ ErlHeapFragment *tmp;
+ if (bprog == NULL)
+ return;
+ prog = Binary2MatchProg(bprog);
+ tmp = prog->term_save;
+ while (tmp) {
+ (*func)(&(tmp->off_heap), arg);
+ tmp = tmp->next;
+ }
+ if (prog->saved_program_buf)
+ (*func)(&(prog->saved_program_buf->off_heap), arg);
+}
+
+/*
+** This is not the most efficient way to do it, but it's a rare
+** and not especially nice case when this is used.
+*/
+static Eterm dpm_array_to_list(Process *psp, Eterm *arr, int arity)
+{
+ Eterm *hp = HAlloc(psp, arity * 2);
+ Eterm ret = NIL;
+ while (--arity >= 0) {
+ ret = CONS(hp, arr[arity], ret);
+ hp += 2;
+ }
+ return ret;
+}
+/*
+** Execution of the match program, this is Pam.
+** May return THE_NON_VALUE, which is a bailout.
+** the para meter 'arity' is only used if 'term' is actually an array,
+** i.e. 'DCOMP_TRACE' was specified
+*/
+Eterm db_prog_match(Process *c_p, Binary *bprog, Eterm term,
+ int arity,
+ Uint32 *return_flags)
+{
+ MatchProg *prog = Binary2MatchProg(bprog);
+ Eterm *ep;
+ Eterm *tp;
+ Eterm t;
+ Eterm **sp;
+ Eterm *esp;
+ Eterm *hp;
+ Uint *pc = prog->text;
+ Eterm *ehp;
+ Eterm ret;
+ Uint n = 0; /* To avoid warning. */
+ int i;
+ unsigned do_catch;
+ ErtsMatchPseudoProcess *mpsp;
+ Process *psp;
+ Process *tmpp;
+ Process *current_scheduled;
+ ErtsSchedulerData *esdp;
+ Eterm (*bif)(Process*, ...);
+ int fail_label;
+ int atomic_trace;
+#ifdef DMC_DEBUG
+ unsigned long *heap_fence;
+ unsigned long *eheap_fence;
+ unsigned long *stack_fence;
+ Uint save_op;
+#endif /* DMC_DEBUG */
+
+ mpsp = get_match_pseudo_process(c_p, prog->heap_size);
+ psp = &mpsp->process;
+
+ /* We need to lure the scheduler into believing in the pseudo process,
+ because of floating point exceptions. Do *after* mpsp is set!!! */
+
+ esdp = ERTS_GET_SCHEDULER_DATA_FROM_PROC(c_p);
+ ASSERT(esdp != NULL);
+ current_scheduled = esdp->current_process;
+ esdp->current_process = psp;
+ /* SMP: psp->scheduler_data is set by get_match_pseudo_process */
+
+ atomic_trace = 0;
+#define BEGIN_ATOMIC_TRACE(p) \
+ do { \
+ if (! atomic_trace) { \
+ erts_smp_proc_unlock((p), ERTS_PROC_LOCK_MAIN); \
+ erts_smp_block_system(0); \
+ atomic_trace = !0; \
+ } \
+ } while (0)
+#define END_ATOMIC_TRACE(p) \
+ do { \
+ if (atomic_trace) { \
+ erts_smp_release_system(); \
+ erts_smp_proc_lock((p), ERTS_PROC_LOCK_MAIN); \
+ atomic_trace = 0; \
+ } \
+ } while (0)
+
+#ifdef DMC_DEBUG
+ save_op = 0;
+ heap_fence = (unsigned long *) mpsp->heap + prog->eheap_offset - 1;
+ eheap_fence = (unsigned long *) mpsp->heap + prog->stack_offset - 1;
+ stack_fence = (unsigned long *) mpsp->heap + prog->heap_size - 1;
+ *heap_fence = FENCE_PATTERN;
+ *eheap_fence = FENCE_PATTERN;
+ *stack_fence = FENCE_PATTERN;
+#endif /* DMC_DEBUG */
+
+#ifdef HARDDEBUG
+#define FAIL() {erts_printf("Fail line %d\n",__LINE__); goto fail;}
+#else
+#define FAIL() goto fail
+#endif
+#define FAIL_TERM am_EXIT /* The term to set as return when bif fails and
+ do_catch != 0 */
+
+ *return_flags = 0U;
+
+restart:
+ ep = &term;
+ esp = mpsp->heap + prog->stack_offset;
+ sp = (Eterm **) esp;
+ hp = mpsp->heap;
+ ehp = mpsp->heap + prog->eheap_offset;
+ ret = am_true;
+ do_catch = 0;
+ fail_label = -1;
+
+ for (;;) {
+#ifdef DMC_DEBUG
+ if (*heap_fence != FENCE_PATTERN) {
+ erl_exit(1, "Heap fence overwritten in db_prog_match after op "
+ "0x%08x, overwritten with 0x%08x.", save_op, *heap_fence);
+ }
+ if (*eheap_fence != FENCE_PATTERN) {
+ erl_exit(1, "Eheap fence overwritten in db_prog_match after op "
+ "0x%08x, overwritten with 0x%08x.", save_op,
+ *eheap_fence);
+ }
+ if (*stack_fence != FENCE_PATTERN) {
+ erl_exit(1, "Stack fence overwritten in db_prog_match after op "
+ "0x%08x, overwritten with 0x%08x.", save_op,
+ *stack_fence);
+ }
+ save_op = *pc;
+#endif
+ switch (*pc++) {
+ case matchTryMeElse:
+ fail_label = *pc++;
+ break;
+ case matchArray: /* only when DCOMP_TRACE, is always first
+ instruction. */
+ n = *pc++;
+ if ((int) n != arity)
+ FAIL();
+ ep = (Eterm *) *ep;
+ break;
+ case matchArrayBind: /* When the array size is unknown. */
+ n = *pc++;
+ hp[n] = dpm_array_to_list(psp, (Eterm *) term, arity);
+ break;
+ case matchTuple: /* *ep is a tuple of arity n */
+ if (!is_tuple(*ep))
+ FAIL();
+ ep = tuple_val(*ep);
+ n = *pc++;
+ if (arityval(*ep) != n)
+ FAIL();
+ ++ep;
+ break;
+ case matchPushT: /* *ep is a tuple of arity n,
+ push ptr to first element */
+ if (!is_tuple(*ep))
+ FAIL();
+ tp = tuple_val(*ep);
+ n = *pc++;
+ if (arityval(*tp) != n)
+ FAIL();
+ *sp++ = tp + 1;
+ ++ep;
+ break;
+ case matchList:
+ if (!is_list(*ep))
+ FAIL();
+ ep = list_val(*ep);
+ break;
+ case matchPushL:
+ if (!is_list(*ep))
+ FAIL();
+ *sp++ = list_val(*ep);
+ ++ep;
+ break;
+ case matchPop:
+ ep = *(--sp);
+ break;
+ case matchBind:
+ n = *pc++;
+ hp[n] = *ep++;
+ break;
+ case matchCmp:
+ n = *pc++;
+ if (!eq(hp[n],*ep))
+ FAIL();
+ ++ep;
+ break;
+ case matchEqBin:
+ t = (Eterm) *pc++;
+ if (!eq(*ep,t))
+ FAIL();
+ ++ep;
+ break;
+ case matchEqFloat:
+ if (!is_float(*ep))
+ FAIL();
+ if (memcmp(float_val(*ep) + 1, pc, sizeof(double)))
+ FAIL();
+ pc += 2;
+ ++ep;
+ break;
+ case matchEqRef:
+ if (!is_ref(*ep))
+ FAIL();
+ if (!eq(*ep, make_internal_ref(pc)))
+ FAIL();
+ i = thing_arityval(*pc);
+ pc += i+1;
+ ++ep;
+ break;
+ case matchEqBig:
+ if (!is_big(*ep))
+ FAIL();
+ tp = big_val(*ep);
+ if (*tp != *pc)
+ FAIL();
+ i = BIG_ARITY(pc);
+ while(i--)
+ if (*++tp != *++pc)
+ FAIL();
+ ++pc;
+ ++ep;
+ break;
+ case matchEq:
+ t = (Eterm) *pc++;
+ if (t != *ep++)
+ FAIL();
+ break;
+ case matchSkip:
+ ++ep;
+ break;
+ /*
+ * Here comes guard instructions
+ */
+ case matchPushC: /* Push constant */
+ *esp++ = *pc++;
+ break;
+ case matchConsA:
+ ehp[1] = *--esp;
+ ehp[0] = esp[-1];
+ esp[-1] = make_list(ehp);
+ ehp += 2;
+ break;
+ case matchConsB:
+ ehp[0] = *--esp;
+ ehp[1] = esp[-1];
+ esp[-1] = make_list(ehp);
+ ehp += 2;
+ break;
+ case matchMkTuple:
+ n = *pc++;
+ t = make_tuple(ehp);
+ *ehp++ = make_arityval(n);
+ while (n--) {
+ *ehp++ = *--esp;
+ }
+ *esp++ = t;
+ break;
+ case matchCall0:
+ bif = (Eterm (*)(Process*, ...)) *pc++;
+ t = (*bif)(psp);
+ if (is_non_value(t)) {
+ if (do_catch)
+ t = FAIL_TERM;
+ else
+ FAIL();
+ }
+ *esp++ = t;
+ break;
+ case matchCall1:
+ bif = (Eterm (*)(Process*, ...)) *pc++;
+ t = (*bif)(psp, esp[-1]);
+ if (is_non_value(t)) {
+ if (do_catch)
+ t = FAIL_TERM;
+ else
+ FAIL();
+ }
+ esp[-1] = t;
+ break;
+ case matchCall2:
+ bif = (Eterm (*)(Process*, ...)) *pc++;
+ t = (*bif)(psp, esp[-1], esp[-2]);
+ if (is_non_value(t)) {
+ if (do_catch)
+ t = FAIL_TERM;
+ else
+ FAIL();
+ }
+ --esp;
+ esp[-1] = t;
+ break;
+ case matchCall3:
+ bif = (Eterm (*)(Process*, ...)) *pc++;
+ t = (*bif)(psp, esp[-1], esp[-2], esp[-3]);
+ if (is_non_value(t)) {
+ if (do_catch)
+ t = FAIL_TERM;
+ else
+ FAIL();
+ }
+ esp -= 2;
+ esp[-1] = t;
+ break;
+ case matchPushV:
+ *esp++ = hp[*pc++];
+ break;
+ case matchPushExpr:
+ *esp++ = term;
+ break;
+ case matchPushArrayAsList:
+ n = arity; /* Only happens when 'term' is an array */
+ tp = (Eterm *) term;
+ *esp++ = make_list(ehp);
+ while (n--) {
+ *ehp++ = *tp++;
+ *ehp = make_list(ehp + 1);
+ ehp++; /* As pointed out by Mikael Pettersson the expression
+ (*ehp++ = make_list(ehp + 1)) that I previously
+ had written here has undefined behaviour. */
+ }
+ ehp[-1] = NIL;
+ break;
+ case matchPushArrayAsListU:
+ /* This instruction is NOT efficient. */
+ *esp++ = dpm_array_to_list(psp, (Eterm *) term, arity);
+ break;
+ case matchTrue:
+ if (*--esp != am_true)
+ FAIL();
+ break;
+ case matchOr:
+ n = *pc++;
+ t = am_false;
+ while (n--) {
+ if (*--esp == am_true) {
+ t = am_true;
+ } else if (*esp != am_false) {
+ esp -= n;
+ if (do_catch) {
+ t = FAIL_TERM;
+ break;
+ } else {
+ FAIL();
+ }
+ }
+ }
+ *esp++ = t;
+ break;
+ case matchAnd:
+ n = *pc++;
+ t = am_true;
+ while (n--) {
+ if (*--esp == am_false) {
+ t = am_false;
+ } else if (*esp != am_true) {
+ esp -= n;
+ if (do_catch) {
+ t = FAIL_TERM;
+ break;
+ } else {
+ FAIL();
+ }
+ }
+ }
+ *esp++ = t;
+ break;
+ case matchOrElse:
+ n = *pc++;
+ if (*--esp == am_true) {
+ ++esp;
+ pc += n;
+ } else if (*esp != am_false) {
+ if (do_catch) {
+ *esp++ = FAIL_TERM;
+ pc += n;
+ } else {
+ FAIL();
+ }
+ }
+ break;
+ case matchAndAlso:
+ n = *pc++;
+ if (*--esp == am_false) {
+ esp++;
+ pc += n;
+ } else if (*esp != am_true) {
+ if (do_catch) {
+ *esp++ = FAIL_TERM;
+ pc += n;
+ } else {
+ FAIL();
+ }
+ }
+ break;
+ case matchJump:
+ n = *pc++;
+ pc += n;
+ break;
+ case matchSelf:
+ *esp++ = c_p->id;
+ break;
+ case matchWaste:
+ --esp;
+ break;
+ case matchReturn:
+ ret = *--esp;
+ break;
+ case matchProcessDump: {
+ erts_dsprintf_buf_t *dsbufp = erts_create_tmp_dsbuf(0);
+ print_process_info(ERTS_PRINT_DSBUF, (void *) dsbufp, c_p);
+ *esp++ = new_binary(psp, (byte *)dsbufp->str, (int)dsbufp->str_len);
+ erts_destroy_tmp_dsbuf(dsbufp);
+ break;
+ }
+ case matchDisplay: /* Debugging, not for production! */
+ erts_printf("%T\n", esp[-1]);
+ esp[-1] = am_true;
+ break;
+ case matchSetReturnTrace:
+ *return_flags |= MATCH_SET_RETURN_TRACE;
+ *esp++ = am_true;
+ break;
+ case matchSetExceptionTrace:
+ *return_flags |= MATCH_SET_EXCEPTION_TRACE;
+ *esp++ = am_true;
+ break;
+ case matchIsSeqTrace:
+ if (SEQ_TRACE_TOKEN(c_p) != NIL)
+ *esp++ = am_true;
+ else
+ *esp++ = am_false;
+ break;
+ case matchSetSeqToken:
+ t = erts_seq_trace(c_p, esp[-1], esp[-2], 0);
+ if (is_non_value(t)) {
+ esp[-2] = FAIL_TERM;
+ } else {
+ esp[-2] = t;
+ }
+ --esp;
+ break;
+ case matchSetSeqTokenFake:
+ t = seq_trace_fake(c_p, esp[-1]);
+ if (is_non_value(t)) {
+ esp[-2] = FAIL_TERM;
+ } else {
+ esp[-2] = t;
+ }
+ --esp;
+ break;
+ case matchGetSeqToken:
+ if (SEQ_TRACE_TOKEN(c_p) == NIL)
+ *esp++ = NIL;
+ else {
+ *esp++ = make_tuple(ehp);
+ ehp[0] = make_arityval(5);
+ ehp[1] = SEQ_TRACE_TOKEN_FLAGS(c_p);
+ ehp[2] = SEQ_TRACE_TOKEN_LABEL(c_p);
+ ehp[3] = SEQ_TRACE_TOKEN_SERIAL(c_p);
+ ehp[4] = SEQ_TRACE_TOKEN_SENDER(c_p);
+ ehp[5] = SEQ_TRACE_TOKEN_LASTCNT(c_p);
+ ASSERT(SEQ_TRACE_TOKEN_ARITY(c_p) == 5);
+ ASSERT(is_immed(ehp[1]));
+ ASSERT(is_immed(ehp[2]));
+ ASSERT(is_immed(ehp[3]));
+ ASSERT(is_immed(ehp[5]));
+ if(!is_immed(ehp[4])) {
+ Eterm *sender = &ehp[4];
+ ehp += 6;
+ *sender = copy_struct(*sender,
+ size_object(*sender),
+ &ehp,
+ &MSO(psp));
+ }
+ else
+ ehp += 6;
+
+ }
+ break;
+ case matchEnableTrace:
+ if ( (n = erts_trace_flag2bit(esp[-1]))) {
+ BEGIN_ATOMIC_TRACE(c_p);
+ set_tracee_flags(c_p, c_p->tracer_proc, 0, n);
+ esp[-1] = am_true;
+ } else {
+ esp[-1] = FAIL_TERM;
+ }
+ break;
+ case matchEnableTrace2:
+ n = erts_trace_flag2bit((--esp)[-1]);
+ esp[-1] = FAIL_TERM;
+ if (n) {
+ BEGIN_ATOMIC_TRACE(c_p);
+ if ( (tmpp = get_proc(c_p, 0, esp[0], 0))) {
+ /* Always take over the tracer of the current process */
+ set_tracee_flags(tmpp, c_p->tracer_proc, 0, n);
+ esp[-1] = am_true;
+ }
+ }
+ break;
+ case matchDisableTrace:
+ if ( (n = erts_trace_flag2bit(esp[-1]))) {
+ BEGIN_ATOMIC_TRACE(c_p);
+ set_tracee_flags(c_p, c_p->tracer_proc, n, 0);
+ esp[-1] = am_true;
+ } else {
+ esp[-1] = FAIL_TERM;
+ }
+ break;
+ case matchDisableTrace2:
+ n = erts_trace_flag2bit((--esp)[-1]);
+ esp[-1] = FAIL_TERM;
+ if (n) {
+ BEGIN_ATOMIC_TRACE(c_p);
+ if ( (tmpp = get_proc(c_p, 0, esp[0], 0))) {
+ /* Always take over the tracer of the current process */
+ set_tracee_flags(tmpp, c_p->tracer_proc, n, 0);
+ esp[-1] = am_true;
+ }
+ }
+ break;
+ case matchCaller:
+ if (!(c_p->cp) || !(hp = find_function_from_pc(c_p->cp))) {
+ *esp++ = am_undefined;
+ } else {
+ *esp++ = make_tuple(ehp);
+ ehp[0] = make_arityval(3);
+ ehp[1] = hp[0];
+ ehp[2] = hp[1];
+ ehp[3] = make_small(hp[2]);
+ ehp += 4;
+ }
+ break;
+ case matchSilent:
+ --esp;
+ if (*esp == am_true) {
+ erts_smp_proc_lock(c_p, ERTS_PROC_LOCKS_ALL_MINOR);
+ c_p->trace_flags |= F_TRACE_SILENT;
+ erts_smp_proc_unlock(c_p, ERTS_PROC_LOCKS_ALL_MINOR);
+ }
+ else if (*esp == am_false) {
+ erts_smp_proc_lock(c_p, ERTS_PROC_LOCKS_ALL_MINOR);
+ c_p->trace_flags &= ~F_TRACE_SILENT;
+ erts_smp_proc_unlock(c_p, ERTS_PROC_LOCKS_ALL_MINOR);
+ }
+ break;
+ case matchTrace2:
+ {
+ /* disable enable */
+ Uint d_flags = 0, e_flags = 0; /* process trace flags */
+ Eterm tracer = c_p->tracer_proc;
+ /* XXX Atomicity note: Not fully atomic. Default tracer
+ * is sampled from current process but applied to
+ * tracee and tracer later after releasing main
+ * locks on current process, so c_p->tracer_proc
+ * may actually have changed when tracee and tracer
+ * gets updated. I do not think nobody will notice.
+ * It is just the default value that is not fully atomic.
+ * and the real argument settable from match spec
+ * {trace,[],[{{tracer,Tracer}}]} is much, much older.
+ */
+ int cputs = 0;
+
+ if (! erts_trace_flags(esp[-1], &d_flags, &tracer, &cputs) ||
+ ! erts_trace_flags(esp[-2], &e_flags, &tracer, &cputs) ||
+ cputs ) {
+ (--esp)[-1] = FAIL_TERM;
+ break;
+ }
+ erts_smp_proc_lock(c_p, ERTS_PROC_LOCKS_ALL_MINOR);
+ (--esp)[-1] = set_match_trace(c_p, FAIL_TERM, tracer,
+ d_flags, e_flags);
+ erts_smp_proc_unlock(c_p, ERTS_PROC_LOCKS_ALL_MINOR);
+ }
+ break;
+ case matchTrace3:
+ {
+ /* disable enable */
+ Uint d_flags = 0, e_flags = 0; /* process trace flags */
+ Eterm tracer = c_p->tracer_proc;
+ /* XXX Atomicity note. Not fully atomic. See above.
+ * Above it could possibly be solved, but not here.
+ */
+ int cputs = 0;
+ Eterm tracee = (--esp)[0];
+
+ if (! erts_trace_flags(esp[-1], &d_flags, &tracer, &cputs) ||
+ ! erts_trace_flags(esp[-2], &e_flags, &tracer, &cputs) ||
+ cputs ||
+ ! (tmpp = get_proc(c_p, ERTS_PROC_LOCK_MAIN,
+ tracee, ERTS_PROC_LOCKS_ALL))) {
+ (--esp)[-1] = FAIL_TERM;
+ break;
+ }
+ if (tmpp == c_p) {
+ (--esp)[-1] = set_match_trace(c_p, FAIL_TERM, tracer,
+ d_flags, e_flags);
+ erts_smp_proc_unlock(c_p, ERTS_PROC_LOCKS_ALL_MINOR);
+ } else {
+ erts_smp_proc_unlock(c_p, ERTS_PROC_LOCK_MAIN);
+ (--esp)[-1] = set_match_trace(tmpp, FAIL_TERM, tracer,
+ d_flags, e_flags);
+ erts_smp_proc_unlock(tmpp, ERTS_PROC_LOCKS_ALL);
+ erts_smp_proc_lock(c_p, ERTS_PROC_LOCK_MAIN);
+ }
+ }
+ break;
+ case matchCatch:
+ do_catch = 1;
+ break;
+ case matchHalt:
+ goto success;
+ default:
+ erl_exit(1, "Internal error: unexpected opcode in match program.");
+ }
+ }
+fail:
+ *return_flags = 0U;
+ if (fail_label >= 0) { /* We failed during a "TryMeElse",
+ lets restart, with the next match
+ program */
+ pc = (prog->text) + fail_label;
+ cleanup_match_pseudo_process(mpsp, 1);
+ goto restart;
+ }
+ ret = THE_NON_VALUE;
+success:
+
+#ifdef DMC_DEBUG
+ if (*heap_fence != FENCE_PATTERN) {
+ erl_exit(1, "Heap fence overwritten in db_prog_match after op "
+ "0x%08x, overwritten with 0x%08x.", save_op, *heap_fence);
+ }
+ if (*eheap_fence != FENCE_PATTERN) {
+ erl_exit(1, "Eheap fence overwritten in db_prog_match after op "
+ "0x%08x, overwritten with 0x%08x.", save_op,
+ *eheap_fence);
+ }
+ if (*stack_fence != FENCE_PATTERN) {
+ erl_exit(1, "Stack fence overwritten in db_prog_match after op "
+ "0x%08x, overwritten with 0x%08x.", save_op,
+ *stack_fence);
+ }
+#endif
+
+ esdp->current_process = current_scheduled;
+
+ END_ATOMIC_TRACE(c_p);
+ return ret;
+#undef FAIL
+#undef FAIL_TERM
+#undef BEGIN_ATOMIC_TRACE
+#undef END_ATOMIC_TRACE
+}
+
+
+/*
+ * Convert a match program to a "magic" binary to return up to erlang
+ */
+Eterm db_make_mp_binary(Process *p, Binary *mp, Eterm **hpp) {
+ return erts_mk_magic_binary_term(hpp, &MSO(p), mp);
+}
+
+DMCErrInfo *db_new_dmc_err_info(void)
+{
+ DMCErrInfo *ret = erts_alloc(ERTS_ALC_T_DB_DMC_ERR_INFO,
+ sizeof(DMCErrInfo));
+ ret->var_trans = NULL;
+ ret->num_trans = 0;
+ ret->error_added = 0;
+ ret->first = NULL;
+ return ret;
+}
+
+Eterm db_format_dmc_err_info(Process *p, DMCErrInfo *ei)
+{
+ int sl;
+ int vnum;
+ DMCError *tmp;
+ Eterm *shp;
+ Eterm ret = NIL;
+ Eterm tlist, tpl, sev;
+ char buff[DMC_ERR_STR_LEN + 20 /* for the number */];
+
+ for (tmp = ei->first; tmp != NULL; tmp = tmp->next) {
+ if (tmp->variable >= 0 &&
+ tmp->variable < ei->num_trans &&
+ ei->var_trans != NULL) {
+ vnum = (int) ei->var_trans[tmp->variable];
+ } else {
+ vnum = tmp->variable;
+ }
+ if (vnum >= 0)
+ sprintf(buff,tmp->error_string, vnum);
+ else
+ strcpy(buff,tmp->error_string);
+ sl = strlen(buff);
+ shp = HAlloc(p, sl * 2 + 5);
+ sev = (tmp->severity == dmcWarning) ?
+ am_atom_put("warning",7) :
+ am_error;
+ tlist = buf_to_intlist(&shp, buff, sl, NIL);
+ tpl = TUPLE2(shp, sev, tlist);
+ shp += 3;
+ ret = CONS(shp, tpl, ret);
+ shp += 2;
+ }
+ return ret;
+}
+
+void db_free_dmc_err_info(DMCErrInfo *ei){
+ while (ei->first != NULL) {
+ DMCError *ll = ei->first->next;
+ erts_free(ERTS_ALC_T_DB_DMC_ERROR, ei->first);
+ ei->first = ll;
+ }
+ if (ei->var_trans)
+ erts_free(ERTS_ALC_T_DB_TRANS_TAB, ei->var_trans);
+ erts_free(ERTS_ALC_T_DB_DMC_ERR_INFO, ei);
+}
+
+/* Calculate integer addition: counter+incr.
+** Store bignum in *hpp and increase *hpp accordingly.
+** *hpp is assumed to be large enough to hold the result.
+*/
+Eterm db_add_counter(Eterm** hpp, Eterm counter, Eterm incr)
+{
+ Eterm big_tmp[2];
+ Eterm res;
+ Sint ires;
+ Eterm arg1;
+ Eterm arg2;
+
+ if (is_both_small(counter,incr)) {
+ ires = signed_val(counter) + signed_val(incr);
+ if (IS_SSMALL(ires)) {
+ return make_small(ires);
+ } else {
+ res = small_to_big(ires, *hpp);
+ ASSERT(BIG_NEED_SIZE(big_size(res))==2);
+ *hpp += 2;
+ return res;
+ }
+ }
+ else {
+ switch(NUMBER_CODE(counter, incr)) {
+ case SMALL_BIG:
+ arg1 = small_to_big(signed_val(counter), big_tmp);
+ arg2 = incr;
+ break;
+ case BIG_SMALL:
+ arg1 = counter;
+ arg2 = small_to_big(signed_val(incr), big_tmp);
+ break;
+ case BIG_BIG:
+ arg1 = incr;
+ arg2 = counter;
+ break;
+ default:
+ return THE_NON_VALUE;
+ }
+ res = big_plus(arg1, arg2, *hpp);
+ if (is_big(res)) {
+ *hpp += BIG_NEED_SIZE(big_size(res));
+ }
+ return res;
+ }
+}
+
+/*
+** Update one element:
+** handle: Initialized by db_lookup_dbterm()
+** position: The tuple position of the elements to be updated.
+** newval: The new value of the element.
+** Can not fail.
+*/
+void db_do_update_element(DbUpdateHandle* handle,
+ Sint position,
+ Eterm newval)
+{
+ Eterm oldval = handle->dbterm->tpl[position];
+ Eterm* newp;
+ Eterm* oldp;
+ Uint newval_sz;
+ Uint oldval_sz;
+
+ if (is_both_immed(newval,oldval)) {
+ handle->dbterm->tpl[position] = newval;
+ return;
+ }
+ else if (!handle->mustResize && is_boxed(newval)) {
+ newp = boxed_val(newval);
+ switch (*newp & _TAG_HEADER_MASK) {
+ case _TAG_HEADER_POS_BIG:
+ case _TAG_HEADER_NEG_BIG:
+ case _TAG_HEADER_FLOAT:
+ case _TAG_HEADER_HEAP_BIN:
+ newval_sz = header_arity(*newp) + 1;
+ if (is_boxed(oldval)) {
+ oldp = boxed_val(oldval);
+ switch (*oldp & _TAG_HEADER_MASK) {
+ case _TAG_HEADER_POS_BIG:
+ case _TAG_HEADER_NEG_BIG:
+ case _TAG_HEADER_FLOAT:
+ case _TAG_HEADER_HEAP_BIN:
+ oldval_sz = header_arity(*oldp) + 1;
+ if (oldval_sz == newval_sz) {
+ /* "self contained" terms of same size, do memcpy */
+ sys_memcpy(oldp, newp, newval_sz*sizeof(Eterm));
+ return;
+ }
+ goto both_size_set;
+ }
+ }
+ goto new_size_set;
+ }
+ }
+ /* Not possible for simple memcpy or dbterm is already non-contiguous, */
+ /* need to realloc... */
+
+ newval_sz = is_immed(newval) ? 0 : size_object(newval);
+new_size_set:
+
+ oldval_sz = is_immed(oldval) ? 0 : size_object(oldval);
+both_size_set:
+
+ handle->new_size = handle->new_size - oldval_sz + newval_sz;
+
+ /* write new value in old dbterm, finalize will make a flat copy */
+ handle->dbterm->tpl[position] = newval;
+ handle->mustResize = 1;
+}
+
+
+/*
+** Copy the object into a possibly new DbTerm,
+** offset is the offset of the DbTerm from the start
+** of the sysAllocaed structure, The possibly realloced and copied
+** structure is returned. Make sure (((char *) old) - offset) is a
+** pointer to a ERTS_ALC_T_DB_TERM allocated data area.
+*/
+void* db_get_term(DbTableCommon *tb, DbTerm* old, Uint offset, Eterm obj)
+{
+ int size = size_object(obj);
+ void *structp = ((char*) old) - offset;
+ DbTerm* p;
+ Eterm copy;
+ Eterm *top;
+
+ if (old != 0) {
+ erts_cleanup_offheap(&old->off_heap);
+ if (size == old->size) {
+ p = old;
+ } else {
+ Uint new_sz = offset + sizeof(DbTerm) + sizeof(Eterm)*(size-1);
+ Uint old_sz = offset + sizeof(DbTerm) + sizeof(Eterm)*(old->size-1);
+
+ if (erts_ets_realloc_always_moves) {
+ void *nstructp = erts_db_alloc(ERTS_ALC_T_DB_TERM,
+ (DbTable *) tb,
+ new_sz);
+ memcpy(nstructp,structp,offset);
+ erts_db_free(ERTS_ALC_T_DB_TERM,
+ (DbTable *) tb,
+ structp,
+ old_sz);
+ structp = nstructp;
+ } else {
+ structp = erts_db_realloc(ERTS_ALC_T_DB_TERM,
+ (DbTable *) tb,
+ structp,
+ old_sz,
+ new_sz);
+ }
+ p = (DbTerm*) ((void *)(((char *) structp) + offset));
+ }
+ }
+ else {
+ structp = erts_db_alloc(ERTS_ALC_T_DB_TERM,
+ (DbTable *) tb,
+ (offset
+ + sizeof(DbTerm)
+ + sizeof(Eterm)*(size-1)));
+ p = (DbTerm*) ((void *)(((char *) structp) + offset));
+ }
+ p->size = size;
+ p->off_heap.mso = NULL;
+ p->off_heap.externals = NULL;
+#ifndef HYBRID /* FIND ME! */
+ p->off_heap.funs = NULL;
+#endif
+ p->off_heap.overhead = 0;
+
+ top = DBTERM_BUF(p);
+ copy = copy_struct(obj, size, &top, &p->off_heap);
+ DBTERM_SET_TPL(p,tuple_val(copy));
+
+ return structp;
+}
+
+
+void db_free_term_data(DbTerm* p)
+{
+ erts_cleanup_offheap(&p->off_heap);
+}
+
+
+/*
+** Check if object represents a "match" variable
+** i.e and atom $N where N is an integer
+**
+*/
+
+int db_is_variable(Eterm obj)
+{
+ byte *b;
+ int n;
+ int N;
+
+ if (is_not_atom(obj))
+ return -1;
+ b = atom_tab(atom_val(obj))->name;
+ if ((n = atom_tab(atom_val(obj))->len) < 2)
+ return -1;
+ if (*b++ != '$')
+ return -1;
+ n--;
+ /* Handle first digit */
+ if (*b == '0')
+ return (n == 1) ? 0 : -1;
+ if (*b >= '1' && *b <= '9')
+ N = *b++ - '0';
+ else
+ return -1;
+ n--;
+ while(n--) {
+ if (*b >= '0' && *b <= '9') {
+ N = N*10 + (*b - '0');
+ b++;
+ }
+ else
+ return -1;
+ }
+ return N;
+}
+
+
+/* check if obj is (or contains) a variable */
+/* return 1 if obj contains a variable or underscore */
+/* return 0 if obj is fully ground */
+
+int db_has_variable(Eterm obj)
+{
+ switch(obj & _TAG_PRIMARY_MASK) {
+ case TAG_PRIMARY_LIST: {
+ while (is_list(obj)) {
+ if (db_has_variable(CAR(list_val(obj))))
+ return 1;
+ obj = CDR(list_val(obj));
+ }
+ return(db_has_variable(obj)); /* Non wellformed list or [] */
+ }
+ case TAG_PRIMARY_BOXED:
+ if (!BOXED_IS_TUPLE(obj)) {
+ return 0;
+ } else {
+ Eterm *tuple = tuple_val(obj);
+ int arity = arityval(*tuple++);
+ while(arity--) {
+ if (db_has_variable(*tuple))
+ return 1;
+ tuple++;
+ }
+ return(0);
+ }
+ case TAG_PRIMARY_IMMED1:
+ if (obj == am_Underscore || db_is_variable(obj) >= 0)
+ return 1;
+ }
+ return 0;
+}
+
+int erts_db_is_compiled_ms(Eterm term)
+{
+ return (is_binary(term)
+ && (thing_subtag(*binary_val(term)) == REFC_BINARY_SUBTAG)
+ && IsMatchProgBinary((((ProcBin *) binary_val(term))->val)));
+}
+
+/*
+** Local (static) utilities.
+*/
+
+/*
+***************************************************************************
+** Compiled matches
+***************************************************************************
+*/
+/*
+** Utility to add an error
+*/
+
+static void add_dmc_err(DMCErrInfo *err_info,
+ char *str,
+ int variable,
+ Eterm term,
+ DMCErrorSeverity severity)
+{
+ /* Linked in in reverse order, to ease the formatting */
+ DMCError *e = erts_alloc(ERTS_ALC_T_DB_DMC_ERROR, sizeof(DMCError));
+ if (term != 0UL) {
+ erts_snprintf(e->error_string, DMC_ERR_STR_LEN, str, term);
+ } else {
+ strncpy(e->error_string, str, DMC_ERR_STR_LEN);
+ e->error_string[DMC_ERR_STR_LEN] ='\0';
+ }
+ e->variable = variable;
+ e->severity = severity;
+ e->next = err_info->first;
+#ifdef HARDDEBUG
+ erts_fprintf(stderr,"add_dmc_err: %s\n",e->error_string);
+#endif
+ err_info->first = e;
+ if (severity >= dmcError)
+ err_info->error_added = 1;
+}
+
+/*
+** Handle one term in the match expression (not the guard)
+*/
+static DMCRet dmc_one_term(DMCContext *context,
+ DMCHeap *heap,
+ DMC_STACK_TYPE(Eterm) *stack,
+ DMC_STACK_TYPE(Uint) *text,
+ Eterm c)
+{
+ Sint n;
+ Eterm *hp;
+ ErlHeapFragment *tmp_mb;
+ Uint sz, sz2, sz3;
+ Uint i, j;
+
+
+ switch (c & _TAG_PRIMARY_MASK) {
+ case TAG_PRIMARY_IMMED1:
+ if ((n = db_is_variable(c)) >= 0) { /* variable */
+ if (n >= heap->size) {
+ /*
+ ** Ouch, big integer in match variable.
+ */
+ Eterm *save_hp;
+ ASSERT(heap->data == heap->def);
+ sz = sz2 = sz3 = 0;
+ for (j = 0; j < context->num_match; ++j) {
+ sz += size_object(context->matchexpr[j]);
+ sz2 += size_object(context->guardexpr[j]);
+ sz3 += size_object(context->bodyexpr[j]);
+ }
+ context->copy =
+ new_message_buffer(sz + sz2 + sz3 +
+ context->num_match);
+ save_hp = hp = context->copy->mem;
+ hp += context->num_match;
+ for (j = 0; j < context->num_match; ++j) {
+ context->matchexpr[j] =
+ copy_struct(context->matchexpr[j],
+ size_object(context->matchexpr[j]), &hp,
+ &(context->copy->off_heap));
+ context->guardexpr[j] =
+ copy_struct(context->guardexpr[j],
+ size_object(context->guardexpr[j]), &hp,
+ &(context->copy->off_heap));
+ context->bodyexpr[j] =
+ copy_struct(context->bodyexpr[j],
+ size_object(context->bodyexpr[j]), &hp,
+ &(context->copy->off_heap));
+ }
+ for (j = 0; j < context->num_match; ++j) {
+ /* the actual expressions can be
+ atoms in their selves, place them first */
+ *save_hp++ = context->matchexpr[j];
+ }
+ heap->size = match_compact(context->copy,
+ context->err_info);
+ for (j = 0; j < context->num_match; ++j) {
+ /* restore the match terms, as they
+ may be atoms that changed */
+ context->matchexpr[j] = context->copy->mem[j];
+ }
+ heap->data = erts_alloc(ERTS_ALC_T_DB_MS_CMPL_HEAP,
+ heap->size*sizeof(unsigned));
+ sys_memset(heap->data, 0,
+ heap->size * sizeof(unsigned));
+ DMC_CLEAR(*stack);
+ /*DMC_PUSH(*stack,NIL);*/
+ DMC_CLEAR(*text);
+ return retRestart;
+ }
+ if (heap->data[n]) { /* already bound ? */
+ DMC_PUSH(*text,matchCmp);
+ DMC_PUSH(*text,n);
+ } else { /* Not bound, bind! */
+ if (n >= heap->used)
+ heap->used = n + 1;
+ DMC_PUSH(*text,matchBind);
+ DMC_PUSH(*text,n);
+ heap->data[n] = 1;
+ }
+ } else if (c == am_Underscore) {
+ DMC_PUSH(*text, matchSkip);
+ } else { /* Any immediate value */
+ DMC_PUSH(*text, matchEq);
+ DMC_PUSH(*text, (Uint) c);
+ }
+ break;
+ case TAG_PRIMARY_LIST:
+ DMC_PUSH(*text, matchPushL);
+ ++(context->stack_used);
+ DMC_PUSH(*stack, c);
+ break;
+ case TAG_PRIMARY_BOXED: {
+ Eterm hdr = *boxed_val(c);
+ switch ((hdr & _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE) {
+ case (_TAG_HEADER_ARITYVAL >> _TAG_PRIMARY_SIZE):
+ n = arityval(*tuple_val(c));
+ DMC_PUSH(*text, matchPushT);
+ ++(context->stack_used);
+ DMC_PUSH(*text, n);
+ DMC_PUSH(*stack, c);
+ break;
+ case (_TAG_HEADER_REF >> _TAG_PRIMARY_SIZE):
+ n = thing_arityval(*internal_ref_val(c));
+ DMC_PUSH(*text, matchEqRef);
+ DMC_PUSH(*text, *internal_ref_val(c));
+ for (i = 1; i <= n; ++i) {
+ DMC_PUSH(*text, (Uint) internal_ref_val(c)[i]);
+ }
+ break;
+ case (_TAG_HEADER_POS_BIG >> _TAG_PRIMARY_SIZE):
+ case (_TAG_HEADER_NEG_BIG >> _TAG_PRIMARY_SIZE):
+ n = thing_arityval(*big_val(c));
+ DMC_PUSH(*text, matchEqBig);
+ DMC_PUSH(*text, *big_val(c));
+ for (i = 1; i <= n; ++i) {
+ DMC_PUSH(*text, (Uint) big_val(c)[i]);
+ }
+ break;
+ case (_TAG_HEADER_FLOAT >> _TAG_PRIMARY_SIZE):
+ DMC_PUSH(*text,matchEqFloat);
+ DMC_PUSH(*text, (Uint) float_val(c)[1]);
+ /* XXX: this reads and pushes random junk on ARCH_64 */
+ DMC_PUSH(*text, (Uint) float_val(c)[2]);
+ break;
+ default: /* BINARY, FUN, VECTOR, or EXTERNAL */
+ /*
+ ** Make a private copy...
+ */
+ n = size_object(c);
+ tmp_mb = new_message_buffer(n);
+ hp = tmp_mb->mem;
+ DMC_PUSH(*text, matchEqBin);
+ DMC_PUSH(*text, copy_struct(c, n, &hp, &(tmp_mb->off_heap)));
+ tmp_mb->next = context->save;
+ context->save = tmp_mb;
+ break;
+ }
+ break;
+ }
+ default:
+ erl_exit(1, "db_match_compile: "
+ "Bad object on heap: 0x%08lx\n",
+ (unsigned long) c);
+ }
+ return retOk;
+}
+
+/*
+** Match guard compilation
+*/
+
+static void do_emit_constant(DMCContext *context, DMC_STACK_TYPE(Uint) *text,
+ Eterm t)
+{
+ int sz;
+ ErlHeapFragment *emb;
+ Eterm *hp;
+ Eterm tmp;
+
+ if (IS_CONST(t)) {
+ tmp = t;
+ } else {
+ sz = my_size_object(t);
+ emb = new_message_buffer(sz);
+ hp = emb->mem;
+ tmp = my_copy_struct(t,&hp,&(emb->off_heap));
+ emb->next = context->save;
+ context->save = emb;
+ }
+ DMC_PUSH(*text,matchPushC);
+ DMC_PUSH(*text,(Uint) tmp);
+ if (++context->stack_used > context->stack_need)
+ context->stack_need = context->stack_used;
+}
+
+#define RETURN_ERROR_X(String, X, Y, ContextP, ConstantF) \
+do { \
+if ((ContextP)->err_info != NULL) { \
+ (ConstantF) = 0; \
+ add_dmc_err((ContextP)->err_info, String, X, Y, dmcError); \
+ return retOk; \
+} else \
+ return retFail; \
+} while(0)
+
+#define RETURN_ERROR(String, ContextP, ConstantF) \
+ RETURN_ERROR_X(String, -1, 0UL, ContextP, ConstantF)
+
+#define RETURN_VAR_ERROR(String, N, ContextP, ConstantF) \
+ RETURN_ERROR_X(String, N, 0UL, ContextP, ConstantF)
+
+#define RETURN_TERM_ERROR(String, T, ContextP, ConstantF) \
+ RETURN_ERROR_X(String, -1, T, ContextP, ConstantF)
+
+#define WARNING(String, ContextP) \
+add_dmc_err((ContextP)->err_info, String, -1, 0UL, dmcWarning)
+
+#define VAR_WARNING(String, N, ContextP) \
+add_dmc_err((ContextP)->err_info, String, N, 0UL, dmcWarning)
+
+#define TERM_WARNING(String, T, ContextP) \
+add_dmc_err((ContextP)->err_info, String, -1, T, dmcWarning)
+
+static DMCRet dmc_list(DMCContext *context,
+ DMCHeap *heap,
+ DMC_STACK_TYPE(Uint) *text,
+ Eterm t,
+ int *constant)
+{
+ int c1;
+ int c2;
+ int ret;
+
+ if ((ret = dmc_expr(context, heap, text, CAR(list_val(t)), &c1)) != retOk)
+ return ret;
+
+ if ((ret = dmc_expr(context, heap, text, CDR(list_val(t)), &c2)) != retOk)
+ return ret;
+
+ if (c1 && c2) {
+ *constant = 1;
+ return retOk;
+ }
+ *constant = 0;
+ if (!c1) {
+ /* The CAR is not a constant, so if the CDR is, we just push it,
+ otherwise it is already pushed. */
+ if (c2)
+ do_emit_constant(context, text, CDR(list_val(t)));
+ DMC_PUSH(*text, matchConsA);
+ } else { /* !c2 && c1 */
+ do_emit_constant(context, text, CAR(list_val(t)));
+ DMC_PUSH(*text, matchConsB);
+ }
+ --context->stack_used; /* Two objects on stack becomes one */
+ context->eheap_need += 2;
+ return retOk;
+}
+
+static DMCRet dmc_tuple(DMCContext *context,
+ DMCHeap *heap,
+ DMC_STACK_TYPE(Uint) *text,
+ Eterm t,
+ int *constant)
+{
+ DMC_STACK_TYPE(Uint) instr_save;
+ int all_constant = 1;
+ int textpos = DMC_STACK_NUM(*text);
+ Eterm *p = tuple_val(t);
+ Uint nelems = arityval(*p);
+ Uint i;
+ int c;
+ DMCRet ret;
+
+ /*
+ ** We remember where we started to layout code,
+ ** assume all is constant and back up and restart if not so.
+ ** The tuple should be laid out with the last element first,
+ ** so we can memcpy the tuple to the eheap.
+ */
+ for (i = nelems; i > 0; --i) {
+ if ((ret = dmc_expr(context, heap, text, p[i], &c)) != retOk)
+ return ret;
+ if (!c && all_constant) {
+ all_constant = 0;
+ if (i < nelems) {
+ Uint j;
+
+ /*
+ * Oops, we need to relayout the constants.
+ * Save the already laid out instructions.
+ */
+ DMC_INIT_STACK(instr_save);
+ while (DMC_STACK_NUM(*text) > textpos)
+ DMC_PUSH(instr_save, DMC_POP(*text));
+ for (j = nelems; j > i; --j)
+ do_emit_constant(context, text, p[j]);
+ while(!DMC_EMPTY(instr_save))
+ DMC_PUSH(*text, DMC_POP(instr_save));
+ DMC_FREE(instr_save);
+ }
+ } else if (c && !all_constant) {
+ /* push a constant */
+ do_emit_constant(context, text, p[i]);
+ }
+ }
+
+ if (all_constant) {
+ *constant = 1;
+ return retOk;
+ }
+ DMC_PUSH(*text, matchMkTuple);
+ DMC_PUSH(*text, nelems);
+ context->stack_used -= (nelems - 1);
+ context->eheap_need += (nelems + 1);
+ *constant = 0;
+ return retOk;
+}
+
+static DMCRet dmc_whole_expression(DMCContext *context,
+ DMCHeap *heap,
+ DMC_STACK_TYPE(Uint) *text,
+ Eterm t,
+ int *constant)
+{
+ if (context->cflags & DCOMP_TRACE) {
+ /* Hmmm, convert array to list... */
+ if (context->special) {
+ DMC_PUSH(*text, matchPushArrayAsListU);
+ } else {
+ ASSERT(is_tuple(context->matchexpr
+ [context->current_match]));
+ context->eheap_need +=
+ arityval(*(tuple_val(context->matchexpr
+ [context->current_match]))) * 2;
+ DMC_PUSH(*text, matchPushArrayAsList);
+ }
+ } else {
+ DMC_PUSH(*text, matchPushExpr);
+ }
+ ++context->stack_used;
+ if (context->stack_used > context->stack_need)
+ context->stack_need = context->stack_used;
+ *constant = 0;
+ return retOk;
+}
+
+static DMCRet dmc_variable(DMCContext *context,
+ DMCHeap *heap,
+ DMC_STACK_TYPE(Uint) *text,
+ Eterm t,
+ int *constant)
+{
+ Uint n = db_is_variable(t);
+ ASSERT(n >= 0);
+ if (n >= heap->used)
+ RETURN_VAR_ERROR("Variable $%d is unbound.", n, context, *constant);
+ if (heap->data[n] == 0U)
+ RETURN_VAR_ERROR("Variable $%d is unbound.", n, context, *constant);
+ DMC_PUSH(*text, matchPushV);
+ DMC_PUSH(*text, n);
+ ++context->stack_used;
+ if (context->stack_used > context->stack_need)
+ context->stack_need = context->stack_used;
+ *constant = 0;
+ return retOk;
+}
+
+static DMCRet dmc_all_bindings(DMCContext *context,
+ DMCHeap *heap,
+ DMC_STACK_TYPE(Uint) *text,
+ Eterm t,
+ int *constant)
+{
+ int i;
+ int heap_used = 0;
+
+ DMC_PUSH(*text, matchPushC);
+ DMC_PUSH(*text, NIL);
+ for (i = heap->used - 1; i >= 0; --i) {
+ if (heap->data[i]) {
+ DMC_PUSH(*text, matchPushV);
+ DMC_PUSH(*text, i);
+ DMC_PUSH(*text, matchConsB);
+ heap_used += 2;
+ }
+ }
+ ++context->stack_used;
+ if ((context->stack_used + 1) > context->stack_need)
+ context->stack_need = (context->stack_used + 1);
+ context->eheap_need += heap_used;
+ *constant = 0;
+ return retOk;
+}
+
+static DMCRet dmc_const(DMCContext *context,
+ DMCHeap *heap,
+ DMC_STACK_TYPE(Uint) *text,
+ Eterm t,
+ int *constant)
+{
+ Eterm *p = tuple_val(t);
+ Uint a = arityval(*p);
+
+ if (a != 2) {
+ RETURN_TERM_ERROR("Special form 'const' called with more than one "
+ "argument in %T.", t, context, *constant);
+ }
+ *constant = 1;
+ return retOk;
+}
+
+static DMCRet dmc_and(DMCContext *context,
+ DMCHeap *heap,
+ DMC_STACK_TYPE(Uint) *text,
+ Eterm t,
+ int *constant)
+{
+ Eterm *p = tuple_val(t);
+ Uint a = arityval(*p);
+ DMCRet ret;
+ int i;
+ int c;
+
+ if (a < 2) {
+ RETURN_TERM_ERROR("Special form 'and' called without arguments "
+ "in %T.", t, context, *constant);
+ }
+ *constant = 0;
+ for (i = a; i > 1; --i) {
+ if ((ret = dmc_expr(context, heap, text, p[i], &c)) != retOk)
+ return ret;
+ if (c)
+ do_emit_constant(context, text, p[i]);
+ }
+ DMC_PUSH(*text, matchAnd);
+ DMC_PUSH(*text, (Uint) a - 1);
+ context->stack_used -= (a - 2);
+ return retOk;
+}
+
+static DMCRet dmc_or(DMCContext *context,
+ DMCHeap *heap,
+ DMC_STACK_TYPE(Uint) *text,
+ Eterm t,
+ int *constant)
+{
+ Eterm *p = tuple_val(t);
+ Uint a = arityval(*p);
+ DMCRet ret;
+ int i;
+ int c;
+
+ if (a < 2) {
+ RETURN_TERM_ERROR("Special form 'or' called without arguments "
+ "in %T.", t, context, *constant);
+ }
+ *constant = 0;
+ for (i = a; i > 1; --i) {
+ if ((ret = dmc_expr(context, heap, text, p[i], &c)) != retOk)
+ return ret;
+ if (c)
+ do_emit_constant(context, text, p[i]);
+ }
+ DMC_PUSH(*text, matchOr);
+ DMC_PUSH(*text, (Uint) a - 1);
+ context->stack_used -= (a - 2);
+ return retOk;
+}
+
+
+static DMCRet dmc_andalso(DMCContext *context,
+ DMCHeap *heap,
+ DMC_STACK_TYPE(Uint) *text,
+ Eterm t,
+ int *constant)
+{
+ Eterm *p = tuple_val(t);
+ Uint a = arityval(*p);
+ DMCRet ret;
+ int i;
+ int c;
+ Uint lbl;
+ Uint lbl_next;
+ Uint lbl_val;
+
+ if (a < 2) {
+ RETURN_TERM_ERROR("Special form 'andalso' called without"
+ " arguments "
+ "in %T.", t, context, *constant);
+ }
+ *constant = 0;
+ lbl = 0;
+ for (i = 2; i <= a; ++i) {
+ if ((ret = dmc_expr(context, heap, text, p[i], &c)) != retOk)
+ return ret;
+ if (c)
+ do_emit_constant(context, text, p[i]);
+ if (i == a) {
+ DMC_PUSH(*text, matchJump);
+ } else {
+ DMC_PUSH(*text, matchAndAlso);
+ }
+ DMC_PUSH(*text, lbl);
+ lbl = DMC_STACK_NUM(*text)-1;
+ --(context->stack_used);
+ }
+ DMC_PUSH(*text, matchPushC);
+ DMC_PUSH(*text, am_true);
+ lbl_val = DMC_STACK_NUM(*text);
+ while (lbl) {
+ lbl_next = DMC_PEEK(*text, lbl);
+ DMC_POKE(*text, lbl, lbl_val-lbl-1);
+ lbl = lbl_next;
+ }
+ if (++context->stack_used > context->stack_need)
+ context->stack_need = context->stack_used;
+ return retOk;
+}
+
+static DMCRet dmc_orelse(DMCContext *context,
+ DMCHeap *heap,
+ DMC_STACK_TYPE(Uint) *text,
+ Eterm t,
+ int *constant)
+{
+ Eterm *p = tuple_val(t);
+ Uint a = arityval(*p);
+ DMCRet ret;
+ int i;
+ int c;
+ Uint lbl;
+ Uint lbl_next;
+ Uint lbl_val;
+
+ if (a < 2) {
+ RETURN_TERM_ERROR("Special form 'orelse' called without arguments "
+ "in %T.", t, context, *constant);
+ }
+ *constant = 0;
+ lbl = 0;
+ for (i = 2; i <= a; ++i) {
+ if ((ret = dmc_expr(context, heap, text, p[i], &c)) != retOk)
+ return ret;
+ if (c)
+ do_emit_constant(context, text, p[i]);
+ if (i == a) {
+ DMC_PUSH(*text, matchJump);
+ } else {
+ DMC_PUSH(*text, matchOrElse);
+ }
+ DMC_PUSH(*text, lbl);
+ lbl = DMC_STACK_NUM(*text)-1;
+ --(context->stack_used);
+ }
+ DMC_PUSH(*text, matchPushC);
+ DMC_PUSH(*text, am_false);
+ lbl_val = DMC_STACK_NUM(*text);
+ while (lbl) {
+ lbl_next = DMC_PEEK(*text, lbl);
+ DMC_POKE(*text, lbl, lbl_val-lbl-1);
+ lbl = lbl_next;
+ }
+ if (++context->stack_used > context->stack_need)
+ context->stack_need = context->stack_used;
+ return retOk;
+}
+
+static DMCRet dmc_message(DMCContext *context,
+ DMCHeap *heap,
+ DMC_STACK_TYPE(Uint) *text,
+ Eterm t,
+ int *constant)
+{
+ Eterm *p = tuple_val(t);
+ Uint a = arityval(*p);
+ DMCRet ret;
+ int c;
+
+
+ if (!(context->cflags & DCOMP_TRACE)) {
+ RETURN_ERROR("Special form 'message' used in wrong dialect.",
+ context,
+ *constant);
+ }
+ if (context->is_guard) {
+ RETURN_ERROR("Special form 'message' called in guard context.",
+ context,
+ *constant);
+ }
+
+ if (a != 2) {
+ RETURN_TERM_ERROR("Special form 'message' called with wrong "
+ "number of arguments in %T.", t, context,
+ *constant);
+ }
+ *constant = 0;
+ if ((ret = dmc_expr(context, heap, text, p[2], &c)) != retOk) {
+ return ret;
+ }
+ if (c) {
+ do_emit_constant(context, text, p[2]);
+ }
+ DMC_PUSH(*text, matchReturn);
+ DMC_PUSH(*text, matchPushC);
+ DMC_PUSH(*text, am_true);
+ /* Push as much as we remove, stack_need is untouched */
+ return retOk;
+}
+
+static DMCRet dmc_self(DMCContext *context,
+ DMCHeap *heap,
+ DMC_STACK_TYPE(Uint) *text,
+ Eterm t,
+ int *constant)
+{
+ Eterm *p = tuple_val(t);
+ Uint a = arityval(*p);
+
+ if (a != 1) {
+ RETURN_TERM_ERROR("Special form 'self' called with arguments "
+ "in %T.", t, context, *constant);
+ }
+ *constant = 0;
+ DMC_PUSH(*text, matchSelf);
+ if (++context->stack_used > context->stack_need)
+ context->stack_need = context->stack_used;
+ return retOk;
+}
+
+static DMCRet dmc_return_trace(DMCContext *context,
+ DMCHeap *heap,
+ DMC_STACK_TYPE(Uint) *text,
+ Eterm t,
+ int *constant)
+{
+ Eterm *p = tuple_val(t);
+ Uint a = arityval(*p);
+
+ if (!(context->cflags & DCOMP_TRACE)) {
+ RETURN_ERROR("Special form 'return_trace' used in wrong dialect.",
+ context,
+ *constant);
+ }
+ if (context->is_guard) {
+ RETURN_ERROR("Special form 'return_trace' called in "
+ "guard context.", context, *constant);
+ }
+
+ if (a != 1) {
+ RETURN_TERM_ERROR("Special form 'return_trace' called with "
+ "arguments in %T.", t, context, *constant);
+ }
+ *constant = 0;
+ DMC_PUSH(*text, matchSetReturnTrace); /* Pushes 'true' on the stack */
+ if (++context->stack_used > context->stack_need)
+ context->stack_need = context->stack_used;
+ return retOk;
+}
+
+static DMCRet dmc_exception_trace(DMCContext *context,
+ DMCHeap *heap,
+ DMC_STACK_TYPE(Uint) *text,
+ Eterm t,
+ int *constant)
+{
+ Eterm *p = tuple_val(t);
+ Uint a = arityval(*p);
+
+ if (!(context->cflags & DCOMP_TRACE)) {
+ RETURN_ERROR("Special form 'exception_trace' used in wrong dialect.",
+ context,
+ *constant);
+ }
+ if (context->is_guard) {
+ RETURN_ERROR("Special form 'exception_trace' called in "
+ "guard context.", context, *constant);
+ }
+
+ if (a != 1) {
+ RETURN_TERM_ERROR("Special form 'exception_trace' called with "
+ "arguments in %T.", t, context, *constant);
+ }
+ *constant = 0;
+ DMC_PUSH(*text, matchSetExceptionTrace); /* Pushes 'true' on the stack */
+ if (++context->stack_used > context->stack_need)
+ context->stack_need = context->stack_used;
+ return retOk;
+}
+
+
+
+static DMCRet dmc_is_seq_trace(DMCContext *context,
+ DMCHeap *heap,
+ DMC_STACK_TYPE(Uint) *text,
+ Eterm t,
+ int *constant)
+{
+ Eterm *p = tuple_val(t);
+ Uint a = arityval(*p);
+
+ if (!(context->cflags & DCOMP_TRACE)) {
+ RETURN_ERROR("Special form 'is_seq_trace' used in wrong dialect.",
+ context,
+ *constant);
+ }
+ if (a != 1) {
+ RETURN_TERM_ERROR("Special form 'is_seq_trace' called with "
+ "arguments in %T.", t, context, *constant);
+ }
+ *constant = 0;
+ DMC_PUSH(*text, matchIsSeqTrace);
+ /* Pushes 'true' or 'false' on the stack */
+ if (++context->stack_used > context->stack_need)
+ context->stack_need = context->stack_used;
+ return retOk;
+}
+
+static DMCRet dmc_set_seq_token(DMCContext *context,
+ DMCHeap *heap,
+ DMC_STACK_TYPE(Uint) *text,
+ Eterm t,
+ int *constant)
+{
+ Eterm *p = tuple_val(t);
+ Uint a = arityval(*p);
+ DMCRet ret;
+ int c;
+
+
+ if (!(context->cflags & DCOMP_TRACE)) {
+ RETURN_ERROR("Special form 'set_seq_token' used in wrong dialect.",
+ context,
+ *constant);
+ }
+ if (context->is_guard) {
+ RETURN_ERROR("Special form 'set_seq_token' called in "
+ "guard context.", context, *constant);
+ }
+
+ if (a != 3) {
+ RETURN_TERM_ERROR("Special form 'set_seq_token' called with wrong "
+ "number of arguments in %T.", t, context,
+ *constant);
+ }
+ *constant = 0;
+ if ((ret = dmc_expr(context, heap, text, p[3], &c)) != retOk) {
+ return ret;
+ }
+ if (c) {
+ do_emit_constant(context, text, p[3]);
+ }
+ if ((ret = dmc_expr(context, heap, text, p[2], &c)) != retOk) {
+ return ret;
+ }
+ if (c) {
+ do_emit_constant(context, text, p[2]);
+ }
+ if (context->cflags & DCOMP_FAKE_DESTRUCTIVE) {
+ DMC_PUSH(*text, matchSetSeqTokenFake);
+ } else {
+ DMC_PUSH(*text, matchSetSeqToken);
+ }
+ --context->stack_used; /* Remove two and add one */
+ return retOk;
+}
+
+static DMCRet dmc_get_seq_token(DMCContext *context,
+ DMCHeap *heap,
+ DMC_STACK_TYPE(Uint) *text,
+ Eterm t,
+ int *constant)
+{
+ Eterm *p = tuple_val(t);
+ Uint a = arityval(*p);
+
+ if (!(context->cflags & DCOMP_TRACE)) {
+ RETURN_ERROR("Special form 'get_seq_token' used in wrong dialect.",
+ context,
+ *constant);
+ }
+ if (context->is_guard) {
+ RETURN_ERROR("Special form 'get_seq_token' called in "
+ "guard context.", context, *constant);
+ }
+ if (a != 1) {
+ RETURN_TERM_ERROR("Special form 'get_seq_token' called with "
+ "arguments in %T.", t, context,
+ *constant);
+ }
+
+ *constant = 0;
+ DMC_PUSH(*text, matchGetSeqToken);
+ context->eheap_need += (6 /* A 5-tuple is built */
+ + EXTERNAL_THING_HEAD_SIZE + 2 /* Sender can
+ be an external
+ pid */);
+ if (++context->stack_used > context->stack_need)
+ context->stack_need = context->stack_used;
+ return retOk;
+}
+
+
+
+static DMCRet dmc_display(DMCContext *context,
+ DMCHeap *heap,
+ DMC_STACK_TYPE(Uint) *text,
+ Eterm t,
+ int *constant)
+{
+ Eterm *p = tuple_val(t);
+ Uint a = arityval(*p);
+ DMCRet ret;
+ int c;
+
+
+ if (!(context->cflags & DCOMP_TRACE)) {
+ RETURN_ERROR("Special form 'display' used in wrong dialect.",
+ context,
+ *constant);
+ }
+ if (context->is_guard) {
+ RETURN_ERROR("Special form 'display' called in guard context.",
+ context,
+ *constant);
+ }
+
+ if (a != 2) {
+ RETURN_TERM_ERROR("Special form 'display' called with wrong "
+ "number of arguments in %T.", t, context,
+ *constant);
+ }
+ *constant = 0;
+ if ((ret = dmc_expr(context, heap, text, p[2], &c)) != retOk) {
+ return ret;
+ }
+ if (c) {
+ do_emit_constant(context, text, p[2]);
+ }
+ DMC_PUSH(*text, matchDisplay);
+ /* Push as much as we remove, stack_need is untouched */
+ return retOk;
+}
+
+static DMCRet dmc_process_dump(DMCContext *context,
+ DMCHeap *heap,
+ DMC_STACK_TYPE(Uint) *text,
+ Eterm t,
+ int *constant)
+{
+ Eterm *p = tuple_val(t);
+ Uint a = arityval(*p);
+
+ if (!(context->cflags & DCOMP_TRACE)) {
+ RETURN_ERROR("Special form 'process_dump' used in wrong dialect.",
+ context,
+ *constant);
+ }
+ if (context->is_guard) {
+ RETURN_ERROR("Special form 'process_dump' called in "
+ "guard context.", context, *constant);
+ }
+
+ if (a != 1) {
+ RETURN_TERM_ERROR("Special form 'process_dump' called with "
+ "arguments in %T.", t, context, *constant);
+ }
+ *constant = 0;
+ DMC_PUSH(*text, matchProcessDump); /* Creates binary */
+ if (++context->stack_used > context->stack_need)
+ context->stack_need = context->stack_used;
+ return retOk;
+}
+
+static DMCRet dmc_enable_trace(DMCContext *context,
+ DMCHeap *heap,
+ DMC_STACK_TYPE(Uint) *text,
+ Eterm t,
+ int *constant)
+{
+ Eterm *p = tuple_val(t);
+ Uint a = arityval(*p);
+ DMCRet ret;
+ int c;
+
+
+ if (!(context->cflags & DCOMP_TRACE)) {
+ RETURN_ERROR("Special form 'enable_trace' used in wrong dialect.",
+ context,
+ *constant);
+ }
+ if (context->is_guard) {
+ RETURN_ERROR("Special form 'enable_trace' called in guard context.",
+ context,
+ *constant);
+ }
+
+ switch (a) {
+ case 2:
+ *constant = 0;
+ if ((ret = dmc_expr(context, heap, text, p[2], &c)) != retOk) {
+ return ret;
+ }
+ if (c) {
+ do_emit_constant(context, text, p[2]);
+ }
+ DMC_PUSH(*text, matchEnableTrace);
+ /* Push as much as we remove, stack_need is untouched */
+ break;
+ case 3:
+ *constant = 0;
+ if ((ret = dmc_expr(context, heap, text, p[3], &c)) != retOk) {
+ return ret;
+ }
+ if (c) {
+ do_emit_constant(context, text, p[3]);
+ }
+ if ((ret = dmc_expr(context, heap, text, p[2], &c)) != retOk) {
+ return ret;
+ }
+ if (c) {
+ do_emit_constant(context, text, p[2]);
+ }
+ DMC_PUSH(*text, matchEnableTrace2);
+ --context->stack_used; /* Remove two and add one */
+ break;
+ default:
+ RETURN_TERM_ERROR("Special form 'enable_trace' called with wrong "
+ "number of arguments in %T.", t, context,
+ *constant);
+ }
+ return retOk;
+}
+
+static DMCRet dmc_disable_trace(DMCContext *context,
+ DMCHeap *heap,
+ DMC_STACK_TYPE(Uint) *text,
+ Eterm t,
+ int *constant)
+{
+ Eterm *p = tuple_val(t);
+ Uint a = arityval(*p);
+ DMCRet ret;
+ int c;
+
+
+ if (!(context->cflags & DCOMP_TRACE)) {
+ RETURN_ERROR("Special form 'disable_trace' used in wrong dialect.",
+ context,
+ *constant);
+ }
+ if (context->is_guard) {
+ RETURN_ERROR("Special form 'disable_trace' called in guard context.",
+ context,
+ *constant);
+ }
+
+ switch (a) {
+ case 2:
+ *constant = 0;
+ if ((ret = dmc_expr(context, heap, text, p[2], &c)) != retOk) {
+ return ret;
+ }
+ if (c) {
+ do_emit_constant(context, text, p[2]);
+ }
+ DMC_PUSH(*text, matchDisableTrace);
+ /* Push as much as we remove, stack_need is untouched */
+ break;
+ case 3:
+ *constant = 0;
+ if ((ret = dmc_expr(context, heap, text, p[3], &c)) != retOk) {
+ return ret;
+ }
+ if (c) {
+ do_emit_constant(context, text, p[3]);
+ }
+ if ((ret = dmc_expr(context, heap, text, p[2], &c)) != retOk) {
+ return ret;
+ }
+ if (c) {
+ do_emit_constant(context, text, p[2]);
+ }
+ DMC_PUSH(*text, matchDisableTrace2);
+ --context->stack_used; /* Remove two and add one */
+ break;
+ default:
+ RETURN_TERM_ERROR("Special form 'disable_trace' called with wrong "
+ "number of arguments in %T.", t, context,
+ *constant);
+ }
+ return retOk;
+}
+
+static DMCRet dmc_trace(DMCContext *context,
+ DMCHeap *heap,
+ DMC_STACK_TYPE(Uint) *text,
+ Eterm t,
+ int *constant)
+{
+ Eterm *p = tuple_val(t);
+ Uint a = arityval(*p);
+ DMCRet ret;
+ int c;
+
+
+ if (!(context->cflags & DCOMP_TRACE)) {
+ RETURN_ERROR("Special form 'trace' used in wrong dialect.",
+ context,
+ *constant);
+ }
+ if (context->is_guard) {
+ RETURN_ERROR("Special form 'trace' called in guard context.",
+ context,
+ *constant);
+ }
+
+ switch (a) {
+ case 3:
+ *constant = 0;
+ if ((ret = dmc_expr(context, heap, text, p[3], &c)) != retOk) {
+ return ret;
+ }
+ if (c) {
+ do_emit_constant(context, text, p[3]);
+ }
+ if ((ret = dmc_expr(context, heap, text, p[2], &c)) != retOk) {
+ return ret;
+ }
+ if (c) {
+ do_emit_constant(context, text, p[2]);
+ }
+ DMC_PUSH(*text, matchTrace2);
+ --context->stack_used; /* Remove two and add one */
+ break;
+ case 4:
+ *constant = 0;
+ if ((ret = dmc_expr(context, heap, text, p[4], &c)) != retOk) {
+ return ret;
+ }
+ if (c) {
+ do_emit_constant(context, text, p[4]);
+ }
+ if ((ret = dmc_expr(context, heap, text, p[3], &c)) != retOk) {
+ return ret;
+ }
+ if (c) {
+ do_emit_constant(context, text, p[3]);
+ }
+ if ((ret = dmc_expr(context, heap, text, p[2], &c)) != retOk) {
+ return ret;
+ }
+ if (c) {
+ do_emit_constant(context, text, p[2]);
+ }
+ DMC_PUSH(*text, matchTrace3);
+ context->stack_used -= 2; /* Remove three and add one */
+ break;
+ default:
+ RETURN_TERM_ERROR("Special form 'trace' called with wrong "
+ "number of arguments in %T.", t, context,
+ *constant);
+ }
+ return retOk;
+}
+
+
+
+static DMCRet dmc_caller(DMCContext *context,
+ DMCHeap *heap,
+ DMC_STACK_TYPE(Uint) *text,
+ Eterm t,
+ int *constant)
+{
+ Eterm *p = tuple_val(t);
+ Uint a = arityval(*p);
+
+ if (!(context->cflags & DCOMP_TRACE)) {
+ RETURN_ERROR("Special form 'caller' used in wrong dialect.",
+ context,
+ *constant);
+ }
+ if (context->is_guard) {
+ RETURN_ERROR("Special form 'caller' called in "
+ "guard context.", context, *constant);
+ }
+
+ if (a != 1) {
+ RETURN_TERM_ERROR("Special form 'caller' called with "
+ "arguments in %T.", t, context, *constant);
+ }
+ *constant = 0;
+ DMC_PUSH(*text, matchCaller); /* Creates binary */
+ context->eheap_need += 4; /* A 3-tuple is built */
+ if (++context->stack_used > context->stack_need)
+ context->stack_need = context->stack_used;
+ return retOk;
+}
+
+
+
+static DMCRet dmc_silent(DMCContext *context,
+ DMCHeap *heap,
+ DMC_STACK_TYPE(Uint) *text,
+ Eterm t,
+ int *constant)
+{
+ Eterm *p = tuple_val(t);
+ Uint a = arityval(*p);
+ DMCRet ret;
+ int c;
+
+ if (!(context->cflags & DCOMP_TRACE)) {
+ RETURN_ERROR("Special form 'silent' used in wrong dialect.",
+ context,
+ *constant);
+ }
+ if (context->is_guard) {
+ RETURN_ERROR("Special form 'silent' called in "
+ "guard context.", context, *constant);
+ }
+
+ if (a != 2) {
+ RETURN_TERM_ERROR("Special form 'silent' called with wrong "
+ "number of arguments in %T.", t, context,
+ *constant);
+ }
+ *constant = 0;
+ if ((ret = dmc_expr(context, heap, text, p[2], &c)) != retOk) {
+ return ret;
+ }
+ if (c) {
+ do_emit_constant(context, text, p[2]);
+ }
+ DMC_PUSH(*text, matchSilent);
+ DMC_PUSH(*text, matchPushC);
+ DMC_PUSH(*text, am_true);
+ /* Push as much as we remove, stack_need is untouched */
+ return retOk;
+}
+
+
+
+static DMCRet dmc_fun(DMCContext *context,
+ DMCHeap *heap,
+ DMC_STACK_TYPE(Uint) *text,
+ Eterm t,
+ int *constant)
+{
+ Eterm *p = tuple_val(t);
+ Uint a = arityval(*p);
+ int c;
+ int i;
+ DMCRet ret;
+ DMCGuardBif *b;
+
+ /* Special forms. */
+ switch (p[1]) {
+ case am_const:
+ return dmc_const(context, heap, text, t, constant);
+ case am_and:
+ return dmc_and(context, heap, text, t, constant);
+ case am_or:
+ return dmc_or(context, heap, text, t, constant);
+ case am_andalso:
+ case am_andthen:
+ return dmc_andalso(context, heap, text, t, constant);
+ case am_orelse:
+ return dmc_orelse(context, heap, text, t, constant);
+ case am_self:
+ return dmc_self(context, heap, text, t, constant);
+ case am_message:
+ return dmc_message(context, heap, text, t, constant);
+ case am_is_seq_trace:
+ return dmc_is_seq_trace(context, heap, text, t, constant);
+ case am_set_seq_token:
+ return dmc_set_seq_token(context, heap, text, t, constant);
+ case am_get_seq_token:
+ return dmc_get_seq_token(context, heap, text, t, constant);
+ case am_return_trace:
+ return dmc_return_trace(context, heap, text, t, constant);
+ case am_exception_trace:
+ return dmc_exception_trace(context, heap, text, t, constant);
+ case am_display:
+ return dmc_display(context, heap, text, t, constant);
+ case am_process_dump:
+ return dmc_process_dump(context, heap, text, t, constant);
+ case am_enable_trace:
+ return dmc_enable_trace(context, heap, text, t, constant);
+ case am_disable_trace:
+ return dmc_disable_trace(context, heap, text, t, constant);
+ case am_trace:
+ return dmc_trace(context, heap, text, t, constant);
+ case am_caller:
+ return dmc_caller(context, heap, text, t, constant);
+ case am_silent:
+ return dmc_silent(context, heap, text, t, constant);
+ case am_set_tcw:
+ if (context->cflags & DCOMP_FAKE_DESTRUCTIVE) {
+ b = dmc_lookup_bif(am_set_tcw_fake, ((int) a) - 1);
+ } else {
+ b = dmc_lookup_bif(p[1], ((int) a) - 1);
+ }
+ break;
+ default:
+ b = dmc_lookup_bif(p[1], ((int) a) - 1);
+ }
+
+
+ if (b == NULL) {
+ if (context->err_info != NULL) {
+ /* Ugly, should define a better RETURN_TERM_ERROR interface... */
+ char buff[100];
+ sprintf(buff, "Function %%T/%d does_not_exist.", (int)a - 1);
+ RETURN_TERM_ERROR(buff, p[1], context, *constant);
+ } else {
+ return retFail;
+ }
+ }
+ ASSERT(b->arity == ((int) a) - 1);
+ if (! (b->flags &
+ (1 <<
+ ((context->cflags & DCOMP_DIALECT_MASK) +
+ (context->is_guard ? DBIF_GUARD : DBIF_BODY))))) {
+ /* Body clause used in wrong context. */
+ if (context->err_info != NULL) {
+ /* Ugly, should define a better RETURN_TERM_ERROR interface... */
+ char buff[100];
+ sprintf(buff,
+ "Function %%T/%d cannot be called in this context.",
+ (int)a - 1);
+ RETURN_TERM_ERROR(buff, p[1], context, *constant);
+ } else {
+ return retFail;
+ }
+ }
+
+ *constant = 0;
+
+ for (i = a; i > 1; --i) {
+ if ((ret = dmc_expr(context, heap, text, p[i], &c)) != retOk)
+ return ret;
+ if (c)
+ do_emit_constant(context, text, p[i]);
+ }
+ switch (b->arity) {
+ case 0:
+ DMC_PUSH(*text, matchCall0);
+ break;
+ case 1:
+ DMC_PUSH(*text, matchCall1);
+ break;
+ case 2:
+ DMC_PUSH(*text, matchCall2);
+ break;
+ case 3:
+ DMC_PUSH(*text, matchCall3);
+ break;
+ default:
+ erl_exit(1,"ets:match() internal error, "
+ "guard with more than 3 arguments.");
+ }
+ DMC_PUSH(*text, (Uint) b->biff);
+ context->stack_used -= (((int) a) - 2);
+ if (context->stack_used > context->stack_need)
+ context->stack_need = context->stack_used;
+ return retOk;
+}
+
+static DMCRet dmc_expr(DMCContext *context,
+ DMCHeap *heap,
+ DMC_STACK_TYPE(Uint) *text,
+ Eterm t,
+ int *constant)
+{
+ DMCRet ret;
+ Eterm tmp;
+ Eterm *p;
+
+
+ switch (t & _TAG_PRIMARY_MASK) {
+ case TAG_PRIMARY_LIST:
+ if ((ret = dmc_list(context, heap, text, t, constant)) != retOk)
+ return ret;
+ break;
+ case TAG_PRIMARY_BOXED:
+ if (!BOXED_IS_TUPLE(t)) {
+ goto simple_term;
+ }
+ p = tuple_val(t);
+#ifdef HARDDEBUG
+ erts_fprintf(stderr,"%d %d %d %d\n",arityval(*p),is_tuple(tmp = p[1]),
+ is_atom(p[1]),db_is_variable(p[1]));
+#endif
+ if (arityval(*p) == 1 && is_tuple(tmp = p[1])) {
+ if ((ret = dmc_tuple(context, heap, text, tmp, constant)) != retOk)
+ return ret;
+ } else if (arityval(*p) >= 1 && is_atom(p[1]) &&
+ !(db_is_variable(p[1]) >= 0)) {
+ if ((ret = dmc_fun(context, heap, text, t, constant)) != retOk)
+ return ret;
+ } else
+ RETURN_TERM_ERROR("%T is neither a function call, nor a tuple "
+ "(tuples are written {{ ... }}).", t,
+ context, *constant);
+ break;
+ case TAG_PRIMARY_IMMED1:
+ if (db_is_variable(t) >= 0) {
+ if ((ret = dmc_variable(context, heap, text, t, constant))
+ != retOk)
+ return ret;
+ break;
+ } else if (t == am_DollarUnderscore) {
+ if ((ret = dmc_whole_expression(context, heap, text, t, constant))
+ != retOk)
+ return ret;
+ break;
+ } else if (t == am_DollarDollar) {
+ if ((ret = dmc_all_bindings(context, heap, text, t, constant))
+ != retOk)
+ return ret;
+ break;
+ }
+ /* Fall through */
+ default:
+ simple_term:
+ *constant = 1;
+ }
+ return retOk;
+}
+
+
+static DMCRet compile_guard_expr(DMCContext *context,
+ DMCHeap *heap,
+ DMC_STACK_TYPE(Uint) *text,
+ Eterm l)
+{
+ DMCRet ret;
+ int constant;
+ Eterm t;
+
+ if (l != NIL) {
+ if (!is_list(l))
+ RETURN_ERROR("Match expression is not a list.",
+ context, constant);
+ if (!(context->is_guard)) {
+ DMC_PUSH(*text, matchCatch);
+ }
+ while (is_list(l)) {
+ constant = 0;
+ t = CAR(list_val(l));
+ if ((ret = dmc_expr(context, heap, text, t, &constant)) !=
+ retOk)
+ return ret;
+ if (constant) {
+ do_emit_constant(context, text, t);
+ }
+ l = CDR(list_val(l));
+ if (context->is_guard) {
+ DMC_PUSH(*text,matchTrue);
+ } else {
+ DMC_PUSH(*text,matchWaste);
+ }
+ --context->stack_used;
+ }
+ if (l != NIL)
+ RETURN_ERROR("Match expression is not a proper list.",
+ context, constant);
+ if (!(context->is_guard) && (context->cflags & DCOMP_TABLE)) {
+ ASSERT(matchWaste == DMC_TOP(*text));
+ (void) DMC_POP(*text);
+ DMC_PUSH(*text, matchReturn); /* Same impact on stack as
+ matchWaste */
+ }
+ }
+ return retOk;
+}
+
+
+
+
+/*
+** Match compilation utility code
+*/
+
+/*
+** Handling of bif's in match guard expressions
+*/
+
+static DMCGuardBif *dmc_lookup_bif(Eterm t, int arity)
+{
+ /*
+ ** Place for optimization, bsearch is slower than inlining it...
+ */
+ DMCGuardBif node = {0,NULL,0};
+ node.name = t;
+ node.arity = arity;
+ return bsearch(&node,
+ guard_tab,
+ sizeof(guard_tab) / sizeof(DMCGuardBif),
+ sizeof(DMCGuardBif),
+ (int (*)(const void *, const void *)) &cmp_guard_bif);
+}
+
+#ifdef DMC_DEBUG
+static Eterm dmc_lookup_bif_reversed(void *f)
+{
+ int i;
+ for (i = 0; i < (sizeof(guard_tab) / sizeof(DMCGuardBif)); ++i)
+ if (f == guard_tab[i].biff)
+ return guard_tab[i].name;
+ return am_undefined;
+}
+#endif
+
+/* For sorting. */
+static int cmp_uint(void *a, void *b)
+{
+ if (*((unsigned *)a) < *((unsigned *)b))
+ return -1;
+ else
+ return (*((unsigned *)a) > *((unsigned *)b));
+}
+
+static int cmp_guard_bif(void *a, void *b)
+{
+ int ret;
+ if (( ret = ((int) atom_val(((DMCGuardBif *) a)->name)) -
+ ((int) atom_val(((DMCGuardBif *) b)->name)) ) == 0) {
+ ret = ((DMCGuardBif *) a)->arity - ((DMCGuardBif *) b)->arity;
+ }
+ return ret;
+}
+
+/*
+** Compact the variables in a match expression i e make {$1, $100, $1000}
+** become {$0,$1,$2}.
+*/
+static int match_compact(ErlHeapFragment *expr, DMCErrInfo *err_info)
+{
+ int i, j, a, n, x;
+ DMC_STACK_TYPE(unsigned) heap;
+ Eterm *p;
+ char buff[25] = "$"; /* large enough for 64 bit to */
+ int ret;
+
+ DMC_INIT_STACK(heap);
+
+ p = expr->mem;
+ i = expr->size;
+ while (i--) {
+ if (is_thing(*p)) {
+ a = thing_arityval(*p);
+ ASSERT(a <= i);
+ i -= a;
+ p += a;
+ } else if (is_atom(*p) && (n = db_is_variable(*p)) >= 0) {
+ x = DMC_STACK_NUM(heap);
+ for (j = 0; j < x && DMC_PEEK(heap,j) != n; ++j)
+ ;
+
+ if (j == x)
+ DMC_PUSH(heap,n);
+ }
+ ++p;
+ }
+ qsort(DMC_STACK_DATA(heap), DMC_STACK_NUM(heap), sizeof(unsigned),
+ (int (*)(const void *, const void *)) &cmp_uint);
+
+ if (err_info != NULL) { /* lint needs a translation table */
+ err_info->var_trans = erts_alloc(ERTS_ALC_T_DB_TRANS_TAB,
+ sizeof(unsigned)*DMC_STACK_NUM(heap));
+ sys_memcpy(err_info->var_trans, DMC_STACK_DATA(heap),
+ DMC_STACK_NUM(heap) * sizeof(unsigned));
+ err_info->num_trans = DMC_STACK_NUM(heap);
+ }
+
+ p = expr->mem;
+ i = expr->size;
+ while (i--) {
+ if (is_thing(*p)) {
+ a = thing_arityval(*p);
+ i -= a;
+ p += a;
+ } else if (is_atom(*p) && (n = db_is_variable(*p)) >= 0) {
+ x = DMC_STACK_NUM(heap);
+#ifdef HARDDEBUG
+ erts_fprintf(stderr, "%T");
+#endif
+ for (j = 0; j < x && DMC_PEEK(heap,j) != n; ++j)
+ ;
+ ASSERT(j < x);
+ sprintf(buff+1,"%u", (unsigned) j);
+ /* Yes, writing directly into terms, they ARE off heap */
+ *p = am_atom_put(buff, strlen(buff));
+ }
+ ++p;
+ }
+ ret = DMC_STACK_NUM(heap);
+ DMC_FREE(heap);
+ return ret;
+}
+
+/*
+** Simple size object that takes care of function calls and constant tuples
+*/
+static Uint my_size_object(Eterm t)
+{
+ Uint sum = 0;
+ Eterm tmp;
+ Eterm *p;
+ switch (t & _TAG_PRIMARY_MASK) {
+ case TAG_PRIMARY_LIST:
+ sum += 2 + my_size_object(CAR(list_val(t))) +
+ my_size_object(CDR(list_val(t)));
+ break;
+ case TAG_PRIMARY_BOXED:
+ if ((((*boxed_val(t)) &
+ _TAG_HEADER_MASK) >> _TAG_PRIMARY_SIZE) !=
+ (_TAG_HEADER_ARITYVAL >> _TAG_PRIMARY_SIZE)) {
+ goto simple_term;
+ }
+
+ if (arityval(*tuple_val(t)) == 1 && is_tuple(tmp = tuple_val(t)[1])) {
+ Uint i,n;
+ p = tuple_val(tmp);
+ n = arityval(p[0]);
+ sum += 1 + n;
+ for (i = 1; i <= n; ++i)
+ sum += my_size_object(p[i]);
+ } else if (arityval(*tuple_val(t)) == 2 &&
+ is_atom(tmp = tuple_val(t)[1]) &&
+ tmp == am_const) {
+ sum += size_object(tuple_val(t)[2]);
+ } else {
+ erl_exit(1,"Internal error, sizing unrecognized object in "
+ "(d)ets:match compilation.");
+ }
+ break;
+ default:
+ simple_term:
+ sum += size_object(t);
+ break;
+ }
+ return sum;
+}
+
+static Eterm my_copy_struct(Eterm t, Eterm **hp, ErlOffHeap* off_heap)
+{
+ Eterm ret = NIL, a, b;
+ Eterm *p;
+ Uint sz;
+ switch (t & _TAG_PRIMARY_MASK) {
+ case TAG_PRIMARY_LIST:
+ a = my_copy_struct(CAR(list_val(t)), hp, off_heap);
+ b = my_copy_struct(CDR(list_val(t)), hp, off_heap);
+ ret = CONS(*hp, a, b);
+ *hp += 2;
+ break;
+ case TAG_PRIMARY_BOXED:
+ if (BOXED_IS_TUPLE(t)) {
+ if (arityval(*tuple_val(t)) == 1 &&
+ is_tuple(a = tuple_val(t)[1])) {
+ Uint i,n;
+ Eterm *savep = *hp;
+ ret = make_tuple(savep);
+ p = tuple_val(a);
+ n = arityval(p[0]);
+ *hp += n + 1;
+ *savep++ = make_arityval(n);
+ for(i = 1; i <= n; ++i)
+ *savep++ = my_copy_struct(p[i], hp, off_heap);
+ } else if (arityval(*tuple_val(t)) == 2 &&
+ is_atom(a = tuple_val(t)[1]) &&
+ a == am_const) {
+ /* A {const, XXX} expression */
+ b = tuple_val(t)[2];
+ sz = size_object(b);
+ ret = copy_struct(b,sz,hp,off_heap);
+ } else {
+ erl_exit(1, "Trying to constant-copy non constant expression "
+ "0x%08x in (d)ets:match compilation.", (unsigned long) t);
+ }
+ } else {
+ sz = size_object(t);
+ ret = copy_struct(t,sz,hp,off_heap);
+ }
+ break;
+ default:
+ ret = t;
+ }
+ return ret;
+}
+
+/*
+** Compiled match bif interface
+*/
+/*
+** erlang:match_spec_test(MatchAgainst, MatchSpec, Type) ->
+** {ok, Return, Flags, Errors} | {error, Errors}
+** MatchAgainst -> if Type == trace: list() else tuple()
+** MatchSpec -> MatchSpec with body corresponding to Type
+** Type -> trace | table (only trace implemented in R5C)
+** Return -> if Type == trace TraceReturn else {BodyReturn, VariableBindings}
+** TraceReturn -> {true | false | term()}
+** BodyReturn -> term()
+** VariableBindings -> [term(), ...]
+** Errors -> [OneError, ...]
+** OneError -> {error, string()} | {warning, string()}
+** Flags -> [Flag, ...]
+** Flag -> return_trace (currently only flag)
+*/
+BIF_RETTYPE match_spec_test_3(BIF_ALIST_3)
+{
+ Eterm res;
+#ifdef DMC_DEBUG
+ if (BIF_ARG_3 == am_atom_put("dis",3)) {
+ test_disassemble_next = 1;
+ BIF_RET(am_true);
+ } else
+#endif
+ if (BIF_ARG_3 == am_trace) {
+ res = match_spec_test(BIF_P, BIF_ARG_1, BIF_ARG_2, 1);
+ if (is_value(res)) {
+ BIF_RET(res);
+ }
+ } else if (BIF_ARG_3 == am_table) {
+ res = match_spec_test(BIF_P, BIF_ARG_1, BIF_ARG_2, 0);
+ if (is_value(res)) {
+ BIF_RET(res);
+ }
+ }
+ BIF_ERROR(BIF_P, BADARG);
+}
+
+static Eterm match_spec_test(Process *p, Eterm against, Eterm spec, int trace)
+{
+ Eterm lint_res;
+ Binary *mps;
+ Eterm res;
+ Eterm ret;
+ Eterm flg;
+ Eterm *hp;
+ Eterm *arr;
+ int n;
+ Eterm l;
+ Uint32 ret_flags;
+ Uint sz;
+ Eterm *save_cp;
+
+ if (trace && !(is_list(against) || against == NIL)) {
+ return THE_NON_VALUE;
+ }
+ if (trace) {
+ lint_res = db_match_set_lint(p, spec, DCOMP_TRACE | DCOMP_FAKE_DESTRUCTIVE);
+ mps = db_match_set_compile(p, spec, DCOMP_TRACE | DCOMP_FAKE_DESTRUCTIVE);
+ } else {
+ lint_res = db_match_set_lint(p, spec, DCOMP_TABLE | DCOMP_FAKE_DESTRUCTIVE);
+ mps = db_match_set_compile(p, spec, DCOMP_TABLE | DCOMP_FAKE_DESTRUCTIVE);
+ }
+
+ if (mps == NULL) {
+ hp = HAlloc(p,3);
+ ret = TUPLE2(hp, am_error, lint_res);
+ } else {
+#ifdef DMC_DEBUG
+ if (test_disassemble_next) {
+ test_disassemble_next = 0;
+ db_match_dis(mps);
+ }
+#endif /* DMC_DEBUG */
+ l = against;
+ n = 0;
+ while (is_list(l)) {
+ ++n;
+ l = CDR(list_val(l));
+ }
+ if (trace) {
+ if (n)
+ arr = erts_alloc(ERTS_ALC_T_DB_TMP, sizeof(Eterm) * n);
+ else
+ arr = NULL;
+ l = against;
+ n = 0;
+ while (is_list(l)) {
+ arr[n] = CAR(list_val(l));
+ ++n;
+ l = CDR(list_val(l));
+ }
+ } else {
+ n = 0;
+ arr = (Eterm *) against;
+ }
+
+ /* We are in the context of a BIF,
+ {caller} should return 'undefined' */
+ save_cp = p->cp;
+ p->cp = NULL;
+ res = erts_match_set_run(p, mps, arr, n, &ret_flags);
+ p->cp = save_cp;
+ if (is_non_value(res)) {
+ res = am_false;
+ }
+ sz = size_object(res);
+ if (ret_flags & MATCH_SET_EXCEPTION_TRACE) sz += 2;
+ if (ret_flags & MATCH_SET_RETURN_TRACE) sz += 2;
+ hp = HAlloc(p, 5 + sz);
+ res = copy_struct(res, sz, &hp, &MSO(p));
+ flg = NIL;
+ if (ret_flags & MATCH_SET_EXCEPTION_TRACE) {
+ flg = CONS(hp, am_exception_trace, flg);
+ hp += 2;
+ }
+ if (ret_flags & MATCH_SET_RETURN_TRACE) {
+ flg = CONS(hp, am_return_trace, flg);
+ hp += 2;
+ }
+ if (trace && arr != NULL) {
+ erts_free(ERTS_ALC_T_DB_TMP, arr);
+ }
+ erts_bin_free(mps);
+ ret = TUPLE4(hp, am_atom_put("ok",2), res, flg, lint_res);
+ }
+ return ret;
+}
+
+static Eterm seq_trace_fake(Process *p, Eterm arg1)
+{
+ Eterm result = seq_trace_info_1(p,arg1);
+ if (is_tuple(result) && *tuple_val(result) == 2) {
+ return (tuple_val(result))[2];
+ }
+ return result;
+}
+
+#ifdef DMC_DEBUG
+/*
+** Disassemble match program
+*/
+static void db_match_dis(Binary *bp)
+{
+ MatchProg *prog = Binary2MatchProg(bp);
+ Uint *t = prog->text;
+ Uint n;
+ Eterm p;
+ int first;
+ ErlHeapFragment *tmp;
+
+ while (t < prog->prog_end) {
+ switch (*t) {
+ case matchTryMeElse:
+ ++t;
+ n = *t;
+ ++t;
+ erts_printf("TryMeElse\t%bpu\n", n);
+ break;
+ case matchArray:
+ ++t;
+ n = *t;
+ ++t;
+ erts_printf("Array\t%bpu\n", n);
+ break;
+ case matchArrayBind:
+ ++t;
+ n = *t;
+ ++t;
+ erts_printf("ArrayBind\t%bpu\n", n);
+ break;
+ case matchTuple:
+ ++t;
+ n = *t;
+ ++t;
+ erts_printf("Tuple\t%bpu\n", n);
+ break;
+ case matchPushT:
+ ++t;
+ n = *t;
+ ++t;
+ erts_printf("PushT\t%bpu\n", n);
+ break;
+ case matchPushL:
+ ++t;
+ erts_printf("PushL\n");
+ break;
+ case matchPop:
+ ++t;
+ erts_printf("Pop\n");
+ break;
+ case matchBind:
+ ++t;
+ n = *t;
+ ++t;
+ erts_printf("Bind\t%bpu\n", n);
+ break;
+ case matchCmp:
+ ++t;
+ n = *t;
+ ++t;
+ erts_printf("Cmp\t%bpu\n", n);
+ break;
+ case matchEqBin:
+ ++t;
+ p = (Eterm) *t;
+ ++t;
+ erts_printf("EqBin\t%p (%T)\n", t, p);
+ break;
+ case matchEqRef:
+ ++t;
+ n = thing_arityval(*t);
+ ++t;
+ erts_printf("EqRef\t(%d) {", (int) n);
+ first = 1;
+ while (n--) {
+ if (first)
+ first = 0;
+ else
+ erts_printf(", ");
+#ifdef ARCH_64
+ erts_printf("0x%016bpx", *t);
+#else
+ erts_printf("0x%08bpx", *t);
+#endif
+ ++t;
+ }
+ erts_printf("}\n");
+ break;
+ case matchEqBig:
+ ++t;
+ n = thing_arityval(*t);
+ ++t;
+ erts_printf("EqBig\t(%d) {", (int) n);
+ first = 1;
+ while (n--) {
+ if (first)
+ first = 0;
+ else
+ erts_printf(", ");
+#ifdef ARCH_64
+ erts_printf("0x%016bpx", *t);
+#else
+ erts_printf("0x%08bpx", *t);
+#endif
+ ++t;
+ }
+ erts_printf("}\n");
+ break;
+ case matchEqFloat:
+ ++t;
+ {
+ double num;
+ memcpy(&num,t, 2 * sizeof(*t));
+ t += 2;
+ erts_printf("EqFloat\t%f\n", num);
+ }
+ break;
+ case matchEq:
+ ++t;
+ p = (Eterm) *t;
+ ++t;
+ erts_printf("Eq \t%T\n", p);
+ break;
+ case matchList:
+ ++t;
+ erts_printf("List\n");
+ break;
+ case matchHalt:
+ ++t;
+ erts_printf("Halt\n");
+ break;
+ case matchSkip:
+ ++t;
+ erts_printf("Skip\n");
+ break;
+ case matchPushC:
+ ++t;
+ p = (Eterm) *t;
+ ++t;
+ erts_printf("PushC\t%T\n", p);
+ break;
+ case matchConsA:
+ ++t;
+ erts_printf("ConsA\n");
+ break;
+ case matchConsB:
+ ++t;
+ erts_printf("ConsB\n");
+ break;
+ case matchMkTuple:
+ ++t;
+ n = *t;
+ ++t;
+ erts_printf("MkTuple\t%bpu\n", n);
+ break;
+ case matchOr:
+ ++t;
+ n = *t;
+ ++t;
+ erts_printf("Or\t%bpu\n", n);
+ break;
+ case matchAnd:
+ ++t;
+ n = *t;
+ ++t;
+ erts_printf("And\t%bpu\n", n);
+ break;
+ case matchOrElse:
+ ++t;
+ n = *t;
+ ++t;
+ erts_printf("OrElse\t%bpu\n", n);
+ break;
+ case matchAndAlso:
+ ++t;
+ n = *t;
+ ++t;
+ erts_printf("AndAlso\t%bpu\n", n);
+ break;
+ case matchCall0:
+ ++t;
+ p = dmc_lookup_bif_reversed((void *) *t);
+ ++t;
+ erts_printf("Call0\t%T\n", p);
+ break;
+ case matchCall1:
+ ++t;
+ p = dmc_lookup_bif_reversed((void *) *t);
+ ++t;
+ erts_printf("Call1\t%T\n", p);
+ break;
+ case matchCall2:
+ ++t;
+ p = dmc_lookup_bif_reversed((void *) *t);
+ ++t;
+ erts_printf("Call2\t%T\n", p);
+ break;
+ case matchCall3:
+ ++t;
+ p = dmc_lookup_bif_reversed((void *) *t);
+ ++t;
+ erts_printf("Call3\t%T\n", p);
+ break;
+ case matchPushV:
+ ++t;
+ n = (Uint) *t;
+ ++t;
+ erts_printf("PushV\t%bpu\n", n);
+ break;
+ case matchTrue:
+ ++t;
+ erts_printf("True\n");
+ break;
+ case matchPushExpr:
+ ++t;
+ erts_printf("PushExpr\n");
+ break;
+ case matchPushArrayAsList:
+ ++t;
+ erts_printf("PushArrayAsList\n");
+ break;
+ case matchPushArrayAsListU:
+ ++t;
+ erts_printf("PushArrayAsListU\n");
+ break;
+ case matchSelf:
+ ++t;
+ erts_printf("Self\n");
+ break;
+ case matchWaste:
+ ++t;
+ erts_printf("Waste\n");
+ break;
+ case matchReturn:
+ ++t;
+ erts_printf("Return\n");
+ break;
+ case matchProcessDump:
+ ++t;
+ erts_printf("ProcessDump\n");
+ break;
+ case matchDisplay:
+ ++t;
+ erts_printf("Display\n");
+ break;
+ case matchIsSeqTrace:
+ ++t;
+ erts_printf("IsSeqTrace\n");
+ break;
+ case matchSetSeqToken:
+ ++t;
+ erts_printf("SetSeqToken\n");
+ break;
+ case matchSetSeqTokenFake:
+ ++t;
+ erts_printf("SetSeqTokenFake\n");
+ break;
+ case matchGetSeqToken:
+ ++t;
+ erts_printf("GetSeqToken\n");
+ break;
+ case matchSetReturnTrace:
+ ++t;
+ erts_printf("SetReturnTrace\n");
+ break;
+ case matchSetExceptionTrace:
+ ++t;
+ erts_printf("SetReturnTrace\n");
+ break;
+ case matchCatch:
+ ++t;
+ erts_printf("Catch\n");
+ break;
+ case matchEnableTrace:
+ ++t;
+ erts_printf("EnableTrace\n");
+ break;
+ case matchDisableTrace:
+ ++t;
+ erts_printf("DisableTrace\n");
+ break;
+ case matchEnableTrace2:
+ ++t;
+ erts_printf("EnableTrace2\n");
+ break;
+ case matchDisableTrace2:
+ ++t;
+ erts_printf("DisableTrace2\n");
+ break;
+ case matchTrace2:
+ ++t;
+ erts_printf("Trace2\n");
+ break;
+ case matchTrace3:
+ ++t;
+ erts_printf("Trace3\n");
+ break;
+ case matchCaller:
+ ++t;
+ erts_printf("Caller\n");
+ break;
+ default:
+ erts_printf("??? (0x%08x)\n", *t);
+ ++t;
+ break;
+ }
+ }
+ erts_printf("\n\nterm_save: {");
+ first = 1;
+ for (tmp = prog->term_save; tmp; tmp = tmp->next) {
+ if (first)
+ first = 0;
+ else
+ erts_printf(", ");
+ erts_printf("0x%08x", (unsigned long) tmp);
+ }
+ erts_printf("}\n");
+ erts_printf("num_bindings: %d\n", prog->num_bindings);
+ erts_printf("heap_size: %bpu\n", prog->heap_size);
+ erts_printf("eheap_offset: %bpu\n", prog->eheap_offset);
+ erts_printf("stack_offset: %bpu\n", prog->stack_offset);
+ erts_printf("text: 0x%08x\n", (unsigned long) prog->text);
+ erts_printf("stack_size: %d (words)\n", prog->heap_size-prog->stack_offset);
+
+}
+
+#endif /* DMC_DEBUG */
+
+