diff options
author | Andy Wingo <wingo@pobox.com> | 2009-07-19 19:48:26 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2009-07-22 00:13:52 +0200 |
commit | 8d90b356560b9cf54300ff9eabf4675acb650e03 (patch) | |
tree | 2193d51f330ab4a827be3559cbf3ac3208b18b57 /libguile | |
parent | a5cfddd560ca21205c8b0417413253d94f3e9b93 (diff) | |
download | guile-8d90b356560b9cf54300ff9eabf4675acb650e03.tar.gz |
vm support for display closures
* libguile/vm-i-system.c (box, empty-box): Boxing values and storing
them in local variables.
(local-boxed-ref, local-boxed-set): A combination of local-ref then
variable-ref/set.
(make-closure2, closure-ref, closure-boxed-ref, closure-boxed-set):
New ops. The idea is to migrate Guile over to using flat dispay
closures. See the paper "Three Implementation Models for Scheme" by
Kent Dybvig for more details; this is the "stack-based" model.
* libguile/vm-engine.c:
* libguile/vm-engine.h: Add the necessary infrastructure to keep track
of a "closure" variable, like our "externals" in semantics, but
minimal, flat, and O(1) in implementation.
Diffstat (limited to 'libguile')
-rw-r--r-- | libguile/vm-engine.c | 13 | ||||
-rw-r--r-- | libguile/vm-engine.h | 30 | ||||
-rw-r--r-- | libguile/vm-i-system.c | 88 |
3 files changed, 130 insertions, 1 deletions
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 90cf697f8..7a98a8a62 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -23,12 +23,14 @@ #define VM_USE_CLOCK 0 /* Bogoclock */ #define VM_CHECK_EXTERNAL 1 /* Check external link */ #define VM_CHECK_OBJECT 1 /* Check object table */ +#define VM_CHECK_CLOSURE 1 /* Check closure vars */ #define VM_PUSH_DEBUG_FRAMES 0 /* Push frames onto the evaluator debug stack */ #elif (VM_ENGINE == SCM_VM_DEBUG_ENGINE) #define VM_USE_HOOKS 1 #define VM_USE_CLOCK 1 #define VM_CHECK_EXTERNAL 1 #define VM_CHECK_OBJECT 1 +#define VM_CHECK_CLOSURE 1 #define VM_PUSH_DEBUG_FRAMES 1 #else #error unknown debug engine VM_ENGINE @@ -47,7 +49,9 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs) /* Cache variables */ struct scm_objcode *bp = NULL; /* program base pointer */ - SCM external = SCM_EOL; /* external environment */ + SCM external = SCM_EOL; /* external environment REMOVEME */ + SCM *closure = NULL; /* closure variables */ + size_t closure_count = 0; /* length of CLOSURE */ SCM *objects = NULL; /* constant objects */ size_t object_count = 0; /* length of OBJECTS */ SCM *stack_base = vp->stack_base; /* stack base address */ @@ -240,6 +244,13 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs) goto vm_error; #endif +#if VM_CHECK_CLOSURE + vm_error_closure: + err_msg = scm_from_locale_string ("VM: Invalid closure variable access"); + finish_args = SCM_EOL; + goto vm_error; +#endif + vm_error: SYNC_ALL (); diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h index d6849799c..a2c1effd3 100644 --- a/libguile/vm-engine.h +++ b/libguile/vm-engine.h @@ -117,6 +117,16 @@ vp->fp = fp; \ } +/* FIXME */ +#define ASSERT_VARIABLE(x) \ + do { if (!SCM_VARIABLEP (x)) { SYNC_REGISTER (); abort(); } \ + } while (0) +#define ASSERT_BOUND_VARIABLE(x) \ + do { ASSERT_VARIABLE (x); \ + if (SCM_VARIABLE_REF (x) == SCM_UNDEFINED) \ + { SYNC_REGISTER (); abort(); } \ + } while (0) + #ifdef VM_ENABLE_PARANOID_ASSERTIONS #define CHECK_IP() \ do { if (ip < bp->base || ip - bp->base > bp->len) abort (); } while (0) @@ -145,6 +155,19 @@ object_count = 0; \ } \ } \ + { \ + SCM c = SCM_PROGRAM_EXTERNALS (program); \ + if (SCM_I_IS_VECTOR (c)) \ + { \ + closure = SCM_I_VECTOR_WELTS (c); \ + closure_count = SCM_I_VECTOR_LENGTH (c); \ + } \ + else \ + { \ + closure = NULL; \ + closure_count = 0; \ + } \ + } \ } #define SYNC_BEFORE_GC() \ @@ -178,6 +201,13 @@ #define CHECK_OBJECT(_num) #endif +#if VM_CHECK_CLOSURE +#define CHECK_CLOSURE(_num) \ + do { if (SCM_UNLIKELY ((_num) >= closure_count)) goto vm_error_closure; } while (0) +#else +#define CHECK_CLOSURE(_num) +#endif + /* * Hooks diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index d884557e1..5e850a1a6 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -248,6 +248,8 @@ VM_DEFINE_INSTRUCTION (22, list_break, "list-break", 0, 0, 0) #define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o) #define VARIABLE_BOUNDP(v) (VARIABLE_REF (v) != SCM_UNDEFINED) +#define CLOSURE_REF(i) closure[i] + /* ref */ VM_DEFINE_INSTRUCTION (23, object_ref, "object-ref", 1, 0, 1) @@ -1150,6 +1152,92 @@ VM_DEFINE_INSTRUCTION (55, truncate_values, "truncate-values", 2, -1, -1) NEXT; } +VM_DEFINE_INSTRUCTION (56, box, "box", 1, 1, 0) +{ + SCM val; + POP (val); + SYNC_BEFORE_GC (); + LOCAL_SET (FETCH (), scm_cell (scm_tc7_variable, SCM_UNPACK (val))); + NEXT; +} + +/* for letrec: + (let ((a *undef*) (b *undef*) ...) + (set! a (lambda () (b ...))) + ...) + */ +VM_DEFINE_INSTRUCTION (57, empty_box, "empty-box", 1, 0, 0) +{ + SYNC_BEFORE_GC (); + LOCAL_SET (FETCH (), + scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED))); + NEXT; +} + +VM_DEFINE_INSTRUCTION (58, local_boxed_ref, "local-boxed-ref", 1, 0, 1) +{ + SCM v = LOCAL_REF (FETCH ()); + ASSERT_BOUND_VARIABLE (v); + PUSH (VARIABLE_REF (v)); + NEXT; +} + +VM_DEFINE_INSTRUCTION (59, local_boxed_set, "local-boxed-set", 1, 1, 0) +{ + SCM v, val; + v = LOCAL_REF (FETCH ()); + POP (val); + ASSERT_VARIABLE (v); + VARIABLE_SET (v, val); + NEXT; +} + +VM_DEFINE_INSTRUCTION (60, closure_ref, "closure-ref", 1, 0, 1) +{ + scm_t_uint8 idx = FETCH (); + + CHECK_CLOSURE (idx); + PUSH (CLOSURE_REF (idx)); + NEXT; +} + +/* no closure-set -- if a var is assigned, it should be in a box */ + +VM_DEFINE_INSTRUCTION (61, closure_boxed_ref, "closure-boxed-ref", 1, 0, 1) +{ + SCM v; + scm_t_uint8 idx = FETCH (); + CHECK_CLOSURE (idx); + v = CLOSURE_REF (idx); + ASSERT_BOUND_VARIABLE (v); + PUSH (VARIABLE_REF (v)); + NEXT; +} + +VM_DEFINE_INSTRUCTION (62, closure_boxed_set, "closure-boxed-set", 1, 1, 0) +{ + SCM v, val; + scm_t_uint8 idx = FETCH (); + POP (val); + CHECK_CLOSURE (idx); + v = CLOSURE_REF (idx); + ASSERT_BOUND_VARIABLE (v); + VARIABLE_SET (v, val); + NEXT; +} + +VM_DEFINE_INSTRUCTION (63, make_closure2, "make-closure2", 0, 2, 1) +{ + SCM vect; + POP (vect); + SYNC_BEFORE_GC (); + /* fixme underflow */ + SCM_NEWSMOB3 (*sp, scm_tc16_program, SCM_PROGRAM_OBJCODE (*sp), + SCM_PROGRAM_OBJTABLE (*sp), vect); + NEXT; +} + + /* (defun renumber-ops () "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences" |