libguile/continuations.c

   1 /* Copyright (C) 1995,1996,1998,2000,2001 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41
  42
  43 \f
  44
  45 #include <string.h>
  46
  47 #include "libguile/_scm.h"
  48 #include "libguile/root.h"
  49 #include "libguile/stackchk.h"
  50 #include "libguile/smob.h"
  51 #include "libguile/ports.h"
  52 #include "libguile/dynwind.h"
  53 #include "libguile/values.h"
  54
  55 #ifdef DEBUG_EXTENSIONS
  56 #include "libguile/debug.h"
  57 #endif
  58
  59 #include "libguile/validate.h"
  60 #include "libguile/continuations.h"
  61
  62 \f
  63
  64 /* {Continuations}
  65  */
  66
  67 scm_t_bits scm_tc16_continuation;
  68
  69 static SCM
  70 continuation_mark (SCM obj)
  71 {
  72   scm_t_contregs *continuation = SCM_CONTREGS (obj);
  73
  74   scm_gc_mark (continuation->throw_value);
  75   scm_mark_locations (continuation->stack, continuation->num_stack_items);
  76 #ifdef __ia64__
  77   if (continuation->backing_store)
  78     scm_mark_locations (continuation->backing_store,
  79                         continuation->backing_store_size /
  80                         sizeof (SCM_STACKITEM));
  81 #endif /* __ia64__ */
  82   return continuation->dynenv;
  83 }
  84
  85 static size_t
  86 continuation_free (SCM obj)
  87 {
  88   scm_t_contregs *continuation = SCM_CONTREGS (obj);
  89   /* stack array size is 1 if num_stack_items is 0 (rootcont).  */
  90   size_t extra_items = (continuation->num_stack_items > 0)
  91     ? (continuation->num_stack_items - 1)
  92     : 0;
  93   size_t bytes_free = sizeof (scm_t_contregs)
  94     + extra_items * sizeof (SCM_STACKITEM);
  95
  96 #ifdef __ia64__
  97   scm_gc_free (continuation->backing_store, continuation->backing_store_size,
  98                "continuation backing store");
  99 #endif /* __ia64__ */
 100   scm_gc_free (continuation, bytes_free, "continuation");
 101   return 0;
 102 }
 103
 104 static int
 105 continuation_print (SCM obj, SCM port, scm_print_state *state SCM_UNUSED)
 106 {
 107   scm_t_contregs *continuation = SCM_CONTREGS (obj);
 108
 109   scm_puts ("#<continuation ", port);
 110   scm_intprint (continuation->num_stack_items, 10, port);
 111   scm_puts (" @ ", port);
 112   scm_intprint (SCM_CELL_WORD_1 (obj), 16, port);
 113   scm_putc ('>', port);
 114   return 1;
 115 }
 116
 117 #ifdef __ia64__
 118 /* Extern declaration of getcontext()/setcontext() in order to redefine
 119    getcontext() since on ia64-linux the second return value indicates whether
 120    it returned from getcontext() itself or by running setcontext(). */
 121 struct rv
 122 {
 123   long retval;
 124   long first_return;
 125 };
 126 extern struct rv getcontext (ucontext_t *);
 127 extern int setcontext (ucontext_t *);
 128 #endif /* __ia64__ */
 129
 130 /* this may return more than once: the first time with the escape
 131    procedure, then subsequently with the value to be passed to the
 132    continuation.  */
 133 #define FUNC_NAME "scm_make_continuation"
 134 SCM
 135 scm_make_continuation (int *first)
 136 {
 137   volatile SCM cont;
 138   scm_t_contregs *continuation;
 139   scm_t_contregs *rootcont = SCM_CONTREGS (scm_rootcont);
 140   long stack_size;
 141   SCM_STACKITEM * src;
 142 #ifdef __ia64__
 143   struct rv rv;
 144 #endif /* __ia64__ */
 145
 146   SCM_ENTER_A_SECTION;
 147   SCM_FLUSH_REGISTER_WINDOWS;
 148   stack_size = scm_stack_size (rootcont->base);
 149   continuation = scm_gc_malloc (sizeof (scm_t_contregs)
 150                                 + (stack_size - 1) * sizeof (SCM_STACKITEM),
 151                                 "continuation");
 152   continuation->num_stack_items = stack_size;
 153   continuation->dynenv = scm_dynwinds;
 154   continuation->throw_value = SCM_EOL;
 155   continuation->base = src = rootcont->base;
 156   continuation->seq = rootcont->seq;
 157 #ifdef DEBUG_EXTENSIONS
 158   continuation->dframe = scm_last_debug_frame;
 159 #endif
 160   SCM_NEWSMOB (cont, scm_tc16_continuation, continuation);
 161   SCM_EXIT_A_SECTION;
 162
 163 #ifndef SCM_STACK_GROWS_UP
 164   src -= stack_size;
 165 #endif
 166   memcpy (continuation->stack, src, sizeof (SCM_STACKITEM) * stack_size);
 167
 168 #ifdef __ia64__
 169   rv = getcontext (&continuation->ctx);
 170   if (rv.first_return)
 171     {
 172       continuation->backing_store_size =
 173         continuation->ctx.uc_mcontext.sc_ar_bsp -
 174         (unsigned long) __libc_ia64_register_backing_store_base;
 175       continuation->backing_store = NULL;
 176       continuation->backing_store =
 177         scm_gc_malloc (continuation->backing_store_size,
 178                        "continuation backing store");
 179       memcpy (continuation->backing_store,
 180               (void *) __libc_ia64_register_backing_store_base,
 181               continuation->backing_store_size);
 182       *first = 1;
 183       return cont;
 184     }
 185   else
 186     {
 187       SCM ret = continuation->throw_value;
 188       *first = 0;
 189       continuation->throw_value = SCM_BOOL_F;
 190       return ret;
 191     }
 192 #else /* !__ia64__ */
 193   if (setjmp (continuation->jmpbuf))
 194     {
 195       SCM ret = continuation->throw_value;
 196       *first = 0;
 197       continuation->throw_value = SCM_BOOL_F;
 198       return ret;
 199     }
 200   else
 201     {
 202       *first = 1;
 203       return cont;
 204     }
 205 #endif /* !__ia64__ */
 206 }
 207 #undef FUNC_NAME
 208
 209 static void scm_dynthrow (SCM, SCM);
 210
 211 /* Grow the stack by a fixed amount to provide space to copy in the
 212  * continuation.  Possibly this function has to be called several times
 213  * recursively before enough space is available.  Make sure the compiler does
 214  * not optimize the growth array away by storing it's address into a global
 215  * variable.
 216  */
 217
 218 scm_t_bits scm_i_dummy;
 219
 220 static void
 221 grow_stack (SCM cont, SCM val)
 222 {
 223   scm_t_bits growth[100];
 224
 225   scm_i_dummy = (scm_t_bits) growth;
 226   scm_dynthrow (cont, val);
 227 }
 228
 229
 230 /* Copy the continuation stack into the current stack.  Calling functions from
 231  * within this function is safe, since only stack frames below this function's
 232  * own frame are overwritten.  Thus, memcpy can be used for best performance.
 233  */
 234 static void
 235 copy_stack_and_call (scm_t_contregs *continuation, SCM val,
 236                      SCM_STACKITEM * dst)
 237 {
 238   memcpy (dst, continuation->stack,
 239           sizeof (SCM_STACKITEM) * continuation->num_stack_items);
 240
 241 #ifdef DEBUG_EXTENSIONS
 242   scm_last_debug_frame = continuation->dframe;
 243 #endif
 244
 245   continuation->throw_value = val;
 246 #ifdef __ia64__
 247   memcpy ((void *) __libc_ia64_register_backing_store_base,
 248           continuation->backing_store,
 249           continuation->backing_store_size);
 250   setcontext (&continuation->ctx);
 251 #else
 252   longjmp (continuation->jmpbuf, 1);
 253 #endif
 254 }
 255
 256
 257 /* Call grow_stack until the stack space is large enough, then, as the current
 258  * stack frame might get overwritten, let copy_stack_and_call perform the
 259  * actual copying and continuation calling.
 260  */
 261 static void
 262 scm_dynthrow (SCM cont, SCM val)
 263 {
 264   scm_t_contregs *continuation = SCM_CONTREGS (cont);
 265   SCM_STACKITEM * dst = SCM_BASE (scm_rootcont);
 266   SCM_STACKITEM stack_top_element;
 267
 268 #ifdef SCM_STACK_GROWS_UP
 269   if (SCM_PTR_GE (dst + continuation->num_stack_items, &stack_top_element))
 270     grow_stack (cont, val);
 271 #else
 272   dst -= continuation->num_stack_items;
 273   if (SCM_PTR_LE (dst, &stack_top_element))
 274     grow_stack (cont, val);
 275 #endif /* def SCM_STACK_GROWS_UP */
 276
 277   SCM_FLUSH_REGISTER_WINDOWS;
 278   copy_stack_and_call (continuation, val, dst);
 279 }
 280
 281
 282 static SCM
 283 continuation_apply (SCM cont, SCM args)
 284 #define FUNC_NAME "continuation_apply"
 285 {
 286   scm_t_contregs *continuation = SCM_CONTREGS (cont);
 287   scm_t_contregs *rootcont = SCM_CONTREGS (scm_rootcont);
 288
 289   if (continuation->seq != rootcont->seq
 290       /* this base comparison isn't needed */
 291       || continuation->base != rootcont->base)
 292     {
 293       SCM_MISC_ERROR ("continuation from wrong top level: ~S",
 294                       scm_list_1 (cont));
 295     }
 296
 297   scm_dowinds (continuation->dynenv,
 298                scm_ilength (scm_dynwinds)
 299                - scm_ilength (continuation->dynenv));
 300
 301   scm_dynthrow (cont, scm_values (args));
 302   return SCM_UNSPECIFIED; /* not reached */
 303 }
 304 #undef FUNC_NAME
 305
 306
 307 void
 308 scm_init_continuations ()
 309 {
 310   scm_tc16_continuation = scm_make_smob_type ("continuation", 0);
 311   scm_set_smob_mark (scm_tc16_continuation, continuation_mark);
 312   scm_set_smob_free (scm_tc16_continuation, continuation_free);
 313   scm_set_smob_print (scm_tc16_continuation, continuation_print);
 314   scm_set_smob_apply (scm_tc16_continuation, continuation_apply, 0, 0, 1);
 315 #include "libguile/continuations.x"
 316 }
 317
 318 /*
 319   Local Variables:
 320   c-file-style: "gnu"
 321   End:
 322 */