security-and-privacy/gnupg
security-and-privacy/gnupg
1
0
Fork 0
mirror of git://git.gnupg.org/gnupg.git synced 2025-01-30 16:17:02 +01:00
Code Activity

gpgscm: Keep a history of calls for error messages.

Browse Source 
* 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 2016-11-18 10:58:18 +01:00
parent 01256694f0
commit 404e8a4136
5 changed files with 339 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
tests/gpgscm/init.scm
View File

@ -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:

6
tests/gpgscm/opdefines.h
View File

@ -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

33
tests/gpgscm/scheme-private.h
View File

@ -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;

275
tests/gpgscm/scheme.c
View File

@ -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)) {

7
tests/gpgscm/scheme.h
View File

@ -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