in erts/emulator/beam/erl_db_util.c [2005:2792]
Eterm db_prog_match(Process *c_p,
Process *self,
Binary *bprog,
Eterm term,
Eterm *termp,
int arity,
enum erts_pam_run_flags in_flags,
Uint32 *return_flags)
{
MatchProg *prog = Binary2MatchProg(bprog);
const Eterm *ep, *tp, **sp;
Eterm t;
Eterm *esp;
MatchVariable* variables;
ErtsCodeMFA *cp;
const UWord *pc = prog->text;
Eterm *ehp;
Eterm ret;
Uint n;
int i;
unsigned do_catch;
ErtsMatchPseudoProcess *mpsp;
Process *psp;
Process* build_proc;
Process *tmpp;
Process *current_scheduled;
ErtsSchedulerData *esdp;
BIF_RETTYPE (*bif)(BIF_ALIST);
Eterm bif_args[3];
int fail_label;
#ifdef DMC_DEBUG
Uint *heap_fence;
Uint *stack_fence;
Uint save_op;
#endif /* DMC_DEBUG */
ERTS_UNDEF(n,0);
ERTS_UNDEF(current_scheduled,NULL);
ASSERT(c_p || !(in_flags & ERTS_PAM_COPY_RESULT));
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();
if (esdp)
current_scheduled = esdp->current_process;
/* SMP: psp->scheduler_data is set by get_match_pseudo_process */
#ifdef DMC_DEBUG
save_op = 0;
heap_fence = (Eterm*)((char*) mpsp->u.heap + prog->stack_offset) - 1;
stack_fence = (Eterm*)((char*) mpsp->u.heap + prog->heap_size) - 1;
*heap_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;
variables = mpsp->u.variables;
restart:
ep = &term;
esp = (Eterm*)((char*)mpsp->u.heap + prog->stack_offset);
sp = (const Eterm **)esp;
ret = am_true;
do_catch = 0;
fail_label = -1;
build_proc = psp;
if (esdp)
esdp->current_process = psp;
#ifdef DEBUG
ASSERT(variables == mpsp->u.variables);
for (i=0; i<prog->num_bindings; i++) {
variables[i].term = THE_NON_VALUE;
variables[i].proc = NULL;
}
#endif
for (;;) {
#ifdef DMC_DEBUG
if (*heap_fence != FENCE_PATTERN) {
erts_exit(ERTS_ERROR_EXIT, "Heap fence overwritten in db_prog_match after op "
"0x%08x, overwritten with 0x%08x.", save_op, *heap_fence);
}
if (*stack_fence != FENCE_PATTERN) {
erts_exit(ERTS_ERROR_EXIT, "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:
ASSERT(fail_label == -1);
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. */
ASSERT(termp || arity==0);
n = *pc++;
variables[n].term = 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 matchMap:
if (!is_map(*ep)) {
FAIL();
}
n = *pc++;
if (is_flatmap(*ep)) {
if (flatmap_get_size(flatmap_val(*ep)) < n) {
FAIL();
}
} else {
ASSERT(is_hashmap(*ep));
if (hashmap_size(*ep) < n) {
FAIL();
}
}
ep = flatmap_val(*ep);
break;
case matchPushM:
if (!is_map(*ep)) {
FAIL();
}
n = *pc++;
if (is_flatmap(*ep)) {
if (flatmap_get_size(flatmap_val(*ep)) < n) {
FAIL();
}
} else {
ASSERT(is_hashmap(*ep));
if (hashmap_size(*ep) < n) {
FAIL();
}
}
*sp++ = flatmap_val(*ep++);
break;
case matchKey:
t = (Eterm) *pc++;
tp = erts_maps_get(t, make_boxed(ep));
if (!tp) {
FAIL();
}
*sp++ = ep;
ep = tp;
break;
case matchPop:
ep = *(--sp);
break;
case matchSwap:
tp = sp[-1];
sp[-1] = sp[-2];
sp[-2] = tp;
break;
case matchBind:
n = *pc++;
variables[n].term = *ep++;
break;
case matchCmp:
n = *pc++;
if (!EQ(variables[n].term, *ep))
FAIL();
++ep;
break;
case matchEqBin:
t = (Eterm) *pc++;
if (!EQ(t,*ep))
FAIL();
++ep;
break;
case matchEqFloat:
if (!is_float(*ep))
FAIL();
if (sys_memcmp(float_val(*ep) + 1, pc, sizeof(double)))
FAIL();
pc += TermWords(2);
++ep;
break;
case matchEqRef: {
Eterm* epc = (Eterm*)pc;
if (!is_ref(*ep))
FAIL();
if (!EQ(make_internal_ref(epc), *ep)) {
FAIL();
}
i = thing_arityval(*epc);
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++;
ASSERT(is_immed(t));
if (t != *ep++)
FAIL();
break;
case matchSkip:
++ep;
break;
/*
* Here comes guard & body instructions
*/
case matchPushC: /* Push constant */
if ((in_flags & ERTS_PAM_COPY_RESULT)
&& do_catch && !is_immed(*pc)) {
*esp++ = copy_object(*pc++, c_p);
}
else {
*esp++ = *pc++;
}
break;
case matchConsA:
ehp = HAllocX(build_proc, 2, HEAP_XTRA);
CDR(ehp) = *--esp;
CAR(ehp) = esp[-1];
esp[-1] = make_list(ehp);
break;
case matchConsB:
ehp = HAllocX(build_proc, 2, HEAP_XTRA);
CAR(ehp) = *--esp;
CDR(ehp) = esp[-1];
esp[-1] = make_list(ehp);
break;
case matchMkTuple:
n = *pc++;
ehp = HAllocX(build_proc, n+1, HEAP_XTRA);
t = make_tuple(ehp);
*ehp++ = make_arityval(n);
while (n--) {
*ehp++ = *--esp;
}
*esp++ = t;
break;
case matchMkFlatMap:
n = *pc++;
ehp = HAllocX(build_proc, MAP_HEADER_FLATMAP_SZ + n, HEAP_XTRA);
t = *--esp;
{
flatmap_t *m = (flatmap_t *)ehp;
m->thing_word = MAP_HEADER_FLATMAP;
m->size = n;
m->keys = t;
}
t = make_flatmap(ehp);
ehp += MAP_HEADER_FLATMAP_SZ;
while (n--) {
*ehp++ = *--esp;
}
*esp++ = t;
break;
case matchMkHashMap:
n = *pc++;
esp -= 2*n;
ehp = HAllocX(build_proc, 2*n, HEAP_XTRA);
{
ErtsHeapFactory factory;
Uint ix;
for (ix = 0; ix < 2*n; ix++){
ehp[ix] = esp[ix];
}
erts_factory_proc_init(&factory, build_proc);
t = erts_hashmap_from_array(&factory, ehp, n, 0);
erts_factory_close(&factory);
}
*esp++ = t;
break;
case matchCall0:
bif = (BIF_RETTYPE (*)(BIF_ALIST)) *pc++;
t = (*bif)(build_proc, bif_args, NULL);
if (is_non_value(t)) {
if (do_catch)
t = FAIL_TERM;
else
FAIL();
}
*esp++ = t;
break;
case matchCall1:
bif = (BIF_RETTYPE (*)(BIF_ALIST)) *pc++;
t = (*bif)(build_proc, esp-1, NULL);
if (is_non_value(t)) {
if (do_catch)
t = FAIL_TERM;
else
FAIL();
}
esp[-1] = t;
break;
case matchCall2:
bif = (BIF_RETTYPE (*)(BIF_ALIST)) *pc++;
bif_args[0] = esp[-1];
bif_args[1] = esp[-2];
t = (*bif)(build_proc, bif_args, NULL);
if (is_non_value(t)) {
if (do_catch)
t = FAIL_TERM;
else
FAIL();
}
--esp;
esp[-1] = t;
break;
case matchCall3:
bif = (BIF_RETTYPE (*)(BIF_ALIST)) *pc++;
bif_args[0] = esp[-1];
bif_args[1] = esp[-2];
bif_args[2] = esp[-3];
t = (*bif)(build_proc, bif_args, NULL);
if (is_non_value(t)) {
if (do_catch)
t = FAIL_TERM;
else
FAIL();
}
esp -= 2;
esp[-1] = t;
break;
case matchPushVResult:
if (!(in_flags & ERTS_PAM_COPY_RESULT)) goto case_matchPushV;
/* Build copy on callers heap */
n = *pc++;
ASSERT(is_value(variables[n].term));
ASSERT(!variables[n].proc);
variables[n].term = copy_object_x(variables[n].term, c_p, HEAP_XTRA);
*esp++ = variables[n].term;
#ifdef DEBUG
variables[n].proc = c_p;
#endif
break;
case matchPushV:
case_matchPushV:
n = *pc++;
ASSERT(is_value(variables[n].term));
*esp++ = variables[n].term;
break;
case matchPushExpr:
if (in_flags & ERTS_PAM_COPY_RESULT) {
Uint sz;
Eterm* top;
sz = size_object(term);
top = HAllocX(build_proc, sz, HEAP_XTRA);
if (in_flags & ERTS_PAM_CONTIGUOUS_TUPLE) {
ASSERT(is_tuple(term));
*esp++ = copy_shallow(tuple_val(term), sz, &top, &MSO(build_proc));
}
else {
*esp++ = copy_struct(term, sz, &top, &MSO(build_proc));
}
}
else {
*esp++ = term;
}
break;
case matchPushArrayAsList:
n = arity; /* Only happens when 'term' is an array */
tp = termp;
ehp = HAllocX(build_proc, n*2, HEAP_XTRA);
*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(build_proc, 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++ = self->common.id;
break;
case matchWaste:
--esp;
break;
case matchReturn:
ret = *--esp;
break;
case matchProcessDump: {
erts_dsprintf_buf_t *dsbufp = erts_create_tmp_dsbuf(0);
ASSERT(c_p == self);
print_process_info(ERTS_PRINT_DSBUF, (void *) dsbufp, c_p, ERTS_PROC_LOCK_MAIN);
*esp++ = new_binary(build_proc, (byte *)dsbufp->str,
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:
ASSERT(c_p == self);
if (have_seqtrace(SEQ_TRACE_TOKEN(c_p)))
*esp++ = am_true;
else
*esp++ = am_false;
break;
case matchSetSeqToken:
ASSERT(c_p == self);
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:
ASSERT(c_p == self);
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:
ASSERT(c_p == self);
if (have_no_seqtrace(SEQ_TRACE_TOKEN(c_p)))
*esp++ = NIL;
else {
Eterm token;
Uint token_sz;
ASSERT(SEQ_TRACE_TOKEN_ARITY(c_p) == 5);
ASSERT(is_immed(SEQ_TRACE_TOKEN_FLAGS(c_p)));
ASSERT(is_immed(SEQ_TRACE_TOKEN_SERIAL(c_p)));
ASSERT(is_immed(SEQ_TRACE_TOKEN_LASTCNT(c_p)));
token = SEQ_TRACE_TOKEN(c_p);
token_sz = size_object(token);
ehp = HAllocX(build_proc, token_sz, HEAP_XTRA);
*esp++ = copy_struct(token, token_sz, &ehp, &MSO(build_proc));
}
break;
case matchEnableTrace:
ASSERT(c_p == self);
if ( (n = erts_trace_flag2bit(esp[-1]))) {
erts_proc_lock(c_p, ERTS_PROC_LOCKS_ALL_MINOR);
set_tracee_flags(c_p, ERTS_TRACER(c_p), 0, n);
erts_proc_unlock(c_p, ERTS_PROC_LOCKS_ALL_MINOR);
esp[-1] = am_true;
} else {
esp[-1] = FAIL_TERM;
}
break;
case matchEnableTrace2:
ASSERT(c_p == self);
n = erts_trace_flag2bit((--esp)[-1]);
esp[-1] = FAIL_TERM;
if (n) {
if ( (tmpp = get_proc(c_p, ERTS_PROC_LOCK_MAIN, esp[0], ERTS_PROC_LOCKS_ALL))) {
/* Always take over the tracer of the current process */
set_tracee_flags(tmpp, ERTS_TRACER(c_p), 0, n);
if (tmpp == c_p)
erts_proc_unlock(tmpp, ERTS_PROC_LOCKS_ALL_MINOR);
else
erts_proc_unlock(tmpp, ERTS_PROC_LOCKS_ALL);
esp[-1] = am_true;
}
}
break;
case matchDisableTrace:
ASSERT(c_p == self);
if ( (n = erts_trace_flag2bit(esp[-1]))) {
erts_proc_lock(c_p, ERTS_PROC_LOCKS_ALL_MINOR);
set_tracee_flags(c_p, ERTS_TRACER(c_p), n, 0);
erts_proc_unlock(c_p, ERTS_PROC_LOCKS_ALL_MINOR);
esp[-1] = am_true;
} else {
esp[-1] = FAIL_TERM;
}
break;
case matchDisableTrace2:
ASSERT(c_p == self);
n = erts_trace_flag2bit((--esp)[-1]);
esp[-1] = FAIL_TERM;
if (n) {
if ( (tmpp = get_proc(c_p, ERTS_PROC_LOCK_MAIN, esp[0], ERTS_PROC_LOCKS_ALL))) {
/* Always take over the tracer of the current process */
set_tracee_flags(tmpp, ERTS_TRACER(c_p), n, 0);
if (tmpp == c_p)
erts_proc_unlock(tmpp, ERTS_PROC_LOCKS_ALL_MINOR);
else
erts_proc_unlock(tmpp, ERTS_PROC_LOCKS_ALL);
esp[-1] = am_true;
}
}
break;
case matchCaller:
ASSERT(c_p == self);
t = c_p->stop[0];
if (is_not_CP(t)) {
*esp++ = am_undefined;
} else if (!(cp = erts_find_function_from_pc(cp_val(t)))) {
*esp++ = am_undefined;
} else {
ehp = HAllocX(build_proc, 4, HEAP_XTRA);
*esp++ = make_tuple(ehp);
ehp[0] = make_arityval(3);
ehp[1] = cp->module;
ehp[2] = cp->function;
ehp[3] = make_small((Uint) cp->arity);
}
break;
case matchSilent:
ASSERT(c_p == self);
--esp;
if (in_flags & ERTS_PAM_IGNORE_TRACE_SILENT)
break;
if (*esp == am_true) {
erts_proc_lock(c_p, ERTS_PROC_LOCKS_ALL_MINOR);
ERTS_TRACE_FLAGS(c_p) |= F_TRACE_SILENT;
erts_proc_unlock(c_p, ERTS_PROC_LOCKS_ALL_MINOR);
}
else if (*esp == am_false) {
erts_proc_lock(c_p, ERTS_PROC_LOCKS_ALL_MINOR);
ERTS_TRACE_FLAGS(c_p) &= ~F_TRACE_SILENT;
erts_proc_unlock(c_p, ERTS_PROC_LOCKS_ALL_MINOR);
}
break;
case matchTrace2:
ASSERT(c_p == self);
{
/* disable enable */
Uint d_flags = 0, e_flags = 0; /* process trace flags */
ErtsTracer tracer = erts_tracer_nil;
/* 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 ERTS_TRACER_PROC(c_p)
* 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;
erts_tracer_update(&tracer, ERTS_TRACER(c_p));
if (! erts_trace_flags(esp[-1], &d_flags, &tracer, &cputs) ||
! erts_trace_flags(esp[-2], &e_flags, &tracer, &cputs) ||
cputs ) {
(--esp)[-1] = FAIL_TERM;
ERTS_TRACER_CLEAR(&tracer);
break;
}
erts_proc_lock(c_p, ERTS_PROC_LOCKS_ALL_MINOR);
(--esp)[-1] = set_match_trace(c_p, FAIL_TERM, tracer,
d_flags, e_flags);
erts_proc_unlock(c_p, ERTS_PROC_LOCKS_ALL_MINOR);
ERTS_TRACER_CLEAR(&tracer);
}
break;
case matchTrace3:
ASSERT(c_p == self);
{
/* disable enable */
Uint d_flags = 0, e_flags = 0; /* process trace flags */
ErtsTracer tracer = erts_tracer_nil;
/* XXX Atomicity note. Not fully atomic. See above.
* Above it could possibly be solved, but not here.
*/
int cputs = 0;
Eterm tracee = (--esp)[0];
erts_tracer_update(&tracer, ERTS_TRACER(c_p));
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;
ERTS_TRACER_CLEAR(&tracer);
break;
}
if (tmpp == c_p) {
(--esp)[-1] = set_match_trace(c_p, FAIL_TERM, tracer,
d_flags, e_flags);
erts_proc_unlock(c_p, ERTS_PROC_LOCKS_ALL_MINOR);
} else {
erts_proc_unlock(c_p, ERTS_PROC_LOCK_MAIN);
(--esp)[-1] = set_match_trace(tmpp, FAIL_TERM, tracer,
d_flags, e_flags);
erts_proc_unlock(tmpp, ERTS_PROC_LOCKS_ALL);
erts_proc_lock(c_p, ERTS_PROC_LOCK_MAIN);
}
ERTS_TRACER_CLEAR(&tracer);
}
break;
case matchCatch: /* Match success, now build result */
do_catch = 1;
if (in_flags & ERTS_PAM_COPY_RESULT) {
build_proc = c_p;
if (esdp)
esdp->current_process = c_p;
}
break;
case matchHalt:
goto success;
default:
erts_exit(ERTS_ERROR_EXIT, "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) {
erts_exit(ERTS_ERROR_EXIT, "Heap fence overwritten in db_prog_match after op "
"0x%08x, overwritten with 0x%08x.", save_op, *heap_fence);
}
if (*stack_fence != FENCE_PATTERN) {
erts_exit(ERTS_ERROR_EXIT, "Stack fence overwritten in db_prog_match after op "
"0x%08x, overwritten with 0x%08x.", save_op,
*stack_fence);
}
#endif
if (esdp)
esdp->current_process = current_scheduled;
return ret;
#undef FAIL
#undef FAIL_TERM
}