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