re-enable computed goto; fix ,help in the repl; subr dispatch optimizations

* m4/labels-as-values.m4: New file, checks for computed goto.

* configure.in: Use AC_C_LABELS_AS_VALUES.

* module/system/repl/command.scm (procedure-documentation): Extend the
  core's procedure-documentation in an ad-hoc way, so that ,help works.

* module/system/vm/core.scm (program-properties): New function.
  (program-documentation): New function.

* src/vm_engine.h (DROP, DROPN): Decrement sp before checking for
  underflow.

* src/vm_system.c (call, tail-call): Add some optimized dispatch for some
  C functions, so that we can avoid consing and the interpreter if
  possible. However currently it seems that I'm always getting the
  scm_call_* trampolines back.

configure.in

@@ -285,6 +285,8 @@ AC_CHECK_LIB(uca, __uc_get_ar_bsp)
 
 AC_C_BIGENDIAN
 
+AC_C_LABELS_AS_VALUES
+
 AC_CHECK_SIZEOF(char)
 AC_CHECK_SIZEOF(unsigned char)
 AC_CHECK_SIZEOF(short)

m4/labels-as-values.m4

@@ -0,0 +1,22 @@
+dnl check for gcc's "labels as values" feature
+AC_DEFUN(AC_C_LABELS_AS_VALUES,
+[AC_CACHE_CHECK([labels as values], ac_cv_labels_as_values,
+[AC_TRY_COMPILE([
+int foo(int);
+int foo(i)
+int i; { 
+static void *label[] = { &&l1, &&l2 };
+goto *label[i];
+l1: return 1;
+l2: return 2;
+}
+],
+[int i;], 
+ac_cv_labels_as_values=yes,
+ac_cv_labels_as_values=no)])
+if test "$ac_cv_labels_as_values" = yes; then
+AC_DEFINE(HAVE_LABELS_AS_VALUES, [],
+          [Define if compiler supports gcc's "labels as values" (aka computed goto)
+           feature, used to speed up instruction dispatch in the interpreter.])
+fi
+])

module/system/repl/command.scm

@@ -55,6 +55,14 @@
 (define (group-name g) (car g))
 (define (group-commands g) (cdr g))
 
+;; Hack, until core can be extended.
+(define procedure-documentation
+  (let ((old-definition procedure-documentation))
+    (lambda (p)
+      (if (program? p)
+          (program-documentation p)
+          (procedure-documentation p)))))
+
 (define *command-module* (current-module))
 (define (command-name c) (car c))
 (define (command-abbrev c) (if (null? (cdr c)) #f (cadr c)))

module/system/vm/core.scm

@@ -24,6 +24,7 @@
   :export (arity:nargs arity:nrest arity:nlocs arity:nexts
            make-binding binding:name binding:extp binding:index
            program-bindings program-sources
+           program-properties program-property program-documentation
            frame-arguments frame-local-variables frame-external-variables
            frame-environment
            frame-variable-exists? frame-variable-ref frame-variable-set!
@@ -66,10 +67,16 @@
   (cond ((program-meta prog) => cadr)
 	(else '())))
 
+(define (program-properties prog)
+  (or (and=> (program-meta prog) cddr)
+      '()))
+
 (define (program-property prog prop)
-  (cond ((program-meta prog) => (lambda (x)
+  (assq-ref (program-properties proc) prop))
-                                  (assq-ref (cddr x) prop)))
+
-	(else '())))
+(define (program-documentation prog)
+  (assq-ref (program-properties proc) 'documentation))
+
 
 
 ;;;

src/vm_engine.h

@@ -227,8 +227,8 @@
     goto vm_error_stack_underflow
 
 #define PUSH(x)	do { sp++; CHECK_OVERFLOW (); *sp = x; } while (0)
-#define DROP()	do { CHECK_UNDERFLOW (); sp--; } while (0)
+#define DROP()	do { sp--; CHECK_UNDERFLOW (); } while (0)
-#define DROPN(_n)	do { CHECK_UNDERFLOW (); sp -= (_n); } while (0)
+#define DROPN(_n)	do { sp -= (_n); CHECK_UNDERFLOW (); } while (0)
 #define POP(x)	do { x = *sp; DROP (); } while (0)
 
 /* A fast CONS.  This has to be fast since its used, for instance, by

src/vm_system.c

@@ -422,20 +422,58 @@ VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1)
       NEXT;
     }
   /*
-   * Function call
+   * Subr call
+   */
+  switch (nargs) 
+    {
+    case 0:
+      {
+        scm_t_trampoline_0 call = scm_trampoline_0 (x);
+        if (call) 
+          {
+            SYNC_ALL ();
+            *sp = call (x);
+            NEXT;
+          }
+        break;
+      }
+    case 1:
+      {
+        scm_t_trampoline_1 call = scm_trampoline_1 (x);
+        if (call)
+          {
+            SCM arg1;
+            POP (arg1);
+            SYNC_ALL ();
+            *sp = call (x, arg1);
+            NEXT;
+          }
+        break;
+      }
+    case 2:
+      {
+        scm_t_trampoline_2 call = scm_trampoline_2 (x);
+        if (call)
+          {
+            SCM arg1, arg2;
+            POP (arg2);
+            POP (arg1);
+            SYNC_ALL ();
+            *sp = call (x, arg1, arg2);
+            NEXT;
+          }
+        break;
+      }
+    }
+  /*
+   * Other interpreted or compiled call
    */
   if (!SCM_FALSEP (scm_procedure_p (x)))
     {
       /* At this point, the stack contains the procedure and each one of its
 	 arguments.  */
       SCM args;
-
-#if 1
       POP_LIST (nargs);
-#else
-      /* Experimental:  Build the arglist on the VM stack.  XXX  */
-      POP_LIST_ON_STACK (nargs);
-#endif
       POP (args);
       *sp = scm_apply (x, args, SCM_EOL);
       NEXT;
@@ -503,7 +541,52 @@ VM_DEFINE_INSTRUCTION (tail_call, "tail-call", 1, -1, 1)
       goto vm_call_program;
     }
   /*
-   * Function call
+   * Subr call
+   */
+  switch (nargs) 
+    {
+    case 0:
+      {
+        scm_t_trampoline_0 call = scm_trampoline_0 (x);
+        if (call) 
+          {
+            SYNC_ALL ();
+            *sp = call (x);
+            goto vm_return;
+          }
+        break;
+      }
+    case 1:
+      {
+        scm_t_trampoline_1 call = scm_trampoline_1 (x);
+        if (call)
+          {
+            SCM arg1;
+            POP (arg1);
+            SYNC_ALL ();
+            *sp = call (x, arg1);
+            goto vm_return;
+          }
+        break;
+      }
+    case 2:
+      {
+        scm_t_trampoline_2 call = scm_trampoline_2 (x);
+        if (call)
+          {
+            SCM arg1, arg2;
+            POP (arg2);
+            POP (arg1);
+            SYNC_ALL ();
+            *sp = call (x, arg1, arg2);
+            goto vm_return;
+          }
+        break;
+      }
+    }
+
+  /*
+   * Other interpreted or compiled call
    */
   if (!SCM_FALSEP (scm_procedure_p (x)))
     {