diff options
Diffstat (limited to 'erts/emulator/beam/erl_db_util.c')
| -rw-r--r-- | erts/emulator/beam/erl_db_util.c | 4651 |
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, + ¬_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 */ + + |