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