mirror of git://git.gnupg.org/gnupg.git
gpgscm: Keep a history of calls for error messages.
* tests/gpgscm/init.scm (vm-history-print): New function. * tests/gpgscm/opdefines.h: New opcodes 'CALLSTACK_POP', 'APPLY_CODE', and 'VM_HISTORY'. * tests/gpgscm/scheme-private.h (struct history): New definition. (struct scheme): New field 'history'. * tests/gpgscm/scheme.c (gc): Mark objects in the history. (history_free): New function. (history_init): Likewise. (history_mark): Likewise. (add_mod): New macro. (sub_mod): Likewise. (tailstack_clear): New function. (callstack_pop): Likewise. (callstack_push): Likewise. (tailstack_push): Likewise. (tailstack_flatten): Likewise. (callstack_flatten): Likewise. (history_flatten): Likewise. (opexe_0): New variable 'callsite', keep track of the expression if it is a call, implement the new opcodes, record function applications in the history. (opexe_6): Implement new opcode. (scheme_init_custom_alloc): Initialize history. (scheme_deinit): Free history. * tests/gpgscm/scheme.h (USE_HISTORY): New macro. -- This patch makes TinySCHEME keep a history of function calls. This history can be used to produce helpful error messages. The history data structure is inspired by MIT/GNU Scheme. Signed-off-by: Justus Winter <justus@g10code.com> fu history
This commit is contained in:
Justus Winter
parent
01256694f0
commit
404e8a4136
|
|
@ -534,6 +534,28 @@
|
|||
`(define ,(cadr form)
|
||||
(call/cc (lambda (return) ,@(cddr form)))))
|
||||
|
||||
;; Print the given history.
|
||||
(define (vm-history-print history)
|
||||
(let loop ((n 0) (skip 0) (frames history))
|
||||
(cond
|
||||
((null? frames)
|
||||
#t)
|
||||
((> skip 0)
|
||||
(loop 0 (- skip 1) (cdr frames)))
|
||||
(else
|
||||
(let ((f (car frames)))
|
||||
(display n)
|
||||
(display ": ")
|
||||
(let ((tag (get-tag f)))
|
||||
(unless (null? tag)
|
||||
(display (basename (car tag)))
|
||||
(display ":")
|
||||
(display (+ 1 (cdr tag)))
|
||||
(display ": ")))
|
||||
(write f))
|
||||
(newline)
|
||||
(loop (+ n 1) skip (cdr frames))))))
|
||||
|
||||
;;;; Simple exception handling
|
||||
;
|
||||
; Exceptions are caught as follows:
|
||||
|
|
|
|||
|
|
@ -10,6 +10,10 @@
|
|||
#endif
|
||||
_OP_DEF(opexe_0, 0, 0, 0, 0, OP_E0ARGS )
|
||||
_OP_DEF(opexe_0, 0, 0, 0, 0, OP_E1ARGS )
|
||||
#if USE_HISTORY
|
||||
_OP_DEF(opexe_0, 0, 0, 0, 0, OP_CALLSTACK_POP )
|
||||
#endif
|
||||
_OP_DEF(opexe_0, 0, 0, 0, 0, OP_APPLY_CODE )
|
||||
_OP_DEF(opexe_0, 0, 0, 0, 0, OP_APPLY )
|
||||
#if USE_TRACING
|
||||
_OP_DEF(opexe_0, 0, 0, 0, 0, OP_REAL_APPLY )
|
||||
|
|
@ -197,4 +201,6 @@
|
|||
_OP_DEF(opexe_6, "get-closure-code", 1, 1, TST_NONE, OP_GET_CLOSURE )
|
||||
_OP_DEF(opexe_6, "closure?", 1, 1, TST_NONE, OP_CLOSUREP )
|
||||
_OP_DEF(opexe_6, "macro?", 1, 1, TST_NONE, OP_MACROP )
|
||||
_OP_DEF(opexe_6, "*vm-history*", 0, 0, TST_NONE, OP_VM_HISTORY )
|
||||
|
||||
#undef _OP_DEF
|
||||
|
|
|
|||
|
|
@ -62,6 +62,34 @@ struct cell {
|
|||
} _object;
|
||||
};
|
||||
|
||||
#if USE_HISTORY
|
||||
/* The history is a two-dimensional ring buffer. A donut-shaped data
|
||||
* structure. This data structure is inspired by MIT/GNU Scheme. */
|
||||
struct history {
|
||||
/* Number of calls to store. Must be a power of two. */
|
||||
size_t N;
|
||||
|
||||
/* Number of tail-calls to store in each call frame. Must be a
|
||||
* power of two. */
|
||||
size_t M;
|
||||
|
||||
/* Masks for fast index calculations. */
|
||||
size_t mask_N;
|
||||
size_t mask_M;
|
||||
|
||||
/* A vector of size N containing calls. */
|
||||
pointer callstack;
|
||||
|
||||
/* A vector of size N containing vectors of size M containing tail
|
||||
* calls. */
|
||||
pointer tailstacks;
|
||||
|
||||
/* Our current position. */
|
||||
size_t n;
|
||||
size_t *m;
|
||||
};
|
||||
#endif
|
||||
|
||||
struct scheme {
|
||||
/* arrays for segments */
|
||||
func_alloc malloc;
|
||||
|
|
@ -88,6 +116,11 @@ pointer envir; /* stack register for current environment */
|
|||
pointer code; /* register for current code */
|
||||
pointer dump; /* stack register for next evaluation */
|
||||
|
||||
#if USE_HISTORY
|
||||
struct history history; /* we keep track of the call history for
|
||||
* error messages */
|
||||
#endif
|
||||
|
||||
int interactive_repl; /* are we in an interactive REPL? */
|
||||
|
||||
struct cell _sink;
|
||||
|
|
|
|||
|
|
@ -308,6 +308,14 @@ INTERFACE INLINE void setimmutable(pointer p) { typeflag(p) |= T_IMMUTABLE; }
|
|||
#define cadddr(p) car(cdr(cdr(cdr(p))))
|
||||
#define cddddr(p) cdr(cdr(cdr(cdr(p))))
|
||||
|
||||
#if USE_HISTORY
|
||||
static pointer history_flatten(scheme *sc);
|
||||
static void history_mark(scheme *sc);
|
||||
#else
|
||||
# define history_mark(SC) (void) 0
|
||||
# define history_flatten(SC) (SC)->NIL
|
||||
#endif
|
||||
|
||||
#if USE_CHAR_CLASSIFIERS
|
||||
static INLINE int Cisalpha(int c) { return isascii(c) && isalpha(c); }
|
||||
static INLINE int Cisdigit(int c) { return isascii(c) && isdigit(c); }
|
||||
|
|
@ -1593,6 +1601,7 @@ static void gc(scheme *sc, pointer a, pointer b) {
|
|||
mark(sc->args);
|
||||
mark(sc->envir);
|
||||
mark(sc->code);
|
||||
history_mark(sc);
|
||||
dump_stack_mark(sc);
|
||||
mark(sc->value);
|
||||
mark(sc->inport);
|
||||
|
|
@ -2830,10 +2839,236 @@ static INLINE void dump_stack_mark(scheme *sc)
|
|||
mark(sc->dump);
|
||||
}
|
||||
|
||||
|
||||
|
||||
#if USE_HISTORY
|
||||
|
||||
static void
|
||||
history_free(scheme *sc)
|
||||
{
|
||||
sc->free(sc->history.m);
|
||||
sc->history.tailstacks = sc->NIL;
|
||||
sc->history.callstack = sc->NIL;
|
||||
}
|
||||
|
||||
static pointer
|
||||
history_init(scheme *sc, size_t N, size_t M)
|
||||
{
|
||||
size_t i;
|
||||
struct history *h = &sc->history;
|
||||
|
||||
h->N = N;
|
||||
h->mask_N = N - 1;
|
||||
h->n = N - 1;
|
||||
assert ((N & h->mask_N) == 0);
|
||||
|
||||
h->M = M;
|
||||
h->mask_M = M - 1;
|
||||
assert ((M & h->mask_M) == 0);
|
||||
|
||||
h->callstack = mk_vector(sc, N);
|
||||
if (h->callstack == sc->sink)
|
||||
goto fail;
|
||||
|
||||
h->tailstacks = mk_vector(sc, N);
|
||||
for (i = 0; i < N; i++) {
|
||||
pointer tailstack = mk_vector(sc, M);
|
||||
if (tailstack == sc->sink)
|
||||
goto fail;
|
||||
set_vector_elem(h->tailstacks, i, tailstack);
|
||||
}
|
||||
|
||||
h->m = sc->malloc(N * sizeof *h->m);
|
||||
if (h->m == NULL)
|
||||
goto fail;
|
||||
|
||||
for (i = 0; i < N; i++)
|
||||
h->m[i] = 0;
|
||||
|
||||
return sc->T;
|
||||
|
||||
fail:
|
||||
history_free(sc);
|
||||
return sc->F;
|
||||
}
|
||||
|
||||
static void
|
||||
history_mark(scheme *sc)
|
||||
{
|
||||
struct history *h = &sc->history;
|
||||
mark(h->callstack);
|
||||
mark(h->tailstacks);
|
||||
}
|
||||
|
||||
#define add_mod(a, b, mask) (((a) + (b)) & (mask))
|
||||
#define sub_mod(a, b, mask) add_mod(a, (mask) + 1 - (b), mask)
|
||||
|
||||
static INLINE void
|
||||
tailstack_clear(scheme *sc, pointer v)
|
||||
{
|
||||
assert(is_vector(v));
|
||||
/* XXX optimize */
|
||||
fill_vector(v, sc->NIL);
|
||||
}
|
||||
|
||||
static pointer
|
||||
callstack_pop(scheme *sc)
|
||||
{
|
||||
struct history *h = &sc->history;
|
||||
size_t n = h->n;
|
||||
pointer item;
|
||||
|
||||
if (h->callstack == sc->NIL)
|
||||
return sc->NIL;
|
||||
|
||||
item = vector_elem(h->callstack, n);
|
||||
/* Clear our frame so that it can be gc'ed and we don't run into it
|
||||
* when walking the history. */
|
||||
set_vector_elem(h->callstack, n, sc->NIL);
|
||||
tailstack_clear(sc, vector_elem(h->tailstacks, n));
|
||||
|
||||
/* Exit from the frame. */
|
||||
h->n = sub_mod(h->n, 1, h->mask_N);
|
||||
|
||||
return item;
|
||||
}
|
||||
|
||||
static void
|
||||
callstack_push(scheme *sc, pointer item)
|
||||
{
|
||||
struct history *h = &sc->history;
|
||||
size_t n = h->n;
|
||||
|
||||
if (h->callstack == sc->NIL)
|
||||
return;
|
||||
|
||||
/* Enter a new frame. */
|
||||
n = h->n = add_mod(n, 1, h->mask_N);
|
||||
|
||||
/* Initialize tail stack. */
|
||||
tailstack_clear(sc, vector_elem(h->tailstacks, n));
|
||||
h->m[n] = h->mask_M;
|
||||
|
||||
set_vector_elem(h->callstack, n, item);
|
||||
}
|
||||
|
||||
static void
|
||||
tailstack_push(scheme *sc, pointer item)
|
||||
{
|
||||
struct history *h = &sc->history;
|
||||
size_t n = h->n;
|
||||
size_t m = h->m[n];
|
||||
|
||||
if (h->callstack == sc->NIL)
|
||||
return;
|
||||
|
||||
/* Enter a new tail frame. */
|
||||
m = h->m[n] = add_mod(m, 1, h->mask_M);
|
||||
set_vector_elem(vector_elem(h->tailstacks, n), m, item);
|
||||
}
|
||||
|
||||
static pointer
|
||||
tailstack_flatten(scheme *sc, pointer tailstack, size_t i, size_t n,
|
||||
pointer acc)
|
||||
{
|
||||
struct history *h = &sc->history;
|
||||
pointer frame;
|
||||
|
||||
assert(i <= h->M);
|
||||
assert(n < h->M);
|
||||
|
||||
if (acc == sc->sink)
|
||||
return sc->sink;
|
||||
|
||||
if (i == 0) {
|
||||
/* We reached the end, but we did not see a unused frame. Signal
|
||||
this using '... . */
|
||||
return cons(sc, mk_symbol(sc, "..."), acc);
|
||||
}
|
||||
|
||||
frame = vector_elem(tailstack, n);
|
||||
if (frame == sc->NIL) {
|
||||
/* A unused frame. We reached the end of the history. */
|
||||
return acc;
|
||||
}
|
||||
|
||||
/* Add us. */
|
||||
acc = cons(sc, frame, acc);
|
||||
|
||||
return tailstack_flatten(sc, tailstack, i - 1, sub_mod(n, 1, h->mask_M),
|
||||
acc);
|
||||
}
|
||||
|
||||
static pointer
|
||||
callstack_flatten(scheme *sc, size_t i, size_t n, pointer acc)
|
||||
{
|
||||
struct history *h = &sc->history;
|
||||
pointer frame;
|
||||
|
||||
assert(i <= h->N);
|
||||
assert(n < h->N);
|
||||
|
||||
if (acc == sc->sink)
|
||||
return sc->sink;
|
||||
|
||||
if (i == 0) {
|
||||
/* We reached the end, but we did not see a unused frame. Signal
|
||||
this using '... . */
|
||||
return cons(sc, mk_symbol(sc, "..."), acc);
|
||||
}
|
||||
|
||||
frame = vector_elem(h->callstack, n);
|
||||
if (frame == sc->NIL) {
|
||||
/* A unused frame. We reached the end of the history. */
|
||||
return acc;
|
||||
}
|
||||
|
||||
/* First, emit the tail calls. */
|
||||
acc = tailstack_flatten(sc, vector_elem(h->tailstacks, n), h->M, h->m[n],
|
||||
acc);
|
||||
|
||||
/* Then us. */
|
||||
acc = cons(sc, frame, acc);
|
||||
|
||||
return callstack_flatten(sc, i - 1, sub_mod(n, 1, h->mask_N), acc);
|
||||
}
|
||||
|
||||
static pointer
|
||||
history_flatten(scheme *sc)
|
||||
{
|
||||
struct history *h = &sc->history;
|
||||
pointer history;
|
||||
|
||||
if (h->callstack == sc->NIL)
|
||||
return sc->NIL;
|
||||
|
||||
history = callstack_flatten(sc, h->N, h->n, sc->NIL);
|
||||
if (history == sc->sink)
|
||||
return sc->sink;
|
||||
|
||||
return reverse_in_place(sc, sc->NIL, history);
|
||||
}
|
||||
|
||||
#undef add_mod
|
||||
#undef sub_mod
|
||||
|
||||
#else /* USE_HISTORY */
|
||||
|
||||
#define history_init(SC, A, B) (void) 0
|
||||
#define history_free(SC) (void) 0
|
||||
#define callstack_pop(SC) (void) 0
|
||||
#define callstack_push(SC, X) (void) 0
|
||||
#define tailstack_push(SC, X) (void) 0
|
||||
|
||||
#endif /* USE_HISTORY */
|
||||
|
||||
|
||||
|
||||
#define s_retbool(tf) s_return(sc,(tf) ? sc->T : sc->F)
|
||||
|
||||
static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
|
||||
pointer x, y;
|
||||
pointer callsite;
|
||||
|
||||
switch (op) {
|
||||
CASE(OP_LOAD): /* load */
|
||||
|
|
@ -2959,7 +3194,10 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
|
|||
s_clear_flag(sc, TAIL_CONTEXT);
|
||||
s_thread_to(sc,OP_APPLY);
|
||||
} else {
|
||||
sc->code = cdr(sc->code);
|
||||
gc_disable(sc, 1);
|
||||
sc->args = cons(sc, sc->code, sc->NIL);
|
||||
gc_enable(sc);
|
||||
sc->code = cdr(sc->code);
|
||||
s_thread_to(sc,OP_E1ARGS);
|
||||
}
|
||||
|
||||
|
|
@ -2975,9 +3213,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
|
|||
s_thread_to(sc,OP_EVAL);
|
||||
} else { /* end */
|
||||
sc->args = reverse_in_place(sc, sc->NIL, sc->args);
|
||||
sc->code = car(sc->args);
|
||||
sc->args = cdr(sc->args);
|
||||
s_thread_to(sc,OP_APPLY);
|
||||
s_thread_to(sc,OP_APPLY_CODE);
|
||||
}
|
||||
|
||||
#if USE_TRACING
|
||||
|
|
@ -2989,6 +3225,20 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
|
|||
}
|
||||
#endif
|
||||
|
||||
#if USE_HISTORY
|
||||
CASE(OP_CALLSTACK_POP): /* pop the call stack */
|
||||
callstack_pop(sc);
|
||||
s_return(sc, sc->value);
|
||||
#endif
|
||||
|
||||
CASE(OP_APPLY_CODE): /* apply 'cadr(args)' to 'cddr(args)',
|
||||
* record in the history as invoked from
|
||||
* 'car(args)' */
|
||||
free_cons(sc, sc->args, &callsite, &sc->args);
|
||||
sc->code = car(sc->args);
|
||||
sc->args = cdr(sc->args);
|
||||
/* Fallthrough. */
|
||||
|
||||
CASE(OP_APPLY): /* apply 'code' to 'args' */
|
||||
#if USE_TRACING
|
||||
if(sc->tracing) {
|
||||
|
|
@ -3001,6 +3251,18 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
|
|||
/* fall through */
|
||||
CASE(OP_REAL_APPLY):
|
||||
#endif
|
||||
#if USE_HISTORY
|
||||
if (op != OP_APPLY_CODE)
|
||||
callsite = sc->code;
|
||||
if (s_get_flag(sc, TAIL_CONTEXT)) {
|
||||
/* We are evaluating a tail call. */
|
||||
tailstack_push(sc, callsite);
|
||||
} else {
|
||||
callstack_push(sc, callsite);
|
||||
s_save(sc, OP_CALLSTACK_POP, sc->NIL, sc->NIL);
|
||||
}
|
||||
#endif
|
||||
|
||||
if (is_proc(sc->code)) {
|
||||
s_goto(sc,procnum(sc->code)); /* PROCEDURE */
|
||||
} else if (is_foreign(sc->code))
|
||||
|
|
@ -4805,6 +5067,8 @@ static pointer opexe_6(scheme *sc, enum scheme_opcodes op) {
|
|||
s_retbool(is_closure(car(sc->args)));
|
||||
CASE(OP_MACROP): /* macro? */
|
||||
s_retbool(is_macro(car(sc->args)));
|
||||
CASE(OP_VM_HISTORY): /* *vm-history* */
|
||||
s_return(sc, history_flatten(sc));
|
||||
default:
|
||||
snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
|
||||
Error_0(sc,sc->strbuff);
|
||||
|
|
@ -5235,6 +5499,8 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) {
|
|||
}
|
||||
}
|
||||
|
||||
history_init(sc, 8, 8);
|
||||
|
||||
/* initialization of global pointers to special symbols */
|
||||
sc->LAMBDA = mk_symbol(sc, "lambda");
|
||||
sc->QUOTE = mk_symbol(sc, "quote");
|
||||
|
|
@ -5284,6 +5550,7 @@ void scheme_deinit(scheme *sc) {
|
|||
dump_stack_free(sc);
|
||||
sc->envir=sc->NIL;
|
||||
sc->code=sc->NIL;
|
||||
history_free(sc);
|
||||
sc->args=sc->NIL;
|
||||
sc->value=sc->NIL;
|
||||
if(is_port(sc->inport)) {
|
||||
|
|
|
|||
|
|
@ -45,6 +45,7 @@ extern "C" {
|
|||
# define USE_PLIST 0
|
||||
# define USE_SMALL_INTEGERS 0
|
||||
# define USE_TAGS 0
|
||||
# define USE_HISTORY 0
|
||||
#endif
|
||||
|
||||
|
||||
|
|
@ -82,6 +83,12 @@ extern "C" {
|
|||
# define USE_TAGS 1
|
||||
#endif
|
||||
|
||||
/* Keep a history of function calls. This enables a feature similar
|
||||
* to stack traces. */
|
||||
#ifndef USE_HISTORY
|
||||
# define USE_HISTORY 1
|
||||
#endif
|
||||
|
||||
/* To force system errors through user-defined error handling (see *error-hook*) */
|
||||
#ifndef USE_ERROR_HOOK
|
||||
# define USE_ERROR_HOOK 1
|
||||
|
|
|
|||
Loading…
Reference in New Issue