guile18/libguile/continuations.c

   1 /* Copyright (C) 1995,1996,1998,2000,2001,2004, 2006, 2008 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public
   5  * License as published by the Free Software Foundation; either
   6  * version 2.1 of the License, or (at your option) any later version.
   7  *
   8  * This library 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 GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16  */
  17
  18
  19 \f
  20 #ifdef HAVE_CONFIG_H
  21 # include <config.h>
  22 #endif
  23
  24 #include "libguile/_scm.h"
  25
  26 #include <string.h>
  27 #include <stdio.h>
  28
  29 #include "libguile/async.h"
  30 #include "libguile/debug.h"
  31 #include "libguile/root.h"
  32 #include "libguile/stackchk.h"
  33 #include "libguile/smob.h"
  34 #include "libguile/ports.h"
  35 #include "libguile/dynwind.h"
  36 #include "libguile/values.h"
  37 #include "libguile/eval.h"
  38
  39 #include "libguile/validate.h"
  40 #include "libguile/continuations.h"
  41
  42 \f
  43
  44 /* {Continuations}
  45  */
  46
  47 scm_t_bits scm_tc16_continuation;
  48
  49 static SCM
  50 continuation_mark (SCM obj)
  51 {
  52   scm_t_contregs *continuation = SCM_CONTREGS (obj);
  53
  54   scm_gc_mark (continuation->root);
  55   scm_gc_mark (continuation->throw_value);
  56   scm_mark_locations (continuation->stack, continuation->num_stack_items);
  57 #ifdef __ia64__
  58   if (continuation->backing_store)
  59     scm_mark_locations (continuation->backing_store,
  60                         continuation->backing_store_size /
  61                         sizeof (SCM_STACKITEM));
  62 #endif /* __ia64__ */
  63   return continuation->dynenv;
  64 }
  65
  66 static size_t
  67 continuation_free (SCM obj)
  68 {
  69   scm_t_contregs *continuation = SCM_CONTREGS (obj);
  70   /* stack array size is 1 if num_stack_items is 0.  */
  71   size_t extra_items = (continuation->num_stack_items > 0)
  72     ? (continuation->num_stack_items - 1)
  73     : 0;
  74   size_t bytes_free = sizeof (scm_t_contregs)
  75     + extra_items * sizeof (SCM_STACKITEM);
  76
  77 #ifdef __ia64__
  78   scm_gc_free (continuation->backing_store, continuation->backing_store_size,
  79                "continuation backing store");
  80 #endif /* __ia64__ */
  81   scm_gc_free (continuation, bytes_free, "continuation");
  82   return 0;
  83 }
  84
  85 static int
  86 continuation_print (SCM obj, SCM port, scm_print_state *state SCM_UNUSED)
  87 {
  88   scm_t_contregs *continuation = SCM_CONTREGS (obj);
  89
  90   scm_puts ("#<continuation ", port);
  91   scm_intprint (continuation->num_stack_items, 10, port);
  92   scm_puts (" @ ", port);
  93   scm_uintprint (SCM_CELL_WORD_1 (obj), 16, port);
  94   scm_putc ('>', port);
  95   return 1;
  96 }
  97
  98 /* this may return more than once: the first time with the escape
  99    procedure, then subsequently with the value to be passed to the
 100    continuation.  */
 101 #define FUNC_NAME "scm_make_continuation"
 102 SCM
 103 scm_make_continuation (int *first)
 104 {
 105   scm_i_thread *thread = SCM_I_CURRENT_THREAD;
 106   SCM cont;
 107   scm_t_contregs *continuation;
 108   long stack_size;
 109   SCM_STACKITEM * src;
 110
 111   SCM_FLUSH_REGISTER_WINDOWS;
 112   stack_size = scm_stack_size (thread->continuation_base);
 113   continuation = scm_gc_malloc (sizeof (scm_t_contregs)
 114                                 + (stack_size - 1) * sizeof (SCM_STACKITEM),
 115                                 "continuation");
 116   continuation->num_stack_items = stack_size;
 117   continuation->dynenv = scm_i_dynwinds ();
 118   continuation->throw_value = SCM_EOL;
 119   continuation->root = thread->continuation_root;
 120   continuation->dframe = scm_i_last_debug_frame ();
 121   src = thread->continuation_base;
 122   SCM_NEWSMOB (cont, scm_tc16_continuation, continuation);
 123
 124 #if ! SCM_STACK_GROWS_UP
 125   src -= stack_size;
 126 #endif
 127   continuation->offset = continuation->stack - src;
 128   memcpy (continuation->stack, src, sizeof (SCM_STACKITEM) * stack_size);
 129
 130   *first = !SCM_I_SETJMP (continuation->jmpbuf);
 131   if (*first)
 132     {
 133 #ifdef __ia64__
 134       continuation->backing_store_size =
 135         (char *) scm_ia64_ar_bsp(&continuation->jmpbuf.ctx)
 136         -
 137         (char *) thread->register_backing_store_base;
 138       continuation->backing_store = NULL;
 139       continuation->backing_store =
 140         scm_gc_malloc (continuation->backing_store_size,
 141                        "continuation backing store");
 142       memcpy (continuation->backing_store,
 143               (void *) thread->register_backing_store_base,
 144               continuation->backing_store_size);
 145 #endif /* __ia64__ */
 146       return cont;
 147     }
 148   else
 149     {
 150       SCM ret = continuation->throw_value;
 151       continuation->throw_value = SCM_BOOL_F;
 152       return ret;
 153     }
 154 }
 155 #undef FUNC_NAME
 156
 157
 158 /* Invoking a continuation proceeds as follows:
 159  *
 160  * - the stack is made large enough for the called continuation
 161  * - the old windchain is unwound down to the branching point
 162  * - the continuation stack is copied into place
 163  * - the windchain is rewound up to the continuation's context
 164  * - the continuation is invoked via longjmp (or setcontext)
 165  *
 166  * This order is important so that unwind and rewind handlers are run
 167  * with their correct stack.
 168  */
 169
 170 static void scm_dynthrow (SCM, SCM);
 171
 172 /* Grow the stack by a fixed amount to provide space to copy in the
 173  * continuation.  Possibly this function has to be called several times
 174  * recursively before enough space is available.  Make sure the compiler does
 175  * not optimize the growth array away by storing it's address into a global
 176  * variable.
 177  */
 178
 179 scm_t_bits scm_i_dummy;
 180
 181 static void
 182 grow_stack (SCM cont, SCM val)
 183 {
 184   scm_t_bits growth[100];
 185
 186   scm_i_dummy = (scm_t_bits) growth;
 187   scm_dynthrow (cont, val);
 188 }
 189
 190
 191 /* Copy the continuation stack into the current stack.  Calling functions from
 192  * within this function is safe, since only stack frames below this function's
 193  * own frame are overwritten.  Thus, memcpy can be used for best performance.
 194  */
 195
 196 typedef struct {
 197   scm_t_contregs *continuation;
 198   SCM_STACKITEM *dst;
 199 } copy_stack_data;
 200
 201 static void
 202 copy_stack (void *data)
 203 {
 204   copy_stack_data *d = (copy_stack_data *)data;
 205   memcpy (d->dst, d->continuation->stack,
 206           sizeof (SCM_STACKITEM) * d->continuation->num_stack_items);
 207 #ifdef __ia64__
 208   SCM_I_CURRENT_THREAD->pending_rbs_continuation = d->continuation;
 209 #endif
 210 }
 211
 212 static void
 213 copy_stack_and_call (scm_t_contregs *continuation, SCM val,
 214                      SCM_STACKITEM * dst)
 215 {
 216   long delta;
 217   copy_stack_data data;
 218
 219   delta = scm_ilength (scm_i_dynwinds ()) - scm_ilength (continuation->dynenv);
 220   data.continuation = continuation;
 221   data.dst = dst;
 222   scm_i_dowinds (continuation->dynenv, delta, copy_stack, &data);
 223
 224   scm_i_set_last_debug_frame (continuation->dframe);
 225
 226   continuation->throw_value = val;
 227   SCM_I_LONGJMP (continuation->jmpbuf, 1);
 228 }
 229
 230 #ifdef __ia64__
 231 void
 232 scm_ia64_longjmp (scm_i_jmp_buf *JB, int VAL)
 233 {
 234   scm_i_thread *t = SCM_I_CURRENT_THREAD;
 235
 236   if (t->pending_rbs_continuation)
 237     {
 238       memcpy (t->register_backing_store_base,
 239               t->pending_rbs_continuation->backing_store,
 240               t->pending_rbs_continuation->backing_store_size);
 241       t->pending_rbs_continuation = NULL;
 242     }
 243   setcontext (&JB->ctx);
 244 }
 245 #endif
 246
 247 /* Call grow_stack until the stack space is large enough, then, as the current
 248  * stack frame might get overwritten, let copy_stack_and_call perform the
 249  * actual copying and continuation calling.
 250  */
 251 static void
 252 scm_dynthrow (SCM cont, SCM val)
 253 {
 254   scm_i_thread *thread = SCM_I_CURRENT_THREAD;
 255   scm_t_contregs *continuation = SCM_CONTREGS (cont);
 256   SCM_STACKITEM *dst = thread->continuation_base;
 257   SCM_STACKITEM stack_top_element;
 258
 259   if (thread->critical_section_level)
 260     {
 261       fprintf (stderr, "continuation invoked from within critical section.\n");
 262       abort ();
 263     }
 264
 265 #if SCM_STACK_GROWS_UP
 266   if (dst + continuation->num_stack_items >= &stack_top_element)
 267     grow_stack (cont, val);
 268 #else
 269   dst -= continuation->num_stack_items;
 270   if (dst <= &stack_top_element)
 271     grow_stack (cont, val);
 272 #endif /* def SCM_STACK_GROWS_UP */
 273
 274   SCM_FLUSH_REGISTER_WINDOWS;
 275   copy_stack_and_call (continuation, val, dst);
 276 }
 277
 278
 279 static SCM
 280 continuation_apply (SCM cont, SCM args)
 281 #define FUNC_NAME "continuation_apply"
 282 {
 283   scm_i_thread *thread = SCM_I_CURRENT_THREAD;
 284   scm_t_contregs *continuation = SCM_CONTREGS (cont);
 285
 286   if (continuation->root != thread->continuation_root)
 287     {
 288       SCM_MISC_ERROR
 289         ("invoking continuation would cross continuation barrier: ~A",
 290          scm_list_1 (cont));
 291     }
 292
 293   scm_dynthrow (cont, scm_values (args));
 294   return SCM_UNSPECIFIED; /* not reached */
 295 }
 296 #undef FUNC_NAME
 297
 298 SCM
 299 scm_i_with_continuation_barrier (scm_t_catch_body body,
 300                                  void *body_data,
 301                                  scm_t_catch_handler handler,
 302                                  void *handler_data,
 303                                  scm_t_catch_handler pre_unwind_handler,
 304                                  void *pre_unwind_handler_data)
 305 {
 306   SCM_STACKITEM stack_item;
 307   scm_i_thread *thread = SCM_I_CURRENT_THREAD;
 308   SCM old_controot;
 309   SCM_STACKITEM *old_contbase;
 310   scm_t_debug_frame *old_lastframe;
 311   SCM result;
 312
 313   /* Establish a fresh continuation root.
 314    */
 315   old_controot = thread->continuation_root;
 316   old_contbase = thread->continuation_base;
 317   old_lastframe = thread->last_debug_frame;
 318   thread->continuation_root = scm_cons (thread->handle, old_controot);
 319   thread->continuation_base = &stack_item;
 320   thread->last_debug_frame = NULL;
 321
 322   /* Call FUNC inside a catch all.  This is now guaranteed to return
 323      directly and exactly once.
 324   */
 325   result = scm_c_catch (SCM_BOOL_T,
 326                         body, body_data,
 327                         handler, handler_data,
 328                         pre_unwind_handler, pre_unwind_handler_data);
 329
 330   /* Return to old continuation root.
 331    */
 332   thread->last_debug_frame = old_lastframe;
 333   thread->continuation_base = old_contbase;
 334   thread->continuation_root = old_controot;
 335
 336   return result;
 337 }
 338
 339 struct c_data {
 340   void *(*func) (void *);
 341   void *data;
 342   void *result;
 343 };
 344
 345 static SCM
 346 c_body (void *d)
 347 {
 348   struct c_data *data = (struct c_data *)d;
 349   data->result = data->func (data->data);
 350   return SCM_UNSPECIFIED;
 351 }
 352
 353 static SCM
 354 c_handler (void *d, SCM tag, SCM args)
 355 {
 356   struct c_data *data = (struct c_data *)d;
 357   data->result = NULL;
 358   return SCM_UNSPECIFIED;
 359 }
 360
 361 void *
 362 scm_c_with_continuation_barrier (void *(*func) (void *), void *data)
 363 {
 364   struct c_data c_data;
 365   c_data.func = func;
 366   c_data.data = data;
 367   scm_i_with_continuation_barrier (c_body, &c_data,
 368                                    c_handler, &c_data,
 369                                    scm_handle_by_message_noexit, NULL);
 370   return c_data.result;
 371 }
 372
 373 struct scm_data {
 374   SCM proc;
 375 };
 376
 377 static SCM
 378 scm_body (void *d)
 379 {
 380   struct scm_data *data = (struct scm_data *)d;
 381   return scm_call_0 (data->proc);
 382 }
 383
 384 static SCM
 385 scm_handler (void *d, SCM tag, SCM args)
 386 {
 387   return SCM_BOOL_F;
 388 }
 389
 390 SCM_DEFINE (scm_with_continuation_barrier, "with-continuation-barrier", 1,0,0,
 391             (SCM proc),
 392 "Call @var{proc} and return its result.  Do not allow the invocation of\n"
 393 "continuations that would leave or enter the dynamic extent of the call\n"
 394 "to @code{with-continuation-barrier}.  Such an attempt causes an error\n"
 395 "to be signaled.\n"
 396 "\n"
 397 "Throws (such as errors) that are not caught from within @var{proc} are\n"
 398 "caught by @code{with-continuation-barrier}.  In that case, a short\n"
 399 "message is printed to the current error port and @code{#f} is returned.\n"
 400 "\n"
 401 "Thus, @code{with-continuation-barrier} returns exactly once.\n")
 402 #define FUNC_NAME s_scm_with_continuation_barrier
 403 {
 404   struct scm_data scm_data;
 405   scm_data.proc = proc;
 406   return scm_i_with_continuation_barrier (scm_body, &scm_data,
 407                                           scm_handler, &scm_data,
 408                                           scm_handle_by_message_noexit, NULL);
 409 }
 410 #undef FUNC_NAME
 411
 412 void
 413 scm_init_continuations ()
 414 {
 415   scm_tc16_continuation = scm_make_smob_type ("continuation", 0);
 416   scm_set_smob_mark (scm_tc16_continuation, continuation_mark);
 417   scm_set_smob_free (scm_tc16_continuation, continuation_free);
 418   scm_set_smob_print (scm_tc16_continuation, continuation_print);
 419   scm_set_smob_apply (scm_tc16_continuation, continuation_apply, 0, 0, 1);
 420 #include "libguile/continuations.x"
 421 }
 422
 423 /*
 424   Local Variables:
 425   c-file-style: "gnu"
 426   End:
 427 */