diff --git a/libguile/continuations.c b/libguile/continuations.c index aeff62e0c..5f3adcf57 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998,2000,2001,2004, 2006, 2008, 2009 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,2000,2001,2004, 2006, 2008, 2009, 2010 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -37,16 +37,117 @@ #include "libguile/values.h" #include "libguile/eval.h" #include "libguile/vm.h" +#include "libguile/instructions.h" #include "libguile/validate.h" #include "libguile/continuations.h" -/* {Continuations} +static scm_t_bits tc16_continuation; +#define SCM_CONTREGSP(x) SCM_TYP16_PREDICATE (tc16_continuation, x) + +#define SCM_CONTREGS(x) ((scm_t_contregs *) SCM_SMOB_DATA_1 (x)) + +#define SCM_CONTINUATION_LENGTH(x) (SCM_CONTREGS (x)->num_stack_items) +#define SCM_SET_CONTINUATION_LENGTH(x, n)\ + (SCM_CONTREGS (x)->num_stack_items = (n)) +#define SCM_JMPBUF(x) ((SCM_CONTREGS (x))->jmpbuf) +#define SCM_DYNENV(x) ((SCM_CONTREGS (x))->dynenv) +#define SCM_THROW_VALUE(x) ((SCM_CONTREGS (x))->throw_value) +#define SCM_CONTINUATION_ROOT(x) ((SCM_CONTREGS (x))->root) +#define SCM_DFRAME(x) ((SCM_CONTREGS (x))->dframe) + + + +/* scm_make_continuation will return a procedure whose objcode contains an + instruction to reinstate the continuation. Here, as in gsubr.c and smob.c, we + define the form of that trampoline function. */ -scm_t_bits scm_tc16_continuation; +#ifdef WORDS_BIGENDIAN +#define OBJCODE_HEADER 0, 0, 0, 8, 0, 0, 0, 27 +#define META_HEADER 0, 0, 0, 19, 0, 0, 0, 0 +#else +#define OBJCODE_HEADER 8, 0, 0, 0, 27, 0, 0, 0 +#define META_HEADER 19, 0, 0, 0, 0, 0, 0, 0 +#endif + +#define ROUND_UP(len,align) (((len-1)|(align-1))+1) +#define ALIGN_PTR(type,p,align) (type*)(ROUND_UP (((scm_t_bits)p), align)) + +#ifdef SCM_ALIGNED +#define SCM_DECLARE_STATIC_ALIGNED_ARRAY(type, sym)\ +static const type sym[] +#define SCM_STATIC_ALIGNED_ARRAY(alignment, type, sym)\ +static SCM_ALIGNED (alignment) const type sym[] +#else +#define SCM_DECLARE_STATIC_ALIGNED_ARRAY(type, sym)\ +static type *sym +#define SCM_STATIC_ALIGNED_ARRAY(alignment, type, sym) \ +SCM_SNARF_INIT(sym = scm_malloc (sizeof(sym##__unaligned) + alignment - 1); \ + sym = ALIGN_PTR (type, sym, alignment); \ + memcpy (sym, sym##__unaligned, sizeof(sym##__unaligned));) \ +static type *sym = NULL; \ +static const type sym##__unaligned[] +#endif + +#define STATIC_OBJCODE_TAG \ + SCM_PACK (scm_tc7_objcode | (SCM_F_OBJCODE_IS_STATIC << 8)) + +#define SCM_STATIC_OBJCODE(sym) \ + SCM_DECLARE_STATIC_ALIGNED_ARRAY (scm_t_uint8, sym##__bytecode); \ + SCM_STATIC_ALIGNED_ARRAY (8, scm_t_cell, sym##__cells) = { \ + { STATIC_OBJCODE_TAG, SCM_PACK (sym##__bytecode) }, \ + { SCM_BOOL_F, SCM_PACK (0) } \ + }; \ + static const SCM sym = SCM_PACK (sym##__cells); \ + SCM_STATIC_ALIGNED_ARRAY (8, scm_t_uint8, sym##__bytecode) + + +SCM_STATIC_OBJCODE (cont_objcode) = { + /* This code is the same as in gsubr.c, except we use smob_call instead of + struct_call. */ + OBJCODE_HEADER, + /* leave args on the stack */ + /* 0 */ scm_op_object_ref, 0, /* push scm_t_contregs smob */ + /* 2 */ scm_op_continuation_call, /* and longjmp (whee) */ + /* 3 */ scm_op_nop, /* pad to 8 bytes */ + /* 4 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, + /* 8 */ + + /* We could put some meta-info to say that this proc is a continuation. Not sure + how to do that, though. */ + META_HEADER, + /* 0 */ scm_op_make_eol, /* bindings */ + /* 1 */ scm_op_make_eol, /* sources */ + /* 2 */ scm_op_make_int8, 0, scm_op_make_int8, 3, /* arity: from ip 0 to ip 3 */ + /* 6 */ scm_op_make_int8_0, /* the arity is 0 required args */ + /* 7 */ scm_op_make_int8_0, /* 0 optionals */ + /* 8 */ scm_op_make_true, /* and a rest arg */ + /* 9 */ scm_op_list, 0, 5, /* make a list of those 5 vals */ + /* 12 */ scm_op_list, 0, 1, /* and the arities will be a list of that one list */ + /* 15 */ scm_op_list, 0, 3, /* pack bindings, sources, and arities into list */ + /* 18 */ scm_op_return /* and return */ + /* 19 */ +}; + + +static SCM +make_continuation_trampoline (SCM contregs) +{ + SCM ret = scm_make_program (cont_objcode, + scm_c_make_vector (1, contregs), + SCM_BOOL_F); + SCM_SET_CELL_WORD_0 (ret, + SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_CONTINUATION); + + return ret; +} + + +/* {Continuations} + */ static int @@ -92,7 +193,7 @@ scm_make_continuation (int *first) memcpy (continuation->stack, src, sizeof (SCM_STACKITEM) * stack_size); continuation->vm_conts = scm_vm_capture_continuations (); - SCM_NEWSMOB (cont, scm_tc16_continuation, continuation); + SCM_NEWSMOB (cont, tc16_continuation, continuation); *first = !SCM_I_SETJMP (continuation->jmpbuf); if (*first) @@ -110,7 +211,7 @@ scm_make_continuation (int *first) (void *) thread->register_backing_store_base, continuation->backing_store_size); #endif /* __ia64__ */ - return cont; + return make_continuation_trampoline (cont); } else { @@ -121,6 +222,34 @@ scm_make_continuation (int *first) } #undef FUNC_NAME +SCM +scm_i_continuation_to_frame (SCM continuation) +{ + SCM contregs; + scm_t_contregs *cont; + + contregs = scm_c_vector_ref (scm_program_objects (continuation), 0); + cont = SCM_CONTREGS (contregs); + + if (!scm_is_null (cont->vm_conts)) + { + SCM vm_cont; + struct scm_vm_cont *data; + vm_cont = scm_cdr (scm_car (cont->vm_conts)); + data = SCM_VM_CONT_DATA (vm_cont); + return scm_c_make_frame (vm_cont, + data->fp + data->reloc, + data->sp + data->reloc, + data->ip, + data->reloc); + } + else + return SCM_BOOL_F; +} + + +/* {Apply} + */ /* Invoking a continuation proceeds as follows: * @@ -242,24 +371,25 @@ scm_dynthrow (SCM cont, SCM val) } -static SCM -continuation_apply (SCM cont, SCM args) -#define FUNC_NAME "continuation_apply" +void +scm_i_continuation_call (SCM cont, size_t n, SCM *argv) { scm_i_thread *thread = SCM_I_CURRENT_THREAD; scm_t_contregs *continuation = SCM_CONTREGS (cont); + SCM args = SCM_EOL; + + /* FIXME: shuffle args on VM stack instead of heap-allocating */ + while (n--) + args = scm_cons (argv[n], args); if (continuation->root != thread->continuation_root) - { - SCM_MISC_ERROR - ("invoking continuation would cross continuation barrier: ~A", - scm_list_1 (cont)); - } + scm_misc_error + ("%continuation-call", + "invoking continuation would cross continuation barrier: ~A", + scm_list_1 (cont)); scm_dynthrow (cont, scm_values (args)); - return SCM_UNSPECIFIED; /* not reached */ } -#undef FUNC_NAME SCM scm_i_with_continuation_barrier (scm_t_catch_body body, @@ -374,9 +504,8 @@ SCM_DEFINE (scm_with_continuation_barrier, "with-continuation-barrier", 1,0,0, void scm_init_continuations () { - scm_tc16_continuation = scm_make_smob_type ("continuation", 0); - scm_set_smob_print (scm_tc16_continuation, continuation_print); - scm_set_smob_apply (scm_tc16_continuation, continuation_apply, 0, 0, 1); + tc16_continuation = scm_make_smob_type ("continuation", 0); + scm_set_smob_print (tc16_continuation, continuation_print); #include "libguile/continuations.x" } diff --git a/libguile/continuations.h b/libguile/continuations.h index a04c53f2c..a15a0fd0c 100644 --- a/libguile/continuations.h +++ b/libguile/continuations.h @@ -3,7 +3,7 @@ #ifndef SCM_CONTINUATIONS_H #define SCM_CONTINUATIONS_H -/* Copyright (C) 1995,1996,2000,2001, 2006, 2008, 2009 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,2000,2001, 2006, 2008, 2009, 2010 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -31,6 +31,9 @@ #endif /* __ia64__ */ +#define SCM_CONTINUATIONP(x) \ + (SCM_PROGRAM_P (x) && SCM_PROGRAM_IS_CONTINUATION (x)) + /* a continuation SCM is a non-immediate pointing to a heap cell with: word 0: bits 0-15: smob type tag: scm_tc16_continuation. bits 16-31: unused. @@ -39,8 +42,6 @@ in the num_stack_items field of the structure. */ -SCM_API scm_t_bits scm_tc16_continuation; - typedef struct { SCM throw_value; @@ -67,22 +68,12 @@ typedef struct SCM_STACKITEM stack[1]; /* copied stack of size num_stack_items. */ } scm_t_contregs; -#define SCM_CONTINUATIONP(x) SCM_TYP16_PREDICATE (scm_tc16_continuation, x) - -#define SCM_CONTREGS(x) ((scm_t_contregs *) SCM_SMOB_DATA_1 (x)) - -#define SCM_CONTINUATION_LENGTH(x) (SCM_CONTREGS (x)->num_stack_items) -#define SCM_SET_CONTINUATION_LENGTH(x, n)\ - (SCM_CONTREGS (x)->num_stack_items = (n)) -#define SCM_JMPBUF(x) ((SCM_CONTREGS (x))->jmpbuf) -#define SCM_DYNENV(x) ((SCM_CONTREGS (x))->dynenv) -#define SCM_THROW_VALUE(x) ((SCM_CONTREGS (x))->throw_value) -#define SCM_CONTINUATION_ROOT(x) ((SCM_CONTREGS (x))->root) -#define SCM_DFRAME(x) ((SCM_CONTREGS (x))->dframe) SCM_API SCM scm_make_continuation (int *first); +SCM_INTERNAL SCM scm_i_continuation_to_frame (SCM cont); +SCM_INTERNAL void scm_i_continuation_call (SCM cont, size_t n, SCM *argv); SCM_API void *scm_c_with_continuation_barrier (void *(*func)(void*), void *); SCM_API SCM scm_with_continuation_barrier (SCM proc); diff --git a/libguile/programs.c b/libguile/programs.c index 189b64e74..ac35e3c10 100644 --- a/libguile/programs.c +++ b/libguile/programs.c @@ -79,7 +79,14 @@ scm_i_program_print (SCM program, SCM port, scm_print_state *pstate) (scm_c_resolve_module ("system vm program"), scm_from_locale_symbol ("write-program")); - if (scm_is_false (write_program) || print_error) + if (SCM_PROGRAM_IS_CONTINUATION (program)) + { + /* twingliness */ + scm_puts ("#', port); + } + else if (scm_is_false (write_program) || print_error) { scm_puts ("#vm_conts)) - { SCM vm_cont; - struct scm_vm_cont *data; - vm_cont = scm_cdr (scm_car (cont->vm_conts)); - data = SCM_VM_CONT_DATA (vm_cont); - frame = scm_c_make_frame (vm_cont, - data->fp + data->reloc, - data->sp + data->reloc, - data->ip, - data->reloc); - } else - frame = SCM_BOOL_F; - } + frame = scm_i_continuation_to_frame (obj); else { SCM_WRONG_TYPE_ARG (SCM_ARG1, obj); @@ -301,21 +287,7 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0, else if (SCM_VM_FRAME_P (stack)) frame = stack; else if (SCM_CONTINUATIONP (stack)) - { - scm_t_contregs *cont = SCM_CONTREGS (stack); - if (!scm_is_null (cont->vm_conts)) - { SCM vm_cont; - struct scm_vm_cont *data; - vm_cont = scm_cdr (scm_car (cont->vm_conts)); - data = SCM_VM_CONT_DATA (vm_cont); - frame = scm_c_make_frame (vm_cont, - data->fp + data->reloc, - data->sp + data->reloc, - data->ip, - data->reloc); - } else - frame = SCM_BOOL_F; - } + frame = scm_i_continuation_to_frame (stack); else { SCM_WRONG_TYPE_ARG (SCM_ARG1, stack); diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 04fee4e35..97b952187 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -978,6 +978,15 @@ VM_DEFINE_INSTRUCTION (58, foreign_call, "foreign-call", 1, -1, -1) } } +VM_DEFINE_INSTRUCTION (89, continuation_call, "continuation-call", 0, -1, 0) +{ + SCM contregs; + POP (contregs); + scm_i_continuation_call (contregs, sp - (fp - 1), fp); + /* no NEXT */ + abort (); +} + VM_DEFINE_INSTRUCTION (59, tail_call_nargs, "tail-call/nargs", 0, 0, 1) { SCM x;