/*
* %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;
/* 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);
static void db_free_tmp_uncompressed(DbTerm* obj);
/*
** 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, (erts_aint_t) 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, NULL, 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, 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 parameter '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* base,
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;
#if HALFWORD_HEAP
int is_abs_variables = (base == NULL);
#endif
#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;
#if HALFWORD_HEAP /* clear all variables for matchPushV */
for (i=prog->eheap_offset-(1+FENCE_PATTERN_SIZE); i>=0; i--) {
hp[i] = NIL;
}
#endif
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_rel(*ep,base))
FAIL();
ep = tuple_val_rel(*ep,base);
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_rel(*ep,base))
FAIL();
tp = tuple_val_rel(*ep,base);
n = *pc++;
if (arityval(*tp) != n)
FAIL();
*sp++ = tp + 1;
++ep;
break;
case matchList:
if (!is_list(*ep))
FAIL();
ep = list_val_rel(*ep,base);
break;
case matchPushL:
if (!is_list(*ep))
FAIL();
*sp++ = list_val_rel(*ep,base);
++ep;
break;
case matchPop:
ep = *(--sp);
break;
case matchBind:
ASSERT_HALFWORD(is_abs_variables == !base);
n = *pc++;
hp[n] = *ep++;
break;
case matchCmp:
ASSERT_HALFWORD(is_abs_variables == !base);
n = *pc++;
if (!eq_rel(hp[n],base,*ep,base))
FAIL();
++ep;
break;
case matchEqBin:
t = (Eterm) *pc++;
if (!eq_rel(t,NULL,*ep,base))
FAIL();
++ep;
break;
case matchEqFloat:
if (!is_float_rel(*ep,base))
FAIL();
if (memcmp(float_val_rel(*ep,base) + 1, pc, sizeof(double)))
FAIL();
pc += TermWords(2);
++ep;
break;
case matchEqRef:
if (!is_ref_rel(*ep,base))
FAIL();
if (!eq_rel(make_internal_ref((Uint *) pc), NULL, *ep, base))
FAIL();
i = thing_arityval(*((Uint *) pc));
pc += TermWords(i+1);
++ep;
break;
case matchEqBig:
if (!is_big_rel(*ep,base))
FAIL();
tp = big_val_rel(*ep,base);
{
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 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:
n = *pc++;
#if HALFWORD_HEAP
if (!is_abs_variables && !is_immed(hp[n])) {
for (i=prog->eheap_offset-1; i>=0; i--) if (!is_immed(hp[i])) {
Uint sz = size_object_rel(hp[i], base);
Eterm* top = HAlloc(psp, sz);
hp[i] = copy_struct_rel(hp[i], sz, &top, &MSO(psp), base, NULL);
}
is_abs_variables = 1;
}
#endif
*esp++ = hp[n];
break;
case matchPushExpr:
ASSERT(is_tuple_rel(term,base));
#if HALFWORD_HEAP
if (base) {
Uint sz = size_object_rel(term, base);
Eterm* top = HAlloc(psp, sz);
*esp++ = copy_shallow_rel(tuple_val_rel(term,base), sz,
&top, &MSO(psp), base);
break;
}
#endif
*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, Wterm counter, Eterm incr)
{
DeclareTmpHeapNoproc(big_tmp,2);
Eterm res;
Sint ires;
Wterm arg1;
Wterm 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;
}
}
/* Must be called to read elements after db_lookup_dbterm.
** Will decompress if needed.
** HEALFWORD_HEAP: Will convert from relative to Wterm format if needed.
*/
Wterm db_do_read_element(DbUpdateHandle* handle, Sint position)
{
#if HALFWORD_HEAP
Eterm elem = handle->new_tuple[position];
Eterm* base = handle->dbterm->tpl;
if (elem == THE_NON_VALUE) {
elem = handle->dbterm->tpl[position];
ASSERT(is_value(elem));
}
else if (handle->new_tuple != handle->dbterm->tpl
|| handle->tb->common.compress) {
base = NULL;
}
if (!is_header(elem)) {
return is_immed(elem) ? elem : rterm2wterm(elem, base);
}
#else
Eterm elem = handle->dbterm->tpl[position];
if (!is_header(elem)) {
return elem;
}
#endif
ASSERT(((DbTableCommon*)handle->tb)->compress);
ASSERT(!handle->mustResize);
handle->dbterm = db_alloc_tmp_uncompressed((DbTableCommon*)handle->tb, handle->dbterm);
handle->mustResize = 1;
#if HALFWORD_HEAP
handle->new_tuple = handle->dbterm->tpl;
#endif
return handle->dbterm->tpl[position];
}
/*
** 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)
{
#if HALFWORD_HEAP
Eterm oldval = handle->new_tuple[position];
Eterm* old_base;
Uint newval_sz;
Uint oldval_sz;
if (is_both_immed(newval,oldval)) {
handle->new_tuple[position] = newval;
#ifdef DEBUG_CLONE
if (handle->dbterm->debug_clone) {
handle->dbterm->debug_clone[position] = newval;
}
#endif
return;
}
if (handle->tb->common.compress) {
if (!handle->mustResize) {
handle->dbterm = db_alloc_tmp_uncompressed(&handle->tb->common,
handle->dbterm);
handle->mustResize = 1;
handle->new_tuple = handle->dbterm->tpl;
oldval = handle->dbterm->tpl[position];
}
old_base = NULL;
}
else {
if (handle->new_tuple == handle->dbterm->tpl) {
int i = header_arity(handle->new_tuple[0]);
handle->new_tuple = erts_alloc(ERTS_ALC_T_TMP, (i+1)*sizeof(Eterm));
handle->new_tuple[0] = handle->dbterm->tpl[0];
for ( ; i ; i--) {
handle->new_tuple[i] = THE_NON_VALUE;
}
}
if (handle->new_tuple[position] == THE_NON_VALUE) {
oldval = handle->dbterm->tpl[position];
old_base = handle->dbterm->tpl;
}
else {
old_base = NULL;
}
}
oldval_sz = is_immed(oldval) ? 0 : size_object_rel(oldval,old_base);
newval_sz = is_immed(newval) ? 0 : size_object(newval);
handle->new_size = handle->new_size - oldval_sz + newval_sz;
/* write new value in old dbterm, finalize will make a flat copy */
handle->new_tuple[position] = newval;
handle->mustResize = 1;
#else /****** !HALFWORD_HEAP ******/
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;
#ifdef DEBUG_CLONE
if (handle->dbterm->debug_clone) {
handle->dbterm->debug_clone[position] = newval;
}
#endif
return;
}
if (!handle->mustResize) {
if (handle->tb->common.compress) {
handle->dbterm = db_alloc_tmp_uncompressed(&handle->tb->common,
handle->dbterm);
handle->mustResize = 1;
oldval = handle->dbterm->tpl[position];
}
else if (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;
#endif /* !HALFWORD_HEAP */
}
static ERTS_INLINE byte* db_realloc_term(DbTableCommon* tb, void* old,
Uint old_sz, Uint new_sz, Uint offset)
{
byte* ret;
if (erts_ets_realloc_always_moves) {
ret = erts_db_alloc(ERTS_ALC_T_DB_TERM, (DbTable*)tb, new_sz);
sys_memcpy(ret, old, offset);
erts_db_free(ERTS_ALC_T_DB_TERM, (DbTable*)tb, old, old_sz);
} else {
ret = erts_db_realloc(ERTS_ALC_T_DB_TERM, (DbTable*)tb,
old, old_sz, new_sz);
}
return ret;
}
/* Allocated size of a compressed dbterm
*/
static ERTS_INLINE Uint db_alloced_size_comp(DbTerm* obj)
{
return obj->tpl[arityval(*obj->tpl) + 1];
}
void db_free_term(DbTable *tb, void* basep, Uint offset)
{
DbTerm* db = (DbTerm*) ((byte*)basep + offset);
Uint size;
if (tb->common.compress) {
db_cleanup_offheap_comp(db);
size = db_alloced_size_comp(db);
}
else {
ErlOffHeap tmp_oh;
tmp_oh.first = db->first_oh;
erts_cleanup_offheap(&tmp_oh);
size = offset + offsetof(DbTerm,tpl) + db->size*sizeof(Eterm);
}
erts_db_free(ERTS_ALC_T_DB_TERM, tb, basep, size);
}
static ERTS_INLINE Uint align_up(Uint value, Uint pow2)
{
ASSERT((pow2 & (pow2-1)) == 0);
return (value + (pow2-1)) & ~(pow2-1);
}
/* Compressed size of an uncompressed term
*/
static Uint db_size_dbterm_comp(DbTableCommon* tb, Eterm obj)
{
Eterm* tpl = tuple_val(obj);
int i;
Uint size = sizeof(DbTerm)
+ arityval(*tpl) * sizeof(Eterm)
+ sizeof(Uint); /* "alloc_size" */
for (i = arityval(*tpl); i>0; i--) {
if (i != tb->keypos && is_not_immed(tpl[i])) {
size += erts_encode_ext_size_ets(tpl[i]);
}
}
size += size_object(tpl[tb->keypos]) * sizeof(Eterm);
return align_up(size, sizeof(Uint));
}
/* Conversion between top tuple element and pointer to compressed data
*/
static ERTS_INLINE Eterm ext2elem(Eterm* tpl, byte* ext)
{
return (((Uint)(ext - (byte*)tpl)) << _TAG_PRIMARY_SIZE) | TAG_PRIMARY_HEADER;
}
static ERTS_INLINE byte* elem2ext(Eterm* tpl, Uint ix)
{
ASSERT(is_header(tpl[ix]));
return (byte*)tpl + (tpl[ix] >> _TAG_PRIMARY_SIZE);
}
static void* copy_to_comp(DbTableCommon* tb, Eterm obj, DbTerm* dest,
Uint alloc_size)
{
ErlOffHeap tmp_offheap;
Eterm* src = tuple_val(obj);
Eterm* tpl = dest->tpl;
Eterm key = src[tb->keypos];
int arity = arityval(src[0]);
union {
Eterm* ep;
byte* cp;
UWord ui;
}top;
int i;
top.ep = tpl+ 1 + arity + 1;
tpl[0] = src[0];
tpl[arity + 1] = alloc_size;
tmp_offheap.first = NULL;
tpl[tb->keypos] = copy_struct_rel(key, size_object(key), &top.ep, &tmp_offheap, NULL, tpl);
dest->first_oh = tmp_offheap.first;
for (i=1; i<=arity; i++) {
if (i != tb->keypos) {
if (is_immed(src[i])) {
tpl[i] = src[i];
}
else {
tpl[i] = ext2elem(tpl, top.cp);
top.cp = erts_encode_ext_ets(src[i], top.cp, &dest->first_oh);
}
}
}
#ifdef DEBUG_CLONE
{
Eterm* dbg_top = erts_alloc(ERTS_ALC_T_DB_TERM, dest->size * sizeof(Eterm));
dest->debug_clone = dbg_top;
tmp_offheap.first = dest->first_oh;
copy_struct_rel(obj, dest->size, &dbg_top, &tmp_offheap, NULL, dbg_top);
dest->first_oh = tmp_offheap.first;
ASSERT(dbg_top == dest->debug_clone + dest->size);
}
#endif
return top.cp;
}
/*
** Copy the object into a possibly new DbTerm,
** offset is the offset of the DbTerm from the start
** of the allocated 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_store_term(DbTableCommon *tb, DbTerm* old, Uint offset, Eterm obj)
{
byte* basep;
DbTerm* newp;
Eterm* top;
int size = size_object(obj);
ErlOffHeap tmp_offheap;
if (old != 0) {
basep = ((byte*) old) - offset;
tmp_offheap.first = old->first_oh;
erts_cleanup_offheap(&tmp_offheap);
old->first_oh = tmp_offheap.first;
if (size == old->size) {
newp = old;
}
else {
Uint new_sz = offset + sizeof(DbTerm) + sizeof(Eterm)*(size-1);
Uint old_sz = offset + sizeof(DbTerm) + sizeof(Eterm)*(old->size-1);
basep = db_realloc_term(tb, basep, old_sz, new_sz, offset);
newp = (DbTerm*) (basep + offset);
}
}
else {
basep = erts_db_alloc(ERTS_ALC_T_DB_TERM, (DbTable *)tb,
(offset + sizeof(DbTerm) + sizeof(Eterm)*(size-1)));
newp = (DbTerm*) (basep + offset);
}
newp->size = size;
top = newp->tpl;
tmp_offheap.first = NULL;
copy_struct_rel(obj, size, &top, &tmp_offheap, NULL, top);
newp->first_oh = tmp_offheap.first;
#ifdef DEBUG_CLONE
newp->debug_clone = NULL;
#endif
return basep;
}
void* db_store_term_comp(DbTableCommon *tb, DbTerm* old, Uint offset, Eterm obj)
{
Uint new_sz = offset + db_size_dbterm_comp(tb, obj);
byte* basep;
DbTerm* newp;
byte* top;
ASSERT(tb->compress);
if (old != 0) {
Uint old_sz = db_alloced_size_comp(old);
db_cleanup_offheap_comp(old);
basep = ((byte*) old) - offset;
if (new_sz == old_sz) {
newp = old;
}
else {
basep = db_realloc_term(tb, basep, old_sz, new_sz, offset);
newp = (DbTerm*) (basep + offset);
}
}
else {
basep = erts_db_alloc(ERTS_ALC_T_DB_TERM, (DbTable*)tb, new_sz);
newp = (DbTerm*) (basep + offset);
}
newp->size = size_object(obj);
top = copy_to_comp(tb, obj, newp, new_sz);
ASSERT(top <= basep + new_sz);
/* ToDo: Maybe realloc if ((basep+new_sz) - top) > WASTED_SPACE_LIMIT */
return basep;
}
void db_finalize_resize(DbUpdateHandle* handle, Uint offset)
{
#if HALFWORD_HEAP
DbTable* tbl = handle->tb;
DbTerm* newDbTerm;
Uint alloc_sz = offset +
(tbl->common.compress ?
db_size_dbterm_comp(&tbl->common, make_tuple(handle->dbterm->tpl)) :
sizeof(DbTerm)+sizeof(Eterm)*(handle->new_size-1));
byte* newp = erts_db_alloc(ERTS_ALC_T_DB_TERM, tbl, alloc_sz);
byte* oldp = *(handle->bp);
sys_memcpy(newp, oldp, offset); /* copy only hash/tree header */
*(handle->bp) = newp;
newDbTerm = (DbTerm*) (newp + offset);
newDbTerm->size = handle->new_size;
/* make a flat copy */
if (tbl->common.compress) {
copy_to_comp(&tbl->common, make_tuple(handle->dbterm->tpl),
newDbTerm, alloc_sz);
db_free_tmp_uncompressed(handle->dbterm);
}
else {
ErlOffHeap tmp_offheap;
int i, arity = header_arity(handle->dbterm->tpl[0]);
Eterm* top = newDbTerm->tpl + arity + 1;
ASSERT(handle->new_tuple != handle->dbterm->tpl);
tmp_offheap.first = NULL;
newDbTerm->tpl[0] = handle->dbterm->tpl[0];
for (i=1; i<=arity; i++) {
Eterm* tpl;
Eterm* src_base;
if (handle->new_tuple[i] == THE_NON_VALUE) {
tpl = handle->dbterm->tpl;
src_base = tpl;
}
else {
tpl = handle->new_tuple;
src_base = NULL;
}
newDbTerm->tpl[i] = copy_struct_rel(tpl[i],
size_object_rel(tpl[i],src_base),
&top, &tmp_offheap, src_base,
newDbTerm->tpl);
}
newDbTerm->first_oh = tmp_offheap.first;
#ifdef DEBUG_CLONE
newDbTerm->debug_clone = NULL;
#endif
ASSERT((byte*)top <= (newp + alloc_sz));
ASSERT(handle->new_tuple != handle->dbterm->tpl);
erts_free(ERTS_ALC_T_TMP, handle->new_tuple);
}
#else /***** !HALFWORD_HEAP *****/
DbTable* tbl = handle->tb;
DbTerm* newDbTerm;
Uint alloc_sz = offset +
(tbl->common.compress ?
db_size_dbterm_comp(&tbl->common, make_tuple(handle->dbterm->tpl)) :
sizeof(DbTerm)+sizeof(Eterm)*(handle->new_size-1));
byte* newp = erts_db_alloc(ERTS_ALC_T_DB_TERM, tbl, alloc_sz);
byte* oldp = *(handle->bp);
sys_memcpy(newp, oldp, offset); /* copy only hash/tree header */
*(handle->bp) = newp;
newDbTerm = (DbTerm*) (newp + offset);
newDbTerm->size = handle->new_size;
/* make a flat copy */
if (tbl->common.compress) {
copy_to_comp(&tbl->common, make_tuple(handle->dbterm->tpl),
newDbTerm, alloc_sz);
db_free_tmp_uncompressed(handle->dbterm);
}
else {
Eterm* top;
ErlOffHeap tmp_offheap;
tmp_offheap.first = NULL;
top = newDbTerm->tpl;
copy_struct(make_tuple(handle->dbterm->tpl), handle->new_size,
&top, &tmp_offheap);
newDbTerm->first_oh = tmp_offheap.first;
#ifdef DEBUG_CLONE
newDbTerm->debug_clone = NULL;
#endif
ASSERT((byte*)top <= (newp + alloc_sz));
}
#endif
}
Eterm db_copy_from_comp(DbTableCommon* tb, DbTerm* bp, Eterm** hpp,
ErlOffHeap* off_heap)
{
Eterm* hp = *hpp;
int i, arity = arityval(bp->tpl[0]);
hp[0] = bp->tpl[0];
*hpp += arity + 1;
hp[tb->keypos] = copy_struct_rel(bp->tpl[tb->keypos],
size_object_rel(bp->tpl[tb->keypos], bp->tpl),
hpp, off_heap, bp->tpl, NULL);
for (i=arity; i>0; i--) {
if (i != tb->keypos) {
if (is_immed(bp->tpl[i])) {
hp[i] = bp->tpl[i];
}
else {
hp[i] = erts_decode_ext_ets(hpp, off_heap,
elem2ext(bp->tpl, i));
}
}
}
ASSERT((*hpp - hp) <= bp->size);
#ifdef DEBUG_CLONE
ASSERT(eq_rel(make_tuple(hp),make_tuple(bp->debug_clone),bp->debug_clone));
#endif
return make_tuple(hp);
}
Eterm db_copy_element_from_ets(DbTableCommon* tb, Process* p,
DbTerm* obj, Uint pos,
Eterm** hpp, Uint extra)
{
if (is_immed(obj->tpl[pos])) {
*hpp = HAlloc(p, extra);
return obj->tpl[pos];
}
if (tb->compress && pos != tb->keypos) {
byte* ext = elem2ext(obj->tpl, pos);
Sint sz = erts_decode_ext_size_ets(ext, db_alloced_size_comp(obj)) + extra;
Eterm* hp = HAlloc(p, sz);
Eterm* endp = hp + sz;
Eterm copy = erts_decode_ext_ets(&hp, &MSO(p), ext);
*hpp = hp;
hp += extra;
HRelease(p, endp, hp);
#ifdef DEBUG_CLONE
ASSERT(eq_rel(copy, obj->debug_clone[pos], obj->debug_clone));
#endif
return copy;
}
else {
Uint sz = size_object_rel(obj->tpl[pos], obj->tpl);
*hpp = HAlloc(p, sz + extra);
return copy_struct_rel(obj->tpl[pos], sz, hpp, &MSO(p), obj->tpl, NULL);
}
}
/* Our own "cleanup_offheap"
* as refc-binaries may be unaligned in compressed terms
*/
void db_cleanup_offheap_comp(DbTerm* obj)
{
union erl_off_heap_ptr u;
ProcBin tmp;
for (u.hdr = obj->first_oh; u.hdr; u.hdr = u.hdr->next) {
if ((UWord)u.voidp % sizeof(Uint) != 0) { /* unaligned ptr */
sys_memcpy(&tmp, u.voidp, sizeof(tmp));
/* Warning, must pass (void*)-variable to memcpy. Otherwise it will
cause Bus error on Sparc due to false compile time assumptions
about word aligned memory (type cast is not enough) */
u.pb = &tmp;
}
switch (thing_subtag(u.hdr->thing_word)) {
case REFC_BINARY_SUBTAG:
if (erts_refc_dectest(&u.pb->val->refc, 0) == 0) {
erts_bin_free(u.pb->val);
}
break;
case FUN_SUBTAG:
ASSERT(u.pb != &tmp);
if (erts_refc_dectest(&u.fun->fe->refc, 0) == 0) {
erts_erase_fun_entry(u.fun->fe);
}
break;
default:
ASSERT(is_external_header(u.hdr->thing_word));
ASSERT(u.pb != &tmp);
erts_deref_node_entry(u.ext->node);
break;
}
}
#ifdef DEBUG_CLONE
if (obj->debug_clone != NULL) {
erts_free(ERTS_ALC_T_DB_TERM, obj->debug_clone);
obj->debug_clone = NULL;
}
#endif
}
int db_eq_comp(DbTableCommon* tb, Eterm a, DbTerm* b)
{
ErlOffHeap tmp_offheap;
Eterm* allocp;
Eterm* hp;
Eterm tmp_b;
int is_eq;
ASSERT(tb->compress);
hp = allocp = erts_alloc(ERTS_ALC_T_TMP, b->size*sizeof(Eterm));
tmp_offheap.first = NULL;
tmp_b = db_copy_from_comp(tb, b, &hp, &tmp_offheap);
is_eq = eq(a,tmp_b);
erts_cleanup_offheap(&tmp_offheap);
erts_free(ERTS_ALC_T_TMP, allocp);
return is_eq;
}
/*
** 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;
}
DbTerm* db_alloc_tmp_uncompressed(DbTableCommon* tb, DbTerm* org)
{
ErlOffHeap tmp_offheap;
DbTerm* res = erts_alloc(ERTS_ALC_T_TMP,
sizeof(DbTerm) + org->size*sizeof(Eterm));
Eterm* hp = res->tpl;
tmp_offheap.first = NULL;
db_copy_from_comp(tb, org, &hp, &tmp_offheap);
res->first_oh = tmp_offheap.first;
res->size = org->size;
#ifdef DEBUG_CLONE
res->debug_clone = NULL;
#endif
return res;
}
void db_free_tmp_uncompressed(DbTerm* obj)
{
ErlOffHeap off_heap;
off_heap.first = obj->first_oh;
erts_cleanup_offheap(&off_heap);
#ifdef DEBUG_CLONE
ASSERT(obj->debug_clone == NULL);
#endif
erts_free(ERTS_ALC_T_TMP, obj);
}
Eterm db_prog_match_and_copy(DbTableCommon* tb, Process* c_p, Binary* bprog,
int all, DbTerm* obj, Eterm** hpp, Uint extra)
{
Uint32 dummy;
Eterm* base;
Eterm res;
if (tb->compress) {
obj = db_alloc_tmp_uncompressed(tb, obj);
base = NULL;
}
else base = obj->tpl;
res = db_prog_match(c_p, bprog, make_tuple_rel(obj->tpl,base), base,
NULL, 0, &dummy);
if (is_value(res) && hpp!=NULL) {
if (all) {
*hpp = HAlloc(c_p, obj->size + extra);
res = copy_shallow_rel(obj->tpl, obj->size, hpp, &MSO(c_p), base);
}
else {
Uint sz = size_object(res);
*hpp = HAlloc(c_p, sz + extra);
res = copy_struct(res, sz, hpp, &MSO(c_p));
}
}
if (tb->compress) {
db_free_tmp_uncompressed(obj);
}
return res;
}
#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 */
