* 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.
AC_C_BIGENDIAN
+AC_C_LABELS_AS_VALUES
+
AC_CHECK_SIZEOF(char)
AC_CHECK_SIZEOF(unsigned char)
AC_CHECK_SIZEOF(short)
--- /dev/null
+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
+])
(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)))
: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!
(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 (cddr x) prop)))
- (else '())))
+ (assq-ref (program-properties proc) prop))
+
+(define (program-documentation prog)
+ (assq-ref (program-properties proc) 'documentation))
+
\f
;;;
if (sp > stack_limit) \
goto vm_error_stack_overflow
-#define CHECK_UNDERFLOW() \
- if (sp < stack_base) \
+#define CHECK_UNDERFLOW() \
+ if (sp < stack_base) \
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 DROPN(_n) do { CHECK_UNDERFLOW (); sp -= (_n); } while (0)
+#define DROP() do { sp--; CHECK_UNDERFLOW (); } 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
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;
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)))
{