libguile/continuations.c

   1 /*      Copyright (C) 1995,1996,1998, 2000 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 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
  43    gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
  44
  45 \f
  46
  47 #include <string.h>
  48
  49 #include "libguile/_scm.h"
  50 #include "libguile/root.h"
  51 #include "libguile/stackchk.h"
  52 #include "libguile/smob.h"
  53 #include "libguile/ports.h"
  54 #include "libguile/dynwind.h"
  55 #include "libguile/values.h"
  56
  57 #ifdef DEBUG_EXTENSIONS
  58 #include "libguile/debug.h"
  59 #endif
  60
  61 #include "libguile/validate.h"
  62 #include "libguile/continuations.h"
  63
  64 \f
  65
  66 /* {Continuations}
  67  */
  68
  69 scm_bits_t scm_tc16_continuation;
  70
  71 static SCM
  72 continuation_mark (SCM obj)
  73 {
  74   scm_contregs_t *continuation = SCM_CONTREGS (obj);
  75
  76   scm_gc_mark (continuation->throw_value);
  77   scm_mark_locations (continuation->stack, continuation->num_stack_items);
  78   return continuation->dynenv;
  79 }
  80
  81 static size_t
  82 continuation_free (SCM obj)
  83 {
  84   scm_contregs_t *continuation = SCM_CONTREGS (obj);
  85   /* stack array size is 1 if num_stack_items is 0 (rootcont).  */
  86   size_t extra_items = (continuation->num_stack_items > 0)
  87     ? (continuation->num_stack_items - 1)
  88     : 0;
  89   size_t bytes_free = sizeof (scm_contregs_t)
  90     + extra_items * sizeof (SCM_STACKITEM);
  91
  92   scm_must_free (continuation);
  93   return bytes_free;
  94 }
  95
  96 static int
  97 continuation_print (SCM obj, SCM port, scm_print_state *state)
  98 {
  99   scm_contregs_t *continuation = SCM_CONTREGS (obj);
 100
 101   scm_puts ("#<continuation ", port);
 102   scm_intprint (continuation->num_stack_items, 10, port);
 103   scm_puts (" @ ", port);
 104   scm_intprint (SCM_CELL_WORD_1 (obj), 16, port);
 105   scm_putc ('>', port);
 106   return 1;
 107 }
 108
 109 /* this may return more than once: the first time with the escape
 110    procedure, then subsequently with the value to be passed to the
 111    continuation.  */
 112 #define FUNC_NAME "scm_make_continuation"
 113 SCM
 114 scm_make_continuation (int *first)
 115 {
 116   volatile SCM cont;
 117   scm_contregs_t *continuation;
 118   scm_contregs_t *rootcont = SCM_CONTREGS (scm_rootcont);
 119   long stack_size;
 120   SCM_STACKITEM * src;
 121
 122   SCM_ENTER_A_SECTION;
 123   SCM_FLUSH_REGISTER_WINDOWS;
 124   stack_size = scm_stack_size (rootcont->base);
 125   continuation = scm_must_malloc (sizeof (scm_contregs_t)
 126                                   + (stack_size - 1) * sizeof (SCM_STACKITEM),
 127                                   FUNC_NAME);
 128   continuation->num_stack_items = stack_size;
 129   continuation->dynenv = scm_dynwinds;
 130   continuation->throw_value = SCM_EOL;
 131   continuation->base = src = rootcont->base;
 132   continuation->seq = rootcont->seq;
 133 #ifdef DEBUG_EXTENSIONS
 134   continuation->dframe = scm_last_debug_frame;
 135 #endif
 136   SCM_NEWSMOB (cont, scm_tc16_continuation, continuation);
 137   SCM_EXIT_A_SECTION;
 138
 139 #ifndef SCM_STACK_GROWS_UP
 140   src -= stack_size;
 141 #endif
 142   memcpy (continuation->stack, src, sizeof (SCM_STACKITEM) * stack_size);
 143
 144   if (setjmp (continuation->jmpbuf))
 145     {
 146       *first = 0;
 147       return continuation->throw_value;
 148     }
 149   else
 150     {
 151       *first = 1;
 152       return cont;
 153     }
 154 }
 155 #undef FUNC_NAME
 156
 157 static void scm_dynthrow (SCM, SCM);
 158
 159 /* Grow the stack by a fixed amount to provide space to copy in the
 160  * continuation.  Possibly this function has to be called several times
 161  * recursively before enough space is available.  Make sure the compiler does
 162  * not optimize the growth array away by storing it's address into a global
 163  * variable.
 164  */
 165
 166 scm_bits_t scm_i_dummy;
 167
 168 static void
 169 grow_stack (SCM cont, SCM val)
 170 {
 171   scm_bits_t growth[100];
 172
 173   scm_i_dummy = (scm_bits_t) growth;
 174   scm_dynthrow (cont, val);
 175 }
 176
 177
 178 /* Copy the continuation stack into the current stack.  Calling functions from
 179  * within this function is safe, since only stack frames below this function's
 180  * own frame are overwritten.  Thus, memcpy can be used for best performance.
 181  */
 182 static void
 183 copy_stack_and_call (scm_contregs_t *continuation, SCM val,
 184                      SCM_STACKITEM * dst)
 185 {
 186   memcpy (dst, continuation->stack,
 187           sizeof (SCM_STACKITEM) * continuation->num_stack_items);
 188
 189 #ifdef DEBUG_EXTENSIONS
 190   scm_last_debug_frame = continuation->dframe;
 191 #endif
 192
 193   continuation->throw_value = val;
 194   longjmp (continuation->jmpbuf, 1);
 195 }
 196
 197
 198 /* Call grow_stack until the stack space is large enough, then, as the current
 199  * stack frame might get overwritten, let copy_stack_and_call perform the
 200  * actual copying and continuation calling.
 201  */
 202 static void
 203 scm_dynthrow (SCM cont, SCM val)
 204 {
 205   scm_contregs_t *continuation = SCM_CONTREGS (cont);
 206   SCM_STACKITEM * dst = SCM_BASE (scm_rootcont);
 207   SCM_STACKITEM stack_top_element;
 208
 209 #ifdef SCM_STACK_GROWS_UP
 210   if (SCM_PTR_GE (dst + continuation->num_stack_items, &stack_top_element))
 211     grow_stack (cont, val);
 212 #else
 213   dst -= continuation->num_stack_items;
 214   if (SCM_PTR_LE (dst, &stack_top_element))
 215     grow_stack (cont, val);
 216 #endif /* def SCM_STACK_GROWS_UP */
 217
 218   SCM_FLUSH_REGISTER_WINDOWS;
 219   copy_stack_and_call (continuation, val, dst);
 220 }
 221
 222
 223 static SCM
 224 continuation_apply (SCM cont, SCM args)
 225 #define FUNC_NAME "continuation_apply"
 226 {
 227   scm_contregs_t *continuation = SCM_CONTREGS (cont);
 228   scm_contregs_t *rootcont = SCM_CONTREGS (scm_rootcont);
 229
 230   if (continuation->seq != rootcont->seq
 231       /* this base comparison isn't needed */
 232       || continuation->base != rootcont->base)
 233     {
 234       SCM_MISC_ERROR ("continuation from wrong top level: ~S",
 235                       SCM_LIST1 (cont));
 236     }
 237
 238   scm_dowinds (continuation->dynenv,
 239                scm_ilength (scm_dynwinds)
 240                - scm_ilength (continuation->dynenv));
 241
 242   scm_dynthrow (cont, scm_values (args));
 243   return SCM_UNSPECIFIED; /* not reached */
 244 }
 245 #undef FUNC_NAME
 246
 247
 248 void
 249 scm_init_continuations ()
 250 {
 251   scm_tc16_continuation = scm_make_smob_type ("continuation", 0);
 252   scm_set_smob_mark (scm_tc16_continuation, continuation_mark);
 253   scm_set_smob_free (scm_tc16_continuation, continuation_free);
 254   scm_set_smob_print (scm_tc16_continuation, continuation_print);
 255   scm_set_smob_apply (scm_tc16_continuation, continuation_apply, 0, 0, 1);
 256 #ifndef SCM_MAGIC_SNARFER
 257 #include "libguile/continuations.x"
 258 #endif
 259 }
 260
 261 /*
 262   Local Variables:
 263   c-file-style: "gnu"
 264   End:
 265 */