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