/* * %CopyrightBegin% * * Copyright Ericsson AB 1998-2010. 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) #define TermWords(t) (((t) / (sizeof(UWord)/sizeof(Eterm))) + !!((t) % (sizeof(UWord)/sizeof(Eterm)))) 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(UWord); 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.first) { 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++) { #if defined(ARCH_64) && !HALFWORD_HEAP 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(UWord) *text, Eterm t); static DMCRet dmc_list(DMCContext *context, DMCHeap *heap, DMC_STACK_TYPE(UWord) *text, Eterm t, int *constant); static DMCRet dmc_tuple(DMCContext *context, DMCHeap *heap, DMC_STACK_TYPE(UWord) *text, Eterm t, int *constant); static DMCRet dmc_variable(DMCContext *context, DMCHeap *heap, DMC_STACK_TYPE(UWord) *text, Eterm t, int *constant); static DMCRet dmc_fun(DMCContext *context, DMCHeap *heap, DMC_STACK_TYPE(UWord) *text, Eterm t, int *constant); static DMCRet dmc_expr(DMCContext *context, DMCHeap *heap, DMC_STACK_TYPE(UWord) *text, Eterm t, int *constant); static DMCRet compile_guard_expr(DMCContext *context, DMCHeap *heap, DMC_STACK_TYPE(UWord) *text, Eterm t); /* match expression subroutine */ static DMCRet dmc_one_term(DMCContext *context, DMCHeap *heap, DMC_STACK_TYPE(Eterm) *stack, DMC_STACK_TYPE(UWord) *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, NIL, 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. */ } static Eterm erts_match_set_run_ets(Process *p, Binary *mpsp, Eterm args, int num_args, Uint32 *return_flags) { Eterm ret; ret = db_prog_match(p, mpsp, args, NULL, 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(UWord) 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 two 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(UWord)) + (DMC_STACK_NUM(text) * sizeof(UWord))), 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(UWord)); 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. */ if (context.save != NULL) { free_message_buffer(context.save); context.save = NULL; } 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; if (bprog == NULL) return; prog = Binary2MatchProg(bprog); if (prog->term_save != NULL) { free_message_buffer(prog->term_save); } 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, Eterm *termp, int arity, Uint32 *return_flags) { MatchProg *prog = Binary2MatchProg(bprog); Eterm *ep; Eterm *tp; Eterm t; Eterm **sp; Eterm *esp; Eterm *hp; BeamInstr *cp; UWord *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 Uint *heap_fence; Uint *eheap_fence; Uint *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 = (Uint *) mpsp->heap + prog->eheap_offset - 1; eheap_fence = (Uint *) mpsp->heap + prog->stack_offset - 1; stack_fence = (Uint *) 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 = termp; break; case matchArrayBind: /* When the array size is unknown. */ n = *pc++; hp[n] = dpm_array_to_list(psp, termp, 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 += TermWords(2); ++ep; break; case matchEqRef: if (!is_ref(*ep)) FAIL(); if (!eq(*ep, make_internal_ref((Uint *) pc))) FAIL(); i = thing_arityval(*((Uint *) pc)); pc += TermWords(i+1); ++ep; break; case matchEqBig: if (!is_big(*ep)) FAIL(); tp = big_val(*ep); { Eterm *epc = (Eterm *) pc; if (*tp != *epc) FAIL(); i = BIG_ARITY(epc); pc += TermWords(i+1); while(i--) { if (*++tp != *++epc) { FAIL(); } } } ++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 = termp; *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, termp, 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) || !(cp = find_function_from_pc(c_p->cp))) { *esp++ = am_undefined; } else { *esp++ = make_tuple(ehp); ehp[0] = make_arityval(3); ehp[1] = cp[0]; ehp[2] = cp[1]; ehp[3] = make_small((Uint) cp[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) { DeclareTmpHeapNoproc(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 { UseTmpHeapNoproc(2); 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: UnUseTmpHeapNoproc(2); return THE_NON_VALUE; } res = big_plus(arg1, arg2, *hpp); if (is_big(res)) { *hpp += BIG_NEED_SIZE(big_size(res)); } UnUseTmpHeapNoproc(2); 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; ErlOffHeap tmp_offheap; if (old != 0) { tmp_offheap.first = old->first_oh; tmp_offheap.overhead = 0; erts_cleanup_offheap(&tmp_offheap); old->first_oh = tmp_offheap.first; 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; tmp_offheap.first = NULL; tmp_offheap.overhead = 0; top = DBTERM_BUF(p); copy = copy_struct(obj, size, &top, &tmp_offheap); p->first_oh = tmp_offheap.first; DBTERM_SET_TPL(p,tuple_val(copy)); return structp; } void db_free_term_data(DbTerm* p) { ErlOffHeap tmp_offheap; tmp_offheap.first = p->first_oh; tmp_offheap.overhead = 0; erts_cleanup_offheap(&tmp_offheap); } /* ** 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(UWord) *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): DMC_PUSH(*text, matchEqRef); #if HALFWORD_HEAP { union { UWord u; Uint t[2]; } fiddle; ASSERT(thing_arityval(*internal_ref_val(c)) == 3); fiddle.t[0] = *internal_ref_val(c); fiddle.t[1] = (Uint) internal_ref_val(c)[1]; DMC_PUSH(*text, fiddle.u); fiddle.t[0] = (Uint) internal_ref_val(c)[2]; fiddle.t[1] = (Uint) internal_ref_val(c)[3]; DMC_PUSH(*text, fiddle.u); } #else n = thing_arityval(*internal_ref_val(c)); DMC_PUSH(*text, *internal_ref_val(c)); for (i = 1; i <= n; ++i) { DMC_PUSH(*text, (Uint) internal_ref_val(c)[i]); } #endif 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); #if HALFWORD_HEAP { union { UWord u; Uint t[2]; } fiddle; ASSERT(n >= 1); fiddle.t[0] = *big_val(c); fiddle.t[1] = big_val(c)[1]; DMC_PUSH(*text, fiddle.u); for (i = 2; i <= n; ++i) { fiddle.t[0] = big_val(c)[i]; if (++i <= n) { fiddle.t[1] = big_val(c)[i]; } else { fiddle.t[1] = (Uint) 0; } DMC_PUSH(*text, fiddle.u); } } #else DMC_PUSH(*text, *big_val(c)); for (i = 1; i <= n; ++i) { DMC_PUSH(*text, (Uint) big_val(c)[i]); } #endif break; case (_TAG_HEADER_FLOAT >> _TAG_PRIMARY_SIZE): DMC_PUSH(*text,matchEqFloat); #if HALFWORD_HEAP { union { UWord u; Uint t[2]; } fiddle; fiddle.t[0] = float_val(c)[1]; fiddle.t[1] = float_val(c)[2]; DMC_PUSH(*text, fiddle.u); } #else DMC_PUSH(*text, (Uint) float_val(c)[1]); #ifdef ARCH_64 DMC_PUSH(*text, (Uint) 0); #else DMC_PUSH(*text, (Uint) float_val(c)[2]); #endif #endif 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(UWord) *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(UWord) *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(UWord) *text, Eterm t, int *constant) { DMC_STACK_TYPE(UWord) 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(UWord) *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(UWord) *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(UWord) *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(UWord) *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(UWord) *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(UWord) *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(UWord) *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(UWord) *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(UWord) *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(UWord) *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(UWord) *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(UWord) *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(UWord) *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(UWord) *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(UWord) *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(UWord) *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(UWord) *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(UWord) *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(UWord) *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(UWord) *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(UWord) *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(UWord) *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(UWord) *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, (UWord) 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(UWord) *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(UWord) *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->used_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->used_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; BeamInstr *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)); } save_cp = p->cp; p->cp = NULL; res = erts_match_set_run(p, mps, arr, n, &ret_flags); p->cp = save_cp; } else { n = 0; arr = NULL; res = erts_match_set_run_ets(p, mps, against, n, &ret_flags); } /* We are in the context of a BIF, {caller} should return 'undefined' */ 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); UWord *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; { RefThing *rt = (RefThing *) t; int ri; n = thing_arityval(rt->header); erts_printf("EqRef\t(%d) {", (int) n); first = 1; for (ri = 0; ri < n; ++ri) { if (first) first = 0; else erts_printf(", "); #if defined(ARCH_64) && !HALFWORD_HEAP erts_printf("0x%016bpx", rt->data.ui[ri]); #else erts_printf("0x%08bpx", rt->data.ui[ri]); #endif } } t += TermWords(REF_THING_SIZE); erts_printf("}\n"); break; case matchEqBig: ++t; n = thing_arityval(*t); { Eterm *et = (Eterm *) t; t += TermWords(n+1); erts_printf("EqBig\t(%d) {", (int) n); first = 1; ++n; while (n--) { if (first) first = 0; else erts_printf(", "); #if defined(ARCH_64) && !HALFWORD_HEAP erts_printf("0x%016bpx", *et); #else erts_printf("0x%08bpx", *et); #endif ++et; } } erts_printf("}\n"); break; case matchEqFloat: ++t; { double num; memcpy(&num,t,sizeof(double)); t += TermWords(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 */