mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-19 11:10:25 +02:00
Code Activity

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

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2008-08-05 01:03:17 +02:00
parent fbde2b915b
commit 659b4611b6
6 changed files with 137 additions and 15 deletions
Download patch file Download diff file Expand all files Collapse all files

2
configure.in
View file

@ -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)

22
m4/labels-as-values.m4 Normal file
View file

@ -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
])

8
module/system/repl/command.scm
View file

@ -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)))

13
module/system/vm/core.scm
View file

@ -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))
;;;

8
src/vm_engine.h
View file

@ -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

99
src/vm_system.c
View file

@ -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)))
{