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

5 files changed, 339 insertions, 4 deletions

diff --git a/tests/gpgscm/init.scm b/tests/gpgscm/init.scm
index f8fd71a1b..b03eb437b 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 a2328fa88..2d17720a6 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 40a421160..7f19a6ea3 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 8cec9cf8a..60b5a4111 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 5e7d90d90..8560f7d9d 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