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   bytes_free += continuation->backing_store_size;
  98   scm_must_free (continuation->backing_store);
  99 #endif /* __ia64__ */
 100   scm_must_free (continuation);
 101   return bytes_free;
 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 struct rv
 119 {
 120   long retval;
 121   long first_return;
 122 };
 123 extern struct rv getcontext (ucontext_t *);
 124 extern int setcontext (ucontext_t *);
 125 #endif /* __ia64__ */
 126
 127 /* this may return more than once: the first time with the escape
 128    procedure, then subsequently with the value to be passed to the
 129    continuation.  */
 130 #define FUNC_NAME "scm_make_continuation"
 131 SCM
 132 scm_make_continuation (int *first)
 133 {
 134   volatile SCM cont;
 135   scm_t_contregs *continuation;
 136   scm_t_contregs *rootcont = SCM_CONTREGS (scm_rootcont);
 137   long stack_size;
 138   SCM_STACKITEM * src;
 139 #ifdef __ia64__
 140   struct rv rv;
 141 #endif
 142
 143   SCM_ENTER_A_SECTION;
 144   SCM_FLUSH_REGISTER_WINDOWS;
 145   stack_size = scm_stack_size (rootcont->base);
 146   continuation = scm_must_malloc (sizeof (scm_t_contregs)
 147                                   + (stack_size - 1) * sizeof (SCM_STACKITEM),
 148                                   FUNC_NAME);
 149   continuation->num_stack_items = stack_size;
 150   continuation->dynenv = scm_dynwinds;
 151   continuation->throw_value = SCM_EOL;
 152   continuation->base = src = rootcont->base;
 153   continuation->seq = rootcont->seq;
 154 #ifdef DEBUG_EXTENSIONS
 155   continuation->dframe = scm_last_debug_frame;
 156 #endif
 157   SCM_NEWSMOB (cont, scm_tc16_continuation, continuation);
 158   SCM_EXIT_A_SECTION;
 159
 160 #ifndef SCM_STACK_GROWS_UP
 161   src -= stack_size;
 162 #endif
 163   memcpy (continuation->stack, src, sizeof (SCM_STACKITEM) * stack_size);
 164
 165 #ifdef __ia64__
 166   rv = getcontext (&continuation->ctx);
 167   if (rv.first_return)
 168     {
 169       continuation->backing_store_size =
 170         continuation->ctx.uc_mcontext.sc_ar_bsp -
 171         __libc_ia64_register_backing_store_base;
 172       continuation->backing_store = NULL;
 173       continuation->backing_store =
 174         scm_must_malloc (continuation->backing_store_size, FUNC_NAME);
 175       memcpy (continuation->backing_store,
 176               (void *) __libc_ia64_register_backing_store_base,
 177               continuation->backing_store_size);
 178       *first = 1;
 179       return cont;
 180     }
 181   else
 182     {
 183       *first = 0;
 184       return continuation->throw_value;
 185     }
 186 #else /* !__ia64__ */
 187   if (setjmp (continuation->jmpbuf))
 188     {
 189       *first = 0;
 190       return continuation->throw_value;
 191     }
 192   else
 193     {
 194       *first = 1;
 195       return cont;
 196     }
 197 #endif /* !__ia64__ */
 198 }
 199 #undef FUNC_NAME
 200
 201 static void scm_dynthrow (SCM, SCM);
 202
 203 /* Grow the stack by a fixed amount to provide space to copy in the
 204  * continuation.  Possibly this function has to be called several times
 205  * recursively before enough space is available.  Make sure the compiler does
 206  * not optimize the growth array away by storing it's address into a global
 207  * variable.
 208  */
 209
 210 scm_t_bits scm_i_dummy;
 211
 212 static void
 213 grow_stack (SCM cont, SCM val)
 214 {
 215   scm_t_bits growth[100];
 216
 217   scm_i_dummy = (scm_t_bits) growth;
 218   scm_dynthrow (cont, val);
 219 }
 220
 221
 222 /* Copy the continuation stack into the current stack.  Calling functions from
 223  * within this function is safe, since only stack frames below this function's
 224  * own frame are overwritten.  Thus, memcpy can be used for best performance.
 225  */
 226 static void
 227 copy_stack_and_call (scm_t_contregs *continuation, SCM val,
 228                      SCM_STACKITEM * dst)
 229 {
 230   memcpy (dst, continuation->stack,
 231           sizeof (SCM_STACKITEM) * continuation->num_stack_items);
 232
 233 #ifdef DEBUG_EXTENSIONS
 234   scm_last_debug_frame = continuation->dframe;
 235 #endif
 236
 237   continuation->throw_value = val;
 238 #ifdef __ia64__
 239   memcpy ((void *) __libc_ia64_register_backing_store_base,
 240           continuation->backing_store,
 241           continuation->backing_store_size);
 242   setcontext (&continuation->ctx);
 243 #else
 244   longjmp (continuation->jmpbuf, 1);
 245 #endif
 246 }
 247
 248
 249 /* Call grow_stack until the stack space is large enough, then, as the current
 250  * stack frame might get overwritten, let copy_stack_and_call perform the
 251  * actual copying and continuation calling.
 252  */
 253 static void
 254 scm_dynthrow (SCM cont, SCM val)
 255 {
 256   scm_t_contregs *continuation = SCM_CONTREGS (cont);
 257   SCM_STACKITEM * dst = SCM_BASE (scm_rootcont);
 258   SCM_STACKITEM stack_top_element;
 259
 260 #ifdef SCM_STACK_GROWS_UP
 261   if (SCM_PTR_GE (dst + continuation->num_stack_items, &stack_top_element))
 262     grow_stack (cont, val);
 263 #else
 264   dst -= continuation->num_stack_items;
 265   if (SCM_PTR_LE (dst, &stack_top_element))
 266     grow_stack (cont, val);
 267 #endif /* def SCM_STACK_GROWS_UP */
 268
 269   SCM_FLUSH_REGISTER_WINDOWS;
 270   copy_stack_and_call (continuation, val, dst);
 271 }
 272
 273
 274 static SCM
 275 continuation_apply (SCM cont, SCM args)
 276 #define FUNC_NAME "continuation_apply"
 277 {
 278   scm_t_contregs *continuation = SCM_CONTREGS (cont);
 279   scm_t_contregs *rootcont = SCM_CONTREGS (scm_rootcont);
 280
 281   if (continuation->seq != rootcont->seq
 282       /* this base comparison isn't needed */
 283       || continuation->base != rootcont->base)
 284     {
 285       SCM_MISC_ERROR ("continuation from wrong top level: ~S",
 286                       scm_list_1 (cont));
 287     }
 288
 289   scm_dowinds (continuation->dynenv,
 290                scm_ilength (scm_dynwinds)
 291                - scm_ilength (continuation->dynenv));
 292
 293   scm_dynthrow (cont, scm_values (args));
 294   return SCM_UNSPECIFIED; /* not reached */
 295 }
 296 #undef FUNC_NAME
 297
 298
 299 void
 300 scm_init_continuations ()
 301 {
 302   scm_tc16_continuation = scm_make_smob_type ("continuation", 0);
 303   scm_set_smob_mark (scm_tc16_continuation, continuation_mark);
 304   scm_set_smob_free (scm_tc16_continuation, continuation_free);
 305   scm_set_smob_print (scm_tc16_continuation, continuation_print);
 306   scm_set_smob_apply (scm_tc16_continuation, continuation_apply, 0, 0, 1);
 307 #ifndef SCM_MAGIC_SNARFER
 308 #include "libguile/continuations.x"
 309 #endif
 310 }
 311
 312 /*
 313   Local Variables:
 314   c-file-style: "gnu"
 315   End:
 316 */