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 "libguile/_scm.h"
  46
  47 #include <string.h>
  48
  49 #include "libguile/root.h"
  50 #include "libguile/stackchk.h"
  51 #include "libguile/smob.h"
  52 #include "libguile/ports.h"
  53 #include "libguile/dynwind.h"
  54 #include "libguile/values.h"
  55
  56 #ifdef DEBUG_EXTENSIONS
  57 #include "libguile/debug.h"
  58 #endif
  59
  60 #include "libguile/validate.h"
  61 #include "libguile/continuations.h"
  62
  63 \f
  64
  65 /* {Continuations}
  66  */
  67
  68 scm_t_bits scm_tc16_continuation;
  69
  70 static SCM
  71 continuation_mark (SCM obj)
  72 {
  73   scm_t_contregs *continuation = SCM_CONTREGS (obj);
  74
  75   scm_gc_mark (continuation->throw_value);
  76   scm_mark_locations (continuation->stack, continuation->num_stack_items);
  77 #ifdef __ia64__
  78   if (continuation->backing_store)
  79     scm_mark_locations (continuation->backing_store,
  80                         continuation->backing_store_size /
  81                         sizeof (SCM_STACKITEM));
  82 #endif /* __ia64__ */
  83   return continuation->dynenv;
  84 }
  85
  86 static size_t
  87 continuation_free (SCM obj)
  88 {
  89   scm_t_contregs *continuation = SCM_CONTREGS (obj);
  90   /* stack array size is 1 if num_stack_items is 0 (rootcont).  */
  91   size_t extra_items = (continuation->num_stack_items > 0)
  92     ? (continuation->num_stack_items - 1)
  93     : 0;
  94   size_t bytes_free = sizeof (scm_t_contregs)
  95     + extra_items * sizeof (SCM_STACKITEM);
  96
  97 #ifdef __ia64__
  98   scm_gc_free (continuation->backing_store, continuation->backing_store_size,
  99                "continuation backing store");
 100 #endif /* __ia64__ */
 101   scm_gc_free (continuation, bytes_free, "continuation");
 102   return 0;
 103 }
 104
 105 static int
 106 continuation_print (SCM obj, SCM port, scm_print_state *state SCM_UNUSED)
 107 {
 108   scm_t_contregs *continuation = SCM_CONTREGS (obj);
 109
 110   scm_puts ("#<continuation ", port);
 111   scm_intprint (continuation->num_stack_items, 10, port);
 112   scm_puts (" @ ", port);
 113   scm_intprint (SCM_CELL_WORD_1 (obj), 16, port);
 114   scm_putc ('>', port);
 115   return 1;
 116 }
 117
 118 #ifdef __ia64__
 119 /* Extern declaration of getcontext()/setcontext() in order to redefine
 120    getcontext() since on ia64-linux the second return value indicates whether
 121    it returned from getcontext() itself or by running setcontext(). */
 122 struct rv
 123 {
 124   long retval;
 125   long first_return;
 126 };
 127 extern struct rv getcontext (ucontext_t *);
 128 extern int setcontext (ucontext_t *);
 129 #endif /* __ia64__ */
 130
 131 /* this may return more than once: the first time with the escape
 132    procedure, then subsequently with the value to be passed to the
 133    continuation.  */
 134 #define FUNC_NAME "scm_make_continuation"
 135 SCM
 136 scm_make_continuation (int *first)
 137 {
 138   volatile SCM cont;
 139   scm_t_contregs *continuation;
 140   scm_t_contregs *rootcont = SCM_CONTREGS (scm_rootcont);
 141   long stack_size;
 142   SCM_STACKITEM * src;
 143 #ifdef __ia64__
 144   struct rv rv;
 145 #endif /* __ia64__ */
 146
 147   SCM_ENTER_A_SECTION;
 148   SCM_FLUSH_REGISTER_WINDOWS;
 149   stack_size = scm_stack_size (rootcont->base);
 150   continuation = scm_gc_malloc (sizeof (scm_t_contregs)
 151                                 + (stack_size - 1) * sizeof (SCM_STACKITEM),
 152                                 "continuation");
 153   continuation->num_stack_items = stack_size;
 154   continuation->dynenv = scm_dynwinds;
 155   continuation->throw_value = SCM_EOL;
 156   continuation->base = src = rootcont->base;
 157   continuation->seq = rootcont->seq;
 158 #ifdef DEBUG_EXTENSIONS
 159   continuation->dframe = scm_last_debug_frame;
 160 #endif
 161   SCM_NEWSMOB (cont, scm_tc16_continuation, continuation);
 162   SCM_EXIT_A_SECTION;
 163
 164 #ifndef SCM_STACK_GROWS_UP
 165   src -= stack_size;
 166 #endif
 167   memcpy (continuation->stack, src, sizeof (SCM_STACKITEM) * stack_size);
 168
 169 #ifdef __ia64__
 170   rv = getcontext (&continuation->ctx);
 171   if (rv.first_return)
 172     {
 173       continuation->backing_store_size =
 174         continuation->ctx.uc_mcontext.sc_ar_bsp -
 175         (unsigned long) __libc_ia64_register_backing_store_base;
 176       continuation->backing_store = NULL;
 177       continuation->backing_store =
 178         scm_gc_malloc (continuation->backing_store_size,
 179                        "continuation backing store");
 180       memcpy (continuation->backing_store,
 181               (void *) __libc_ia64_register_backing_store_base,
 182               continuation->backing_store_size);
 183       *first = 1;
 184       return cont;
 185     }
 186   else
 187     {
 188       SCM ret = continuation->throw_value;
 189       *first = 0;
 190       continuation->throw_value = SCM_BOOL_F;
 191       return ret;
 192     }
 193 #else /* !__ia64__ */
 194   if (setjmp (continuation->jmpbuf))
 195     {
 196       SCM ret = continuation->throw_value;
 197       *first = 0;
 198       continuation->throw_value = SCM_BOOL_F;
 199       return ret;
 200     }
 201   else
 202     {
 203       *first = 1;
 204       return cont;
 205     }
 206 #endif /* !__ia64__ */
 207 }
 208 #undef FUNC_NAME
 209
 210 static void scm_dynthrow (SCM, SCM);
 211
 212 /* Grow the stack by a fixed amount to provide space to copy in the
 213  * continuation.  Possibly this function has to be called several times
 214  * recursively before enough space is available.  Make sure the compiler does
 215  * not optimize the growth array away by storing it's address into a global
 216  * variable.
 217  */
 218
 219 scm_t_bits scm_i_dummy;
 220
 221 static void
 222 grow_stack (SCM cont, SCM val)
 223 {
 224   scm_t_bits growth[100];
 225
 226   scm_i_dummy = (scm_t_bits) growth;
 227   scm_dynthrow (cont, val);
 228 }
 229
 230
 231 /* Copy the continuation stack into the current stack.  Calling functions from
 232  * within this function is safe, since only stack frames below this function's
 233  * own frame are overwritten.  Thus, memcpy can be used for best performance.
 234  */
 235 static void
 236 copy_stack_and_call (scm_t_contregs *continuation, SCM val,
 237                      SCM_STACKITEM * dst)
 238 {
 239   memcpy (dst, continuation->stack,
 240           sizeof (SCM_STACKITEM) * continuation->num_stack_items);
 241
 242 #ifdef DEBUG_EXTENSIONS
 243   scm_last_debug_frame = continuation->dframe;
 244 #endif
 245
 246   continuation->throw_value = val;
 247 #ifdef __ia64__
 248   memcpy ((void *) __libc_ia64_register_backing_store_base,
 249           continuation->backing_store,
 250           continuation->backing_store_size);
 251   setcontext (&continuation->ctx);
 252 #else
 253   longjmp (continuation->jmpbuf, 1);
 254 #endif
 255 }
 256
 257
 258 /* Call grow_stack until the stack space is large enough, then, as the current
 259  * stack frame might get overwritten, let copy_stack_and_call perform the
 260  * actual copying and continuation calling.
 261  */
 262 static void
 263 scm_dynthrow (SCM cont, SCM val)
 264 {
 265   scm_t_contregs *continuation = SCM_CONTREGS (cont);
 266   SCM_STACKITEM * dst = SCM_BASE (scm_rootcont);
 267   SCM_STACKITEM stack_top_element;
 268
 269 #ifdef SCM_STACK_GROWS_UP
 270   if (SCM_PTR_GE (dst + continuation->num_stack_items, &stack_top_element))
 271     grow_stack (cont, val);
 272 #else
 273   dst -= continuation->num_stack_items;
 274   if (dst <= &stack_top_element)
 275     grow_stack (cont, val);
 276 #endif /* def SCM_STACK_GROWS_UP */
 277
 278   SCM_FLUSH_REGISTER_WINDOWS;
 279   copy_stack_and_call (continuation, val, dst);
 280 }
 281
 282
 283 static SCM
 284 continuation_apply (SCM cont, SCM args)
 285 #define FUNC_NAME "continuation_apply"
 286 {
 287   scm_t_contregs *continuation = SCM_CONTREGS (cont);
 288   scm_t_contregs *rootcont = SCM_CONTREGS (scm_rootcont);
 289
 290   if (continuation->seq != rootcont->seq
 291       /* this base comparison isn't needed */
 292       || continuation->base != rootcont->base)
 293     {
 294       SCM_MISC_ERROR ("continuation from wrong top level: ~S",
 295                       scm_list_1 (cont));
 296     }
 297
 298   scm_dowinds (continuation->dynenv,
 299                scm_ilength (scm_dynwinds)
 300                - scm_ilength (continuation->dynenv));
 301
 302   scm_dynthrow (cont, scm_values (args));
 303   return SCM_UNSPECIFIED; /* not reached */
 304 }
 305 #undef FUNC_NAME
 306
 307
 308 void
 309 scm_init_continuations ()
 310 {
 311   scm_tc16_continuation = scm_make_smob_type ("continuation", 0);
 312   scm_set_smob_mark (scm_tc16_continuation, continuation_mark);
 313   scm_set_smob_free (scm_tc16_continuation, continuation_free);
 314   scm_set_smob_print (scm_tc16_continuation, continuation_print);
 315   scm_set_smob_apply (scm_tc16_continuation, continuation_apply, 0, 0, 1);
 316 #include "libguile/continuations.x"
 317 }
 318
 319 /*
 320   Local Variables:
 321   c-file-style: "gnu"
 322   End:
 323 */