X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/a6c64c3c6df9ae2b8baa0f166887c12270b5d646..eb7e1603ad497d0efff686e26e23af987c567721:/libguile/continuations.c diff --git a/libguile/continuations.c b/libguile/continuations.c dissimilarity index 92% index f04912c8a..60322b3af 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -1,212 +1,318 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include -#include "_scm.h" -#include "stackchk.h" -#ifdef DEBUG_EXTENSIONS -#include "debug.h" -#endif -#include "dynwind.h" - -#include "continuations.h" - - -/* {Continuations} - */ - -static char s_cont[] = "continuation"; - - -SCM -scm_make_cont (answer) - SCM * answer; -{ - long j; - SCM cont; - -#ifdef CHEAP_CONTINUATIONS - SCM_NEWCELL (cont); - *answer = cont; - SCM_DEFER_INTS; - SCM_SETJMPBUF (cont, scm_must_malloc ((long) sizeof (scm_contregs), s_cont)); - SCM_SETCAR (cont, scm_tc7_contin); - SCM_DYNENV (cont) = scm_dynwinds; - SCM_THROW_VALUE = SCM_EOL; - SCM_BASE (cont) = SCM_BASE (rootcont); - SCM_SEQ (cont) = SCM_SEQ (rootcont); - SCM_ALLOW_INTS; -#else - register SCM_STACKITEM *src, *dst; - -#if 0 - { - SCM winds; - - for (winds = scm_dynwinds; winds != SCM_EOL; winds = SCM_CDR (winds)) - { - if (SCM_INUMP (SCM_CAR (winds))) - { - scm_relocate_chunk_to_heap (SCM_CAR (winds)); - } - } - } -#endif - - SCM_NEWCELL (cont); - *answer = cont; - SCM_DEFER_INTS; - SCM_FLUSH_REGISTER_WINDOWS; - j = scm_stack_size (SCM_BASE (scm_rootcont)); - SCM_SETJMPBUF (cont, - scm_must_malloc ((long) (sizeof (scm_contregs) + j * sizeof (SCM_STACKITEM)), - s_cont)); - SCM_SETLENGTH (cont, j, scm_tc7_contin); - SCM_DYNENV (cont) = scm_dynwinds; - SCM_THROW_VALUE (cont) = SCM_EOL; - src = SCM_BASE (cont) = SCM_BASE (scm_rootcont); - SCM_SEQ (cont) = SCM_SEQ (scm_rootcont); - SCM_ALLOW_INTS; -#ifndef SCM_STACK_GROWS_UP - src -= SCM_LENGTH (cont); -#endif /* ndef SCM_STACK_GROWS_UP */ - dst = (SCM_STACKITEM *) (SCM_CHARS (cont) + sizeof (scm_contregs)); - for (j = SCM_LENGTH (cont); 0 <= --j;) - *dst++ = *src++; -#endif /* def CHEAP_CONTINUATIONS */ -#ifdef DEBUG_EXTENSIONS - SCM_DFRAME (cont) = scm_last_debug_frame; -#endif - return cont; -} - -/* Grow the stack so that there is room */ -/* to copy in the continuation. Then */ -#ifndef CHEAP_CONTINUATIONS - -static void grow_throw SCM_P ((SCM *a)); - -static void -grow_throw (a) - SCM *a; -{ /* retry the throw. */ - SCM growth[100]; - growth[0] = a[0]; - growth[1] = a[1]; - growth[2] = a[2] + 1; - growth[3] = (SCM) a; - scm_dynthrow (growth); -} -#endif /* ndef CHEAP_CONTINUATIONS */ - - -void -scm_dynthrow (a) - SCM *a; -{ - SCM cont = a[0], val = a[1]; -#ifndef CHEAP_CONTINUATIONS - register long j; - register SCM_STACKITEM *src, *dst = SCM_BASE (scm_rootcont); -#ifdef SCM_STACK_GROWS_UP - if (a[2] && (a - ((SCM *) a[3]) < 100)) -#else - if (a[2] && (((SCM *) a[3]) - a < 100)) -#endif - fputs ("grow_throw: check if SCM growth[100]; being optimized out\n", - stderr); - /* if (a[2]) fprintf(stderr, " ct = %ld, dist = %ld\n", - a[2], (((SCM *)a[3]) - a)); */ -#ifdef SCM_STACK_GROWS_UP - if (SCM_PTR_GE (dst + SCM_LENGTH (cont), (SCM_STACKITEM *) & a)) - grow_throw (a); -#else - dst -= SCM_LENGTH (cont); - if (SCM_PTR_LE (dst, (SCM_STACKITEM *) & a)) - grow_throw (a); -#endif /* def SCM_STACK_GROWS_UP */ - SCM_FLUSH_REGISTER_WINDOWS; - src = (SCM_STACKITEM *) (SCM_CHARS (cont) + sizeof (scm_contregs)); - for (j = SCM_LENGTH (cont); 0 <= --j;) - *dst++ = *src++; -#ifdef sparc /* clear out stack up to this stackframe */ - /* maybe this would help, maybe not */ -/* bzero((void *)&a, sizeof(SCM_STACKITEM) * (((SCM_STACKITEM *)&a) - - (dst - SCM_LENGTH(cont)))) */ -#endif -#endif /* ndef CHEAP_CONTINUATIONS */ -#ifdef DEBUG_EXTENSIONS - scm_last_debug_frame = SCM_DFRAME (cont); -#endif - SCM_THROW_VALUE(cont) = val; - longjmp (SCM_JMPBUF (cont), 1); -} - - -SCM -scm_call_continuation (cont, val) - SCM cont; - SCM val; -{ - SCM a[3]; - a[0] = cont; - a[1] = val; - a[2] = 0; - if ( (SCM_SEQ (cont) != SCM_SEQ (scm_rootcont)) - || (SCM_BASE (cont) != SCM_BASE (scm_rootcont))) /* base compare not needed */ - scm_wta (cont, "continuation from wrong top level", s_cont); - - scm_dowinds (SCM_DYNENV (cont), - scm_ilength (scm_dynwinds) - scm_ilength (SCM_DYNENV (cont))); - - scm_dynthrow (a); - return SCM_UNSPECIFIED; /* not reached */ -} - - - -void -scm_init_continuations () -{ -#include "continuations.x" -} - +/* Copyright (C) 1995,1996,1998,2000,2001 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 as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + + + + +#include "libguile/_scm.h" + +#include + +#include "libguile/debug.h" +#include "libguile/root.h" +#include "libguile/stackchk.h" +#include "libguile/smob.h" +#include "libguile/ports.h" +#include "libguile/dynwind.h" +#include "libguile/values.h" + +#include "libguile/validate.h" +#include "libguile/continuations.h" + + + +/* {Continuations} + */ + +scm_t_bits scm_tc16_continuation; + +static SCM +continuation_mark (SCM obj) +{ + scm_t_contregs *continuation = SCM_CONTREGS (obj); + + scm_gc_mark (continuation->throw_value); + scm_mark_locations (continuation->stack, continuation->num_stack_items); +#ifdef __ia64__ + if (continuation->backing_store) + scm_mark_locations (continuation->backing_store, + continuation->backing_store_size / + sizeof (SCM_STACKITEM)); +#endif /* __ia64__ */ + return continuation->dynenv; +} + +static size_t +continuation_free (SCM obj) +{ + scm_t_contregs *continuation = SCM_CONTREGS (obj); + /* stack array size is 1 if num_stack_items is 0 (rootcont). */ + size_t extra_items = (continuation->num_stack_items > 0) + ? (continuation->num_stack_items - 1) + : 0; + size_t bytes_free = sizeof (scm_t_contregs) + + extra_items * sizeof (SCM_STACKITEM); + +#ifdef __ia64__ + scm_gc_free (continuation->backing_store, continuation->backing_store_size, + "continuation backing store"); +#endif /* __ia64__ */ + scm_gc_free (continuation, bytes_free, "continuation"); + return 0; +} + +static int +continuation_print (SCM obj, SCM port, scm_print_state *state SCM_UNUSED) +{ + scm_t_contregs *continuation = SCM_CONTREGS (obj); + + scm_puts ("#num_stack_items, 10, port); + scm_puts (" @ ", port); + scm_intprint (SCM_CELL_WORD_1 (obj), 16, port); + scm_putc ('>', port); + return 1; +} + +#ifdef __ia64__ +/* Extern declaration of getcontext()/setcontext() in order to redefine + getcontext() since on ia64-linux the second return value indicates whether + it returned from getcontext() itself or by running setcontext(). */ +struct rv +{ + long retval; + long first_return; +}; +extern struct rv ia64_getcontext (ucontext_t *) __asm__ ("getcontext"); +#endif /* __ia64__ */ + +/* this may return more than once: the first time with the escape + procedure, then subsequently with the value to be passed to the + continuation. */ +#define FUNC_NAME "scm_make_continuation" +SCM +scm_make_continuation (int *first) +{ + volatile SCM cont; + scm_t_contregs *continuation; + scm_t_contregs *rootcont = SCM_CONTREGS (scm_rootcont); + long stack_size; + SCM_STACKITEM * src; +#ifdef __ia64__ + struct rv rv; +#endif /* __ia64__ */ + + SCM_ENTER_A_SECTION; + SCM_FLUSH_REGISTER_WINDOWS; + stack_size = scm_stack_size (rootcont->base); + continuation = scm_gc_malloc (sizeof (scm_t_contregs) + + (stack_size - 1) * sizeof (SCM_STACKITEM), + "continuation"); + continuation->num_stack_items = stack_size; + continuation->dynenv = scm_dynwinds; + continuation->throw_value = SCM_EOL; + continuation->base = src = rootcont->base; + continuation->seq = rootcont->seq; + continuation->dframe = scm_last_debug_frame; + SCM_NEWSMOB (cont, scm_tc16_continuation, continuation); + SCM_EXIT_A_SECTION; + +#if ! SCM_STACK_GROWS_UP + src -= stack_size; +#endif + memcpy (continuation->stack, src, sizeof (SCM_STACKITEM) * stack_size); + +#ifdef __ia64__ + rv = ia64_getcontext (&continuation->ctx); + if (rv.first_return) + { + continuation->backing_store_size = + continuation->ctx.uc_mcontext.sc_ar_bsp - + (unsigned long) __libc_ia64_register_backing_store_base; + continuation->backing_store = NULL; + continuation->backing_store = + scm_gc_malloc (continuation->backing_store_size, + "continuation backing store"); + memcpy (continuation->backing_store, + (void *) __libc_ia64_register_backing_store_base, + continuation->backing_store_size); + *first = 1; + return cont; + } + else + { + SCM ret = continuation->throw_value; + *first = 0; + continuation->throw_value = SCM_BOOL_F; + return ret; + } +#else /* !__ia64__ */ + if (setjmp (continuation->jmpbuf)) + { + SCM ret = continuation->throw_value; + *first = 0; + continuation->throw_value = SCM_BOOL_F; + return ret; + } + else + { + *first = 1; + return cont; + } +#endif /* !__ia64__ */ +} +#undef FUNC_NAME + + +/* Invoking a continuation proceeds as follows: + * + * - the stack is made large enough for the called continuation + * - the old windchain is unwound down to the branching point + * - the continuation stack is copied into place + * - the windchain is rewound up to the continuation's context + * - the continuation is invoked via longjmp (or setcontext) + * + * This order is important so that unwind and rewind handlers are run + * with their correct stack. + */ + +static void scm_dynthrow (SCM, SCM); + +/* Grow the stack by a fixed amount to provide space to copy in the + * continuation. Possibly this function has to be called several times + * recursively before enough space is available. Make sure the compiler does + * not optimize the growth array away by storing it's address into a global + * variable. + */ + +scm_t_bits scm_i_dummy; + +static void +grow_stack (SCM cont, SCM val) +{ + scm_t_bits growth[100]; + + scm_i_dummy = (scm_t_bits) growth; + scm_dynthrow (cont, val); +} + + +/* Copy the continuation stack into the current stack. Calling functions from + * within this function is safe, since only stack frames below this function's + * own frame are overwritten. Thus, memcpy can be used for best performance. + */ + +typedef struct { + scm_t_contregs *continuation; + SCM_STACKITEM *dst; +} copy_stack_data; + +static void +copy_stack (void *data) +{ + copy_stack_data *d = (copy_stack_data *)data; + memcpy (d->dst, d->continuation->stack, + sizeof (SCM_STACKITEM) * d->continuation->num_stack_items); +} + +static void +copy_stack_and_call (scm_t_contregs *continuation, SCM val, + SCM_STACKITEM * dst) +{ + long delta; + copy_stack_data data; + + delta = scm_ilength (scm_dynwinds) - scm_ilength (continuation->dynenv); + data.continuation = continuation; + data.dst = dst; + scm_i_dowinds (continuation->dynenv, delta, copy_stack, &data); + + scm_last_debug_frame = continuation->dframe; + + continuation->throw_value = val; +#ifdef __ia64__ + memcpy ((void *) __libc_ia64_register_backing_store_base, + continuation->backing_store, + continuation->backing_store_size); + setcontext (&continuation->ctx); +#else + longjmp (continuation->jmpbuf, 1); +#endif +} + +/* Call grow_stack until the stack space is large enough, then, as the current + * stack frame might get overwritten, let copy_stack_and_call perform the + * actual copying and continuation calling. + */ +static void +scm_dynthrow (SCM cont, SCM val) +{ + scm_t_contregs *continuation = SCM_CONTREGS (cont); + SCM_STACKITEM * dst = SCM_BASE (scm_rootcont); + SCM_STACKITEM stack_top_element; + +#if SCM_STACK_GROWS_UP + if (SCM_PTR_GE (dst + continuation->num_stack_items, &stack_top_element)) + grow_stack (cont, val); +#else + dst -= continuation->num_stack_items; + if (dst <= &stack_top_element) + grow_stack (cont, val); +#endif /* def SCM_STACK_GROWS_UP */ + + SCM_FLUSH_REGISTER_WINDOWS; + copy_stack_and_call (continuation, val, dst); +} + + +static SCM +continuation_apply (SCM cont, SCM args) +#define FUNC_NAME "continuation_apply" +{ + scm_t_contregs *continuation = SCM_CONTREGS (cont); + scm_t_contregs *rootcont = SCM_CONTREGS (scm_rootcont); + + if (continuation->seq != rootcont->seq + /* this base comparison isn't needed */ + || continuation->base != rootcont->base) + { + SCM_MISC_ERROR ("continuation from wrong top level: ~S", + scm_list_1 (cont)); + } + + scm_dynthrow (cont, scm_values (args)); + return SCM_UNSPECIFIED; /* not reached */ +} +#undef FUNC_NAME + + +void +scm_init_continuations () +{ + scm_tc16_continuation = scm_make_smob_type ("continuation", 0); + scm_set_smob_mark (scm_tc16_continuation, continuation_mark); + scm_set_smob_free (scm_tc16_continuation, continuation_free); + scm_set_smob_print (scm_tc16_continuation, continuation_print); + scm_set_smob_apply (scm_tc16_continuation, continuation_apply, 0, 0, 1); +#include "libguile/continuations.x" +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/