From 659b4611b6a138fa252a42d1e1a0f4862242454c Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 5 Aug 2008 01:03:17 +0200 Subject: [PATCH] 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 | 2 + m4/labels-as-values.m4 | 22 ++++++++ module/system/repl/command.scm | 8 +++ module/system/vm/core.scm | 13 +++-- src/vm_engine.h | 8 +-- src/vm_system.c | 99 +++++++++++++++++++++++++++++++--- 6 files changed, 137 insertions(+), 15 deletions(-) create mode 100644 m4/labels-as-values.m4 diff --git a/configure.in b/configure.in index 1bb20a6b6..876e49cbb 100644 --- a/configure.in +++ b/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) diff --git a/m4/labels-as-values.m4 b/m4/labels-as-values.m4 new file mode 100644 index 000000000..eedfb553a --- /dev/null +++ b/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 +]) diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm index e3abe240a..fecea4458 100644 --- a/module/system/repl/command.scm +++ b/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))) diff --git a/module/system/vm/core.scm b/module/system/vm/core.scm index 36f1815f1..32e2d6b07 100644 --- a/module/system/vm/core.scm +++ b/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 (cddr x) prop))) - (else '()))) + (assq-ref (program-properties proc) prop)) + +(define (program-documentation prog) + (assq-ref (program-properties proc) 'documentation)) + ;;; diff --git a/src/vm_engine.h b/src/vm_engine.h index 981f1f9ae..c90ca44a6 100644 --- a/src/vm_engine.h +++ b/src/vm_engine.h @@ -222,13 +222,13 @@ 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 diff --git a/src/vm_system.c b/src/vm_system.c index f227e79fa..1c2992bcb 100644 --- a/src/vm_system.c +++ b/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))) { -- 2.20.1