[Pkg-gnupg-commit] [gnupg2] 77/180: gpgscm: Keep a history of calls for error messages.
Daniel Kahn Gillmor
dkg at fifthhorseman.net
Sat Dec 24 22:29:10 UTC 2016
This is an automated email from the git hooks/post-receive script.
dkg pushed a commit to branch master
in repository gnupg2.
commit 404e8a4136bbbab39df7dd5119841e131998cc15
Author: Justus Winter <justus at g10code.com>
Date: Fri Nov 18 10:58:18 2016 +0100
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 at g10code.com>
fu history
---
tests/gpgscm/init.scm | 22 ++++
tests/gpgscm/opdefines.h | 6 +
tests/gpgscm/scheme-private.h | 33 +++++
tests/gpgscm/scheme.c | 275 +++++++++++++++++++++++++++++++++++++++++-
tests/gpgscm/scheme.h | 7 ++
5 files changed, 339 insertions(+), 4 deletions(-)
diff --git a/tests/gpgscm/init.scm b/tests/gpgscm/init.scm
index f8fd71a..b03eb43 100644
--- a/tests/gpgscm/init.scm
+++ b/tests/gpgscm/init.scm
@@ -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:
diff --git a/tests/gpgscm/opdefines.h b/tests/gpgscm/opdefines.h
index a2328fa..2d17720 100644
--- a/tests/gpgscm/opdefines.h
+++ b/tests/gpgscm/opdefines.h
@@ -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
diff --git a/tests/gpgscm/scheme-private.h b/tests/gpgscm/scheme-private.h
index 40a4211..7f19a6e 100644
--- a/tests/gpgscm/scheme-private.h
+++ b/tests/gpgscm/scheme-private.h
@@ -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;
diff --git a/tests/gpgscm/scheme.c b/tests/gpgscm/scheme.c
index 8cec9cf..60b5a41 100644
--- a/tests/gpgscm/scheme.c
+++ b/tests/gpgscm/scheme.c
@@ -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)) {
diff --git a/tests/gpgscm/scheme.h b/tests/gpgscm/scheme.h
index 5e7d90d..8560f7d 100644
--- a/tests/gpgscm/scheme.h
+++ b/tests/gpgscm/scheme.h
@@ -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
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-gnupg/gnupg2.git
More information about the Pkg-gnupg-commit
mailing list