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